Source File testing/testing.ils

    1 ;;; testing.ils --- Lightweight testing framework
    2 
    3 ;; Copyright (C) 2012-2013  Damien Diederen
    4 
    5 ;; @author Damien Diederen <dd@crosstwine.com>
    6 
    7 ;; All Rights Reserved.
    8 ;;
    9 ;; NOTICE: All information, intellectual and technical concepts
   10 ;; contained herein are, and remain the property of Damien Diederen
   11 ;; and his suppliers, if any.  Dissemination of this information or
   12 ;; reproduction of this material is strictly forbidden unless prior
   13 ;; written permission is obtained from Damien Diederen.
   14 
   15 ;;; Commentary:
   16 
   17 ;; Package testing (global prefix VedaTesting) provides support for
   18 ;; automated testing of SKILL(++) packages.  It is a port of the Go
   19 ;; testing framework (http://golang.org/src/pkg/testing/testing.go)
   20 ;; as provided by go1.0.2.
   21 ;;
   22 ;; It is intended to select and automate the execution of any method
   23 ;; of the form
   24 ;;
   25 ;;     (defmethod Test_Xxx ((context VedaTestingContext)) ...)
   26 ;;
   27 ;; where Xxx can be any alphanumeric string (but the first letter must
   28 ;; not be in [a-z]) and serves to identify the test routine.  These
   29 ;; Test_Xxx routines should be declared within the package they are
   30 ;; testing, in files ending in -test.il or -test.ils.
   31 ;;
   32 ;; This package does not yet implement the BenchmarkXxx or
   33 ;; Example{F,T,T_M} features of the Go testing package.
   34 
   35 ;;; Code:
   36 
   37 ;; Context instances are passed to Test methods to manage test state
   38 ;; and support test logs.  Logs are accumulated during execution and
   39 ;; dumped to a file or standard output depending on configuration
   40 ;; options.
   41 (defclass VedaTestingContext ()
   42   (;; Name of the test being executed.
   43    ;;
   44    ;; @type {string}
   45    (name        @initarg  name
   46                 @reader GetName)
   47    ;; @ignore
   48    ;; @type {list}
   49    (packagePath @initarg  packagePath
   50                 @reader GetPackagePath)
   51    ;; @ignore
   52    ;; @type {list}
   53    (output      @initform nil)
   54    ;; A boolean indicating whether the test has failed or not.
   55    ;; Defaults to nil.
   56    ;;
   57    ;; @type (or symbol list)
   58    (failed      @initform nil
   59                 @reader GetFailed
   60                 @writer SetFailed)
   61    ;; @ignore
   62    ;; @type (or string list)
   63    (start       @initform nil)
   64    ;; The duration of the text execution, in seconds, or nil if the
   65    ;; test hasn't been run or timing could not be measured.
   66    ;;
   67    ;; @type (or fixnum flonum list)
   68    (duration    @initform nil
   69                 @reader GetDuration)))
   70 
   71 ;; Class VedaTestingOptions holds the options that are used for
   72 ;; running tests.
   73 (defclass VedaTestingOptions ()
   74   (;; Verbosity level.  Chatty above 4; defaults to 0.
   75    ;;
   76    ;; @type {fixnum}
   77    (verbose        @initarg verbose
   78                    @initform 0
   79                    @reader GetVerboseLevel
   80                    @writer SetVerboseLevel)
   81    ;; Report format, one of the following symbols: (text xml void).
   82    ;; Defaults to text.
   83    ;;
   84    ;; @type {symbol}
   85    (reportFormat   @initarg reportFormat
   86                    @initform 'text
   87                    @reader GetReportFormat
   88                    @writer SetReportFormat)
   89    ;; Filename used by XML report writer.  Defaults to nil, which maps
   90    ;; to "./result.xml".
   91    ;;
   92    ;; @type (or string list)
   93    (reportFilename @initarg reportFilename
   94                    @initform nil
   95                    @reader GetReportFilename
   96                    @writer SetReportFilename)))
   97 
   98 ;; Note: A number of symbols below are excluded from the API
   99 ;; documentation because they are just imported from package via
  100 ;; source merging for bootstrapping purposes.
  101 
  102 ;; Class AbstractInfo holds information that is common to all
  103 ;; packages, independently of their underlying representation.
  104 ;;
  105 ;; @ignore Cf. "bootstrapping" note above.
  106 (defclass VedaTestingPackageAbstractInfo ()
  107   (;; The name of the package, as understood by the Info/Load
  108    ;; functions.
  109    ;;
  110    ;; @type {string}
  111    (name
  112     @initarg name
  113     @reader GetName)
  114    ;; The package's synopsis.
  115    ;;
  116    ;; @type {string}
  117    (description
  118     @initarg description
  119     @reader GetDescription)
  120    ;; A (possibly empty) list of package authors strings, each having
  121    ;; the following form (cf. name-addr production in RFC 5322):
  122    ;;
  123    ;;     Human-readable Name <email@example.com>
  124    ;;
  125    ;; @type {list}
  126    (authors
  127     @initarg authors
  128     @reader GetAuthors)))
  129 
  130 ;; Class FilesystemInfo describes filesystem-based packages as
  131 ;; "natively" implemented by this package.
  132 ;;
  133 ;; @ignore Cf. "bootstrapping" note above.
  134 (defclass VedaTestingPackageFilesystemInfo (VedaTestingPackageAbstractInfo)
  135   (;; The directory of the search path in which the package was found,
  136    ;; a /-terminated string.
  137    ;;
  138    ;; @type {string}
  139    (base
  140     @initarg base
  141     @reader GetBaseDir)
  142    ;; The titular file containing package information.
  143    ;;
  144    ;; @type {string}
  145    (header
  146     @initarg header
  147     @reader GetHeaderFilename)
  148    ;; A list of other packages required by this package.  The contents
  149    ;; of this field can be controlled via the @requires tag, e.g.:
  150    ;;
  151    ;;     ;; @requires bar, baz
  152    ;;
  153    ;; @type {list}
  154    (requires
  155     @initarg requires
  156     @reader GetPackageRequires)
  157    ;; The package's source files, in load order.
  158    ;;
  159    ;; The contents of this field can be controlled via the @load tag,
  160    ;; e.g.:
  161    ;;
  162    ;;     ;; @load foo.il, bar.ils
  163    ;;
  164    ;; or
  165    ;;
  166    ;;     ;; @load foo.il, bar.ils, ...
  167    ;;
  168    ;; where the ellipsis means that any other source file found in the
  169    ;; package's directory is to be loaded after foo.il and bar.ils (in
  170    ;; an undefined order).
  171    ;;
  172    ;; @type {list}
  173    (sources
  174     @initarg sources
  175     @reader GetSourceFilenames)
  176    ;; Package test files, in load order.
  177    ;;
  178    ;; @type {list}
  179    (tests
  180     @initarg tests
  181     @reader GetTestFilenames)))
  182 
  183 ;; printObject formats unreadable FilesystemInfo instances for
  184 ;; diagnostic purposes.
  185 ;;
  186 ;; @ignore Cf. "bootstrapping" note above.
  187 (defmethod printObject ((pi VedaTestingPackageFilesystemInfo)
  188                         @optional (port poport))
  189   (fprintf port "#<%s %L; base: %L>"
  190            (className (classOf pi)) pi->name pi->base))
  191 
  192 ;; Class SearchOptions holds options that are used for locating
  193 ;; packages; cf. PackageLoad and PackageInfo.
  194 ;;
  195 ;; @ignore Cf. "bootstrapping" note above.
  196 (defclass VedaTestingPackageSearchOptions ()
  197   (;; The list of /-terminated directories which are searched (in
  198    ;; order) for packages.  Non-anchored directories are relative to
  199    ;; the execution directory.
  200    ;;
  201    ;; Defaults to searching pkg/ then ../.
  202    ;;
  203    ;; @type {list}
  204    (searchPath
  205     @initarg searchPath
  206     @initform '("pkg/" "../")
  207     @reader GetSearchPath
  208     @writer SetSearchPath)
  209    ;; When non-nil, gather package information in an asynchronous
  210    ;; manner. The handler must obey a specific VedaPackageAsync
  211    ;; protocol, which is left undocumented for now.
  212    ;;
  213    ;; @type {t}
  214    (asyncHandler
  215     @initarg asyncHandler
  216     @initform nil
  217     @reader GetAsyncHandler
  218     @writer SetAsyncHandler)))
  219 
  220 ;; Class LoadOptions holds options that are used when loading
  221 ;; packages; cf. PackageLoad.
  222 ;;
  223 ;; @ignore Cf. "bootstrapping" note above.
  224 (defclass VedaTestingPackageLoadOptions (VedaTestingPackageSearchOptions)
  225   (;; When t, honor the package's @requires tag.  Otherwise, a
  226    ;; (possibly) empty list of packages which are to be required
  227    ;; before the target.
  228    ;;
  229    ;; Defaults to t.
  230    ;;
  231    ;; @type (or symbol list)
  232    (requires
  233     @initarg requires
  234     @initform t
  235     @reader GetRequires
  236     @writer SetRequires)
  237    ;; When t, reset the table of loaded packages before loading the
  238    ;; target.  Otherwise, a (possibly) empty list of package names to
  239    ;; be evicted from the table of loaded packages before loading the
  240    ;; target.
  241    ;;
  242    ;; Defaults to nil.
  243    ;;
  244    ;; @type (or symbol list)
  245    (forceReload
  246     @initarg forceReload
  247     @initform nil
  248     @reader GetForceReload
  249     @writer SetForceReload)))
  250 
  251 ;; Package entry points.
  252 
  253 (define VedaTestingRunTests nil)
  254 (define VedaTestingRunTestsFromFiles nil)
  255 (define VedaTestingPackageInfo nil)
  256 (define VedaTestingPackageLoad nil)
  257 (define VedaTestingRunTestsOnPackage nil)
  258 
  259 ;; Scope/hide utility functions and related data.
  260 (let ()
  261 
  262   ;; Default options for the RunTests* entry points, if not overriden
  263   ;; by ?options.
  264   (define defaultTestingOptions
  265       (makeInstance 'VedaTestingOptions))
  266 
  267   ;; Fail marks the function as having failed but continues execution.
  268   (defmethod VedaTestingFail ((context VedaTestingContext))
  269     (SetFailed context t)
  270     t)
  271 
  272   ;; FailNow marks the function as having failed and stops its execution.
  273   ;; Execution will continue at the next test or benchmark.
  274   (defmethod VedaTestingFailNow ((context VedaTestingContext))
  275     (VedaTestingFail context)
  276     (err nil))
  277 
  278   ;; Log appends lines of output to the current context.
  279   (defun Log (context s)
  280     (let ((lines (parseString s "\n"))
  281           (output (slotValue context 'output)))
  282       (foreach line lines
  283         (push line output))
  284       (setSlotValue context 'output output))
  285     t)
  286 
  287   ;; Format works around the fact that sprintf in SKILL is not a
  288   ;; function, and cannot be applied to a list of arguments.  The
  289   ;; workaround is ugly and expensive, involving dynamic code
  290   ;; generation and a call to eval.
  291   ;;
  292   ;; @param {string} format
  293   (defun Format (format @rest args)
  294     (cond
  295       ;; Any hope to use this alternative printer?
  296       ((isCallable 'XtsSprintf)
  297        (apply XtsSprintf format args))
  298       (t
  299        (let ((code (nconc (list 'sprintf nil format)
  300                           (foreach mapcar arg args
  301                             (list 'quote arg)))))
  302          (eval code)))))
  303 
  304   ;; Log formats its arguments using default formatting, and records
  305   ;; the text in the error log.
  306   (defmethod VedaTestingLog ((context VedaTestingContext) @rest args)
  307     (let ((pieces nil))
  308       (foreach arg args
  309         (when pieces
  310           (push " " pieces))
  311         (cond
  312           ((stringp arg)
  313            (push arg pieces))
  314           (t
  315            (push (sprintf nil "%L" arg) pieces))))
  316       (Log context (buildString (reverse pieces) ""))))
  317 
  318   ;; Logf formats its arguments according to the format, analogous to
  319   ;; printf, and records the text in the error log.
  320   (defmethod VedaTestingLogf ((context VedaTestingContext) format @rest args)
  321     (Log context (apply Format format args)))
  322 
  323   ;; Error is equivalent to (Log) followed by (Fail).
  324   (defmethod VedaTestingError ((context VedaTestingContext) @rest args)
  325     (apply VedaTestingLog context args)
  326     (VedaTestingFail context))
  327 
  328   ;; Errorf is equivalent to (Logf) followed by (Fail).
  329   (defmethod VedaTestingErrorf ((context VedaTestingContext) format @rest args)
  330     (apply VedaTestingLogf context format args)
  331     (VedaTestingFail context))
  332 
  333   ;; Fatal is equivalent to (Log) followed by (FailNow).
  334   (defmethod VedaTestingFatal ((context VedaTestingContext) @rest args)
  335     (apply VedaTestingLog context args)
  336     (VedaTestingFailNow context))
  337 
  338   ;; Fatalf is equivalent to (Logf) followed by (FailNow).
  339   (defmethod VedaTestingFatalf ((context VedaTestingContext) format @rest args)
  340     (apply VedaTestingLogf context format args)
  341     (VedaTestingFailNow context))
  342 
  343   ;; Internal test runner method.
  344   (defun TRunner (context f traceOnErrorP)
  345     (setSlotValue context 'start (getCurrentTime))
  346     (let (measured)
  347       (letseq ((wf (if (isCallable 'measureTime)
  348                        (lambda (context)
  349                          (setq measured
  350                                (caddr (measureTime (funcall f context)))))
  351                        f))
  352                (r (errset (funcall wf context) traceOnErrorP)))
  353         (unless r
  354           (SetFailed context t)))
  355       (let ((duration (cond
  356                         ((numberp measured)
  357                          ((fix (measured * 100.0)) / 100.0))
  358                         (t
  359                          (compareTime (slotValue context 'start)
  360                                       (getCurrentTime))))))
  361         (setSlotValue context 'duration duration))))
  362 
  363   ;; BuildOutput generates indented output text for report formatting.
  364   (defun BuildOutput (context)
  365     (let ((output (slotValue context 'output)))
  366       (if output
  367           (strcat "\t" (buildString (reverse output) "\n\t") "\n")
  368           "")))
  369 
  370   ;; Returns whether the options' verbose level is set higher than 4.
  371   (defun Chattyp (options)
  372     ((GetVerboseLevel options) > 4))
  373 
  374   ;; TextReporter returns a report function which dumps
  375   ;; lightly-formatted test status information to standard output.
  376   (defun TextReporter (options)
  377     (let ((chattyp (Chattyp options)))
  378       (lambda (event @rest args)
  379         (case event
  380           (startTest
  381            (let ((context (car args)))
  382              (when chattyp
  383                (printf "=== RUN %s\n" (GetName context)))))
  384           (endTest
  385            (let ((context (car args)))
  386              (when (or (GetFailed context) chattyp)
  387                (let ((duration (GetDuration context)))
  388                  (let ((tstr (if (plusp duration)
  389                                  (sprintf nil " (%L seconds)" duration)
  390                                  ""))
  391                        (head (if (GetFailed context) "FAIL" "PASS"))
  392                        (format "--- %s: %s%s\n%s"))
  393                    (printf format head (GetName context)
  394                            tstr (BuildOutput context)))))))))))
  395 
  396   (defun GenTimestamp ()
  397     ;; TODO: Use getCurrentTime, and convert to ISO!
  398     "2012-09-25T18:48:46")
  399 
  400   ;; Characters which must be escaped in XML, no matter what.
  401   (define xmlMustEscapes
  402       '(("&" "&amp;")
  403         ("<" "&lt;")))
  404 
  405   ;; Characters which must be escaped in XML when outputting '-quoted
  406   ;; attribute values.
  407   (define xmlAposEscapes
  408       (append
  409        '(("'" "&apos"))
  410        xmlMustEscapes))
  411 
  412   ;; XmlEscape escapes a string with a specific alist of replacements.
  413   (defun XmlEscape (string escapes)
  414     (cond
  415       ((exists entry escapes
  416          (nindex string (car entry)))
  417        (letseq ((parts (parseString string ""))
  418                 (safe (foreach mapcar part parts
  419                         (let ((it (assoc part escapes)))
  420                           (if it (cadr it) part)))))
  421          (buildString safe "")))
  422       (t
  423        string)))
  424 
  425   ;; XmlEscaper returns a function which accepts one string arguments,
  426   ;; and will XmlEscape that string with the passed-in alist of
  427   ;; replacements.
  428   (defun XmlEscaper (escapes)
  429     (lambda (string)
  430       (XmlEscape string escapes)))
  431 
  432   ;; WriteXml writes a mostly-JUnit-compatible XML testing report to a
  433   ;; stream.  It also takes a list of contexts, and the corresponding
  434   ;; package name (or nil if unknown) as arguments.
  435   (defun WriteXml (stream contexts pkg)
  436     (let ((EA (XmlEscaper xmlAposEscapes))
  437           (EB (XmlEscaper xmlMustEscapes))
  438           (pkg (or pkg "<None>"))
  439           (timestamp (GenTimestamp))
  440           (testCount 0)
  441           (failureCount 0)
  442           (totalTime 0)
  443           (otherOutputs nil))
  444       (foreach context contexts
  445         (setq testCount (testCount + 1))
  446         (when (GetFailed context)
  447           (setq failureCount (failureCount + 1)))
  448         (setq totalTime (totalTime + (GetDuration context))))
  449       (fprintf stream "<?xml version='1.0' encoding='ISO-8859-1'?>\n")
  450       (fprintf stream "<testsuites>\n")
  451       (fprintf stream "  <testsuite package='%s' id='0' name='Unknown'\n"
  452                (EA pkg))
  453       (fprintf stream "             timestamp='%s' hostname='localhost'\n"
  454                (EA timestamp))
  455       (fprintf stream "             tests='%d' failures='%d' errors='0'\n"
  456                testCount failureCount)
  457       (fprintf stream "             time='%L'>\n"
  458                totalTime)
  459       (fprintf stream "    <properties/>\n")
  460       (foreach context contexts
  461         (fprintf stream "    <testcase name='%s' classname='t' time='%L'>\n"
  462                  (EA (GetName context))
  463                  (GetDuration context))
  464         (let ((lines (reverse (slotValue context 'output))))
  465           (cond
  466             ((GetFailed context)
  467              (let ((messageMea (when lines
  468                                  (sprintf nil " message='%s'"
  469                                           (EA (car lines))))))
  470                (fprintf stream "      <failure type='Fail'%s>"
  471                         (or messageMea ""))
  472                (foreach line lines
  473                  (fprintf stream "%s\n" (EB line)))
  474                (fprintf stream "</failure>\n")))
  475             (t
  476              (push lines otherOutputs))))
  477         (fprintf stream "    </testcase>\n"))
  478       (cond
  479         ((null otherOutputs)
  480          (fprintf stream "    <system-out/>\n"))
  481         (t
  482          (fprintf stream "    <system-out>")
  483          (foreach lines (reverse otherOutputs)
  484            (foreach line lines
  485              (fprintf stream "%s\n" (EB line))))
  486          (fprintf stream "</system-out>\n")))
  487       (fprintf stream "    <system-err/>\n")
  488       (fprintf stream "  </testsuite>\n")
  489       (fprintf stream "</testsuites>\n")))
  490 
  491   ;; XmlReporter returns a report function which writes test events to
  492   ;; a file in XML format.
  493   (defun XmlReporter (options pkg)
  494     (let ((chattyp (Chattyp options))
  495           (filename (or (GetReportFilename options)
  496                         "./result.xml"))
  497           (contexts nil))
  498       (lambda (event @rest args)
  499         (case event
  500           (startTest
  501            (let ((context (car args)))
  502              (when chattyp
  503                (printf "=== RUN %s\n" (GetName context)))))
  504           (endTest
  505            (let ((context (car args)))
  506              (push context contexts)))
  507           (endTestsuite
  508            (when contexts
  509              (let ((stream (or (outfile filename)
  510                                (error "Cannot open %L for writing." filename))))
  511                (WriteXml stream (reverse contexts) pkg)
  512                (close stream))))))))
  513 
  514   ;; DevNull is a pseudo-report function which ignores its arguments.
  515   (defun DevNull (@rest _args)
  516     nil)
  517 
  518   ;; Reporter returns a report function configured according to
  519   ;; options and the (possibly nil) package name pkg.
  520   (defun Reporter (options pkg)
  521     (let ((reportFormat (GetReportFormat options)))
  522       (case reportFormat
  523         (text (TextReporter options))
  524         (xml  (XmlReporter options pkg))
  525         ;; KLUDGE: This report format is to disappear and be replaced by
  526         ;; output redirection at some point.
  527         (void DevNull)
  528         (t (error "Unsupported report format %L" reportFormat)))))
  529 
  530   ;; Internal helper for RunTests*.
  531   (defun RunTestsInternal (tests options @key pkg packagePath)
  532     (let ((reporter (Reporter options pkg))
  533           (ok (when tests t)))
  534       (let ((traceOnErrorP (neq reporter DevNull)))
  535         (funcall reporter 'startTestsuite)
  536         (foreach test tests
  537           (letseq ((name (strcat test))
  538                    (context (makeInstance 'VedaTestingContext
  539                                           ?name name
  540                                           ?packagePath packagePath)))
  541             (funcall reporter 'startTest context)
  542             (TRunner context test traceOnErrorP)
  543             (funcall reporter 'endTest context)
  544             (setq ok (and ok (not (GetFailed context))))))
  545         (funcall reporter 'endTestsuite ok))
  546       ok))
  547 
  548   ;; RunTests runs the test functions in tests, a list of funcallable
  549   ;; symbols.  Returns t if none of the tests failed, nil otherwise.
  550   ;;
  551   ;; Test execution and report generation is controlled via ?options;
  552   ;; if nil, a default-initialized instance of VedaTestingOptions is
  553   ;; used.
  554   ;;
  555   ;; @param {list} tests
  556   ;; @param (or VedaTestingOptions list) options
  557   ;; @return (or symbol list)
  558   (defun RunTests (tests @key options)
  559     (RunTestsInternal tests (or options defaultTestingOptions)))
  560 
  561   ;; FindTestMethods looks into the global environment callable
  562   ;; symbols starting with the Test_ prefix.
  563   (defun FindTestMethods ()
  564     (let ((syms (rexMatchList "^Test_" (symeval 'oblist))))
  565       (setof sym syms
  566         (and (isCallable sym)
  567              ;; TODO: Ensure that the callable is indeed a
  568              ;; one-argument method specializing on VedaTestingContext.
  569              t))))
  570 
  571   ;; MaskExistingTests records the currently defined Test_ functions
  572   ;; in a hash table, and (temporarily) removes their definitions.
  573   (defun MaskExistingTests ()
  574     (let ((pre (makeTable 'pre nil))
  575           (old (FindTestMethods)))
  576       (foreach sym old
  577         (setarray pre sym (getd sym))
  578         (putd sym nil))
  579       pre))
  580 
  581   ;; RestoreAndFindNewTests finds the current set of Test_ functions,
  582   ;; and restores the ones which have been previously recorded and
  583   ;; haven't been redefined.
  584   (defun RestoreAndFindNewTests (pre)
  585     (let ((now (FindTestMethods)))
  586       (foreach sym now
  587         (remove sym pre))
  588       (foreach sym pre
  589         ;; Restore original value.
  590         (putd sym (arrayref pre sym)))
  591       now))
  592 
  593   ;; LoadTestsUsingLoader loads test files via a loader function while
  594   ;; monitoring the set of defined test methods, and returns the
  595   ;; symbols naming newly-defined ones.  Cf. RunTestsFromFiles for
  596   ;; details.
  597   ;;
  598   ;; TODO: The current implementation is not as restrictive as it
  599   ;; should, and might erroneously match/return unrelated Test_
  600   ;; functions.
  601   (defun LoadTestsUsingLoader (loader)
  602     (let ((pre (MaskExistingTests)))
  603       (funcall loader ?subset 'tests)
  604       (RestoreAndFindNewTests pre)))
  605 
  606   ;; RunTestsFromFiles loads files, a list of filenames, while
  607   ;; monitoring the set of methods having the following form:
  608   ;;
  609   ;;     (defmethod Test_Xxx ((context VedaTestingContext)) ...)
  610   ;;
  611   ;; It then executes the newly-defined/redefined ones.
  612   ;;
  613   ;; Cf. RunTests for more information about ?options.
  614   ;;
  615   ;; @param {list} files
  616   ;; @param (or VedaTestingOptions list) options
  617   ;; @return (or symbol list)
  618   (defun RunTestsFromFiles (files @key options)
  619     (let ((tests (LoadTestsUsingLoader (FilesLoader files))))
  620       (RunTests tests ?options options)))
  621 
  622   ;; Default options used by Load/Info, if not overriden by ?options.
  623   (define defaultOptions
  624       (makeInstance 'VedaTestingPackageLoadOptions))
  625 
  626   ;; @region Common header parsing
  627 
  628   ;; Generic utilities.
  629 
  630   ;; TrimLeftIndex indicates how to trim the substring of string
  631   ;; delimited by (from, to) to remove all leading characters
  632   ;; contained in string characterBag.
  633   ;;
  634   ;; Both from and to are 1-based, inclusive indices; use 1 and
  635   ;; (strlen string) to trim the whole string.
  636   ;;
  637   ;; Returns the start index of the resulting substring.
  638   (defun TrimLeftIndex (characterBag string from to)
  639     (while (and (from <= to)
  640                 (nindex characterBag (getchar string from)))
  641       (setq from (from + 1)))
  642     from)
  643 
  644   ;; TrimLeft returns a substring of string with all characters in
  645   ;; characterBag stripped off the beginning.
  646   ;;
  647   ;; If no characters need to be trimmed, string is returned.
  648   (defun TrimLeft (characterBag string)
  649     (let ((a (TrimLeftIndex characterBag string 1 (strlen string))))
  650       (cond
  651         ((onep a)
  652          string)
  653         ((a > (strlen string))
  654          "")
  655         (t
  656          (substring string a)))))
  657 
  658   ;; TrimRightIndex indicates how to trim the substring of string
  659   ;; delimited by (from, to) to remove all trailing characters
  660   ;; contained in string characterBag.
  661   ;;
  662   ;; Both from and to are 1-based, inclusive indices; use 1 and
  663   ;; (strlen string) to trim the whole string.
  664   ;;
  665   ;; Returns the end index in the resulting substring.
  666   (defun TrimRightIndex (characterBag string from to)
  667     (while (and (from <= to)
  668                 (nindex characterBag (getchar string to)))
  669       (setq to (to - 1)))
  670     to)
  671 
  672   ;; TrimRight returns a substring of string with all characters in
  673   ;; characterBag stripped off the end.
  674   ;;
  675   ;; If no characters need to be trimmed, string is returned.
  676   (defun TrimRight (characterBag string)
  677     (letseq ((n (strlen string))
  678              (b (TrimRightIndex characterBag string 1 n)))
  679       (if (equal b n)
  680           string
  681           (substring string 1 b))))
  682 
  683   ;; PrefixP returns the length of needle if it is a prefix of
  684   ;; haystack, nil otherwise.
  685   (defun PrefixP (needle haystack)
  686     (let ((n (strlen needle)))
  687       (when (n <= (strlen haystack))
  688         (let ((i 1))
  689           (while (and i (i <= n))
  690             (setq i (when (eq (getchar needle i) (getchar haystack i))
  691                       (i + 1))))
  692           i))))
  693 
  694   ;; SuffixP returns the index of the last character before needle in
  695   ;; haystack when the former is a suffix of the latter.  Otherwise,
  696   ;; returns nil.
  697   (defun SuffixP (needle haystack)
  698     (let ((n (strlen needle))
  699           (m (strlen haystack)))
  700       (when (n <= m)
  701         (let ((i 1)
  702               (offset (m - n)))
  703           (while (and i (i <= n))
  704             (setq i (when (eq (getchar needle i)
  705                               (getchar haystack (offset + i)))
  706                       (i + 1))))
  707           (when i
  708             offset)))))
  709 
  710   ;; Constants.
  711 
  712   ;; Minimum @-tag length, including @.
  713   (define minAtTagLength
  714       4)
  715 
  716   ;; An alist maping known @-tags to the corresponding DPL key.  Also
  717   ;; determines the DPL key order.
  718   (define knownTags
  719       '((nil            header)
  720         ("@description" description)
  721         ("@language"    language)
  722         ("@load"        load)
  723         ("@requires"    requires)
  724         ("@author"      authors)
  725         (nil            tags)))
  726 
  727   ;; Characters recognized as normal whitespace in headers.
  728   (define whitespaceBag
  729       " \t")
  730 
  731   ;; Characters recognized as trailing whitespace at the end of a
  732   ;; header line.
  733   (define trailingWhitespaceBag
  734       (strcat "\n" whitespaceBag))
  735 
  736   ;; TrimWs1 trims at most one whitespace character from the left of
  737   ;; the substring of line starting at from and whose length is n, as
  738   ;; well all of the trailing whitespace.
  739   (defun TrimWs1 (line from n)
  740     (letseq ((a (TrimLeftIndex whitespaceBag line from (min (from + 1) n)))
  741              (b (TrimRightIndex trailingWhitespaceBag line a n)))
  742       (cond
  743         ((a > b)
  744          "")
  745         (t
  746          (substring line a (b - a + 1))))))
  747 
  748   ;; TrimLineComment trims the leading line comment characters, the
  749   ;; first subsequent whitespace character, if any, and the trailing
  750   ;; whitespace off line.
  751   ;;
  752   ;; Returns the trimmed line, or nil if line isn't a line comment.
  753   (defun TrimLineComment (line)
  754     (letseq ((n (strlen line))
  755              (ic (TrimLeftIndex ";" line 1 n)))
  756       (when (ic > 1)
  757         (TrimWs1 line ic n))))
  758 
  759   ;; TrimBlockComment trims the leading banner characters (whitespace
  760   ;; followed by an asterisk), the first subsequent whitespace
  761   ;; character, if any, and the trailing whitespace off line, which
  762   ;; should be coming from a block comment.
  763   ;;
  764   ;; Returns the trimmed line.
  765   (defun TrimBlockComment (line)
  766     (letseq ((n (strlen line))
  767              (iw (TrimLeftIndex whitespaceBag line 1 n))
  768              (is (TrimLeftIndex "*" line iw (min (iw + 1) n))))
  769       (if (equal iw is)
  770           (TrimRight trailingWhitespaceBag line)
  771           (TrimWs1 line is n))))
  772 
  773   ;; Assoc list mapping prefix characters to the corresponding
  774   ;; trimmer.
  775   (define trimmers
  776       `((";"  ,TrimLineComment)
  777         ("/*" ,TrimBlockComment)))
  778 
  779   ;; SelectTrimmers select the header trimmer to use based on line,
  780   ;; which must be the first non-shebang line of the header block.
  781   (defun SelectTrimmer (line)
  782     (cadar (exists trimmer trimmers
  783              (PrefixP (car trimmer) line))))
  784 
  785   ;; ParseDescription parses a package's description line, which is
  786   ;; the first line in the package's titular file and has one of the
  787   ;; following formats:
  788   ;;
  789   ;;     ;;; <filename> --- <description>
  790   ;;
  791   ;;     /* <filename> --- <description>
  792   ;;
  793   ;; Returns the description, or nil if the line does not match one of
  794   ;; the required syntaxes.
  795   (defun ParseDescription (line filename)
  796     ;; FIXME: Should preserve tabs and multiple spaces.
  797     (let ((pieces (parseString line " \t\n")))
  798       (when (and (member (car pieces) '(";;;" "/*"))
  799                  (equal (cadr pieces) filename)
  800                  (equal (caddr pieces) "---"))
  801         (buildString (nthcdr 3 pieces)))))
  802 
  803   ;; SplitTag splits rawtag, which must start with an @-tag, at the
  804   ;; first tab and space character.
  805   ;;
  806   ;; Returns a 2-list with the parts, or (rawtag "") if no whitespace
  807   ;; character was found.
  808   (defun SplitTag (rawtag)
  809     (let ((i minAtTagLength)
  810           (n (strlen rawtag)))
  811       ;; Advance until first space or tab.
  812       (while (and (i <= n)
  813                   (not (nindex whitespaceBag (getchar rawtag i))))
  814         (setq i (i + 1)))
  815       (if (i > n)
  816           (list rawtag "")
  817           (list (substring rawtag 1 (i - 1))
  818                 (substring rawtag (i + 1))))))
  819 
  820   ;; MakeHeaderDpl generates a DPL by combining arguments and
  821   ;; extracting/parsing known tags out of the tags assoc list.
  822   (defun MakeHeaderDpl (header description languagep tags)
  823     (let ((kvs (makeTable 'knownTags nil)))
  824       (setarray kvs 'header header)
  825       (setarray kvs 'description description)
  826       (foreach tag tags
  827         (let ((key (cadr (assoc (car tag) knownTags)))
  828               (raw (cadr tag)))
  829           (cond
  830             ((and (eq key 'language) languagep)
  831              (setarray kvs key (concat (TrimLeft whitespaceBag raw))))
  832             ((memq key '(load requires))
  833              (setarray kvs key (parseString raw ", \t")))
  834             ((eq key 'authors)
  835              (setarray kvs key (cons (TrimLeft whitespaceBag raw)
  836                                      (arrayref kvs key))))
  837             ((eq key 'description)
  838              (setarray kvs key (TrimLeft whitespaceBag raw)))
  839             (t
  840              (let ((key 'tags))
  841                (setarray kvs key (cons tag (arrayref kvs key))))))))
  842       (cons nil
  843             (foreach mapcan entry knownTags
  844               (letseq ((key (cadr entry))
  845                        (cooked (arrayref kvs key)))
  846                 (when cooked
  847                   (list key cooked)))))))
  848 
  849   ;; ParseHeader tries and parses a comment header out of liner, a
  850   ;; function which returns the next line or nil on EOF.  If non-nil,
  851   ;; ?mustDescribe is the name of a package's titular file and is used
  852   ;; to parse/validate the description line.
  853   ;;
  854   ;; Returns a DPL on success, and nil if the header was absent or not
  855   ;; properly formatted.
  856   (defun ParseHeader (liner @key mustDescribe allowShebangP languagep)
  857     (let ((line nil)
  858           (lineno 0)
  859           (trimmer nil)
  860           (trimmed nil)
  861           (description nil)
  862           (tags nil)
  863           (tag nil)
  864           (it nil)
  865           (donep nil))
  866       (while (and (not donep) (setq line (funcall liner)))
  867         (setq lineno (lineno + 1))
  868         ;; Block comments end at the first */, but have a potentially
  869         ;; incomplete last line.
  870         (when (and (eq trimmer TrimBlockComment)
  871                    (setq it (nindex line "*/")))
  872           (setq line (substring line 1 (it - 1)))
  873           (setq donep t))
  874         (cond
  875           ((equal line "\n")
  876            ;; Continue, but prevent @-tag continuation.
  877            (setq tag nil))
  878           ((and allowShebangP (onep lineno) (PrefixP "#!" line))
  879            ;; Continue.
  880            )
  881           ((null (or trimmer (setq trimmer (SelectTrimmer line))))
  882            ;; No properly-formatted comment in here.
  883            (setq donep 'fail))
  884           ((or (null (setq trimmed (funcall trimmer line)))
  885                (member trimmed '("Commentary:" "Code:")))
  886            ;; The first non-comment line, or comment line consisting
  887            ;; of one of these markers, signals the end of the headers.
  888            (setq donep t))
  889           ((and mustDescribe (null description)
  890                 (not (setq description (ParseDescription line mustDescribe))))
  891            ;; Failed to parse the description line; this is not the
  892            ;; header we are looking for.
  893            (setq donep 'fail))
  894           ((and (PrefixP "@" trimmed)
  895                 ((strlen trimmed) >= minAtTagLength))
  896            (setq tag (SplitTag trimmed))
  897            (push tag tags))
  898           ((and tag (nequal trimmed ""))
  899            ;; @-tag continuation line.
  900            (let ((v (strcat (cadr tag) " " (TrimLeft " \t" trimmed))))
  901              (rplaca (cdr tag) v)))
  902           (t
  903            (setq tag nil))))
  904       (unless (eq donep 'fail)
  905         (MakeHeaderDpl mustDescribe description languagep tags))))
  906 
  907   ;; @endregion Common header parsing
  908 
  909   ;; BasicParseHeader invokes ParseHeader on liner, if non-nil, and
  910   ;; returns its results; it returns nil otherwise.  The header
  911   ;; ?mustDescribe filename.
  912   ;;
  913   ;; The liner, if any, must be callable with a single argument, t, in
  914   ;; which case it must close/free its resources (e.g. port).
  915   (defun BasicParseHeader (liner filename)
  916     (when liner
  917       (prog1
  918           (ParseHeader liner ?mustDescribe filename)
  919         ;; Close.
  920         (funcall liner t))))
  921 
  922   ;; MaybeFileLiner tries to return a closable liner
  923   ;; (cf. BasicParseHeader) reading from path, and returns nil if path
  924   ;; cannot be open for reading.
  925   (defun MaybeFileLiner (path)
  926     (let ((port (infile path))
  927           (line nil))
  928       (when port
  929         (lambda (@optional closep)
  930           (cond
  931             ((not closep)
  932              (gets line port))
  933             (t
  934              (close port)
  935              nil))))))
  936 
  937   ;; FilesLoader returns a function which loads the provided list of
  938   ;; filenames in order.  If ?dir is non-nil, it is prepended to each
  939   ;; file before attempting the load operation.
  940   (defun FilesLoader (filenames @key dir)
  941     (lambda (@rest _ignored)
  942       (foreach filename filenames
  943         (when dir
  944           (setq filename (strcat dir filename)))
  945         (load filename))
  946       t))
  947 
  948   ;; The ellipsis marker is used at the end of Load directives to
  949   ;; indicate that the other source files ought to be loaded, too.
  950   (define ellipsis
  951       "...")
  952 
  953   ;; ProcessLoadDirective checks that each entry in directive is also
  954   ;; present in files or is a trailing ellipsis.  Returns a list of
  955   ;; three values: the files from directive, whether a trailing
  956   ;; ellipsis was present, and the rest of the files.
  957   (defun ProcessLoadDirective (directive files)
  958     (let ((files (copy files))
  959           (ellipsisp nil))
  960       (let ((loads (foreach maplist dtail directive
  961                      (let ((file (car dtail)))
  962                        (cond
  963                          ((let ((ftail (member file files)))
  964                             (when ftail
  965                               (rplaca ftail nil)
  966                               file)))
  967                          ((and (equal file ellipsis)
  968                                (null (cdr dtail)))
  969                           (setq ellipsisp t)
  970                           nil)
  971                          (t
  972                           (error "No such file: %L; Load header: %L"
  973                                  file directive)))))))
  974         (list (remove nil loads) ellipsisp (remove nil files)))))
  975 
  976   ;; ClassifyFiles saves the files which match one of the subsets in a
  977   ;; correspondingly-named slot of a fresh DPL (Cf. fileSubsets
  978   ;; variable for an example of subset designators), and returns the
  979   ;; DPL.
  980   (defun ClassifyFiles (files subsets)
  981     (let ((dpl (list nil)))
  982       (foreach file files
  983         (exists subset subsets
  984           (let ((suffixes (car subset)))
  985             (exists suffix suffixes
  986               (when (SuffixP suffix file)
  987                 (letseq ((key (cadr subset))
  988                          (accum (get dpl key)))
  989                   (putprop dpl (cons file accum) key)))))))
  990       dpl))
  991 
  992   ;; fileSubsets holds subset designators for test and source files.
  993   (define fileSubsets
  994       '(;; Files ending with these two suffixes are test files.
  995         (("-test.ils" "-test.il") tests)
  996         ;; Files ending in .ils or .il and which are not considered
  997         ;; test files are source files.
  998         ((".ils" ".il")           sources)))
  999 
 1000   ;; Helper function for PackageInfoFromBase.
 1001   (defun FinalizePackageInfo (base pkg headerInfo loads ellipsisp files)
 1002     (letseq ((filesInfo (ClassifyFiles files fileSubsets))
 1003              (sources (cond
 1004                         ((and loads ellipsisp)
 1005                          (append loads filesInfo->sources))
 1006                         (loads)
 1007                         (t
 1008                          filesInfo->sources))))
 1009       (makeInstance 'VedaTestingPackageFilesystemInfo
 1010                     ?name pkg
 1011                     ?description headerInfo->description
 1012                     ?authors headerInfo->authors
 1013                     ?base base
 1014                     ?header headerInfo->header
 1015                     ?requires headerInfo->requires
 1016                     ?sources sources
 1017                     ?tests filesInfo->tests)))
 1018 
 1019   ;; PackageInfoFromBase returns file-based information about package
 1020   ;; pkg (contained below base, and for which some header info has
 1021   ;; been found).  It combines the header and file-gathered data into
 1022   ;; a fresh instance of VedaTestingPackageFilesystemInfo.
 1023   (defun PackageInfoFromBase (base pkg headerInfo files)
 1024     (apply FinalizePackageInfo base pkg headerInfo
 1025            (if headerInfo->load
 1026                (ProcessLoadDirective headerInfo->load files)
 1027                (list nil t files))))
 1028 
 1029   ;; PackageInfoHelper implements the logic of looking up and parsing
 1030   ;; a package's titular file in a straightforward manner.
 1031   (defun PackageInfoHelper (pkg bases suffixes)
 1032     (let (info)
 1033       (exists base bases
 1034         (let ((dir (strcat base pkg)))
 1035           (exists suffix suffixes
 1036             (letseq ((filename (strcat pkg suffix))
 1037                      (liner (MaybeFileLiner (strcat dir "/" filename)))
 1038                      (headerInfo (BasicParseHeader liner filename)))
 1039               (when headerInfo
 1040                 (let ((files (getDirFiles dir)))
 1041                   (setq info (PackageInfoFromBase base pkg headerInfo
 1042                                                   files))))))))
 1043       info))
 1044 
 1045   ;; PackageInfoAsyncHelper implements the logic of looking up and
 1046   ;; parsing a package's titular file in an asynchronous manner.  It
 1047   ;; performs the same steps as PackageInfoHelper above, but is
 1048   ;; written in continuation-passing style, and performs filesystem
 1049   ;; queries via the specified handler.
 1050   (defun PackageInfoAsyncHelper (handler pkg bases suffixes k)
 1051 
 1052     (defun IterSuffixes (base suffixes k)
 1053       (if (null suffixes)
 1054           (k nil)
 1055           (letseq ((filename (strcat pkg (car suffixes)))
 1056                    (path (strcat base pkg "/" filename)))
 1057             (VedaPackageAsyncMakeLiner handler path
 1058               (lambda (liner)
 1059                 (let ((info (BasicParseHeader liner filename)))
 1060                   (if info
 1061                       (k info)
 1062                       (IterSuffixes base (cdr suffixes) k))))))))
 1063 
 1064     (defun IterBases (bases k)
 1065       (if (null bases)
 1066           (k nil nil)
 1067           (IterSuffixes (car bases) suffixes
 1068                         (lambda (info)
 1069                           (if info
 1070                               (k (car bases) info)
 1071                               (IterBases (cdr bases) k))))))
 1072 
 1073     (defun Files (base info files)
 1074       (let ((packageInfo (when files
 1075                            (PackageInfoFromBase base pkg info files))))
 1076         (k handler packageInfo)))
 1077 
 1078     (defun HeaderInfo (base info)
 1079       (cond
 1080         ((null info)
 1081          (k handler nil))
 1082         (t
 1083          (let ((dir (strcat base pkg "/")))
 1084            (VedaPackageAsyncGetDirFiles handler dir
 1085                                         (lambda (files)
 1086                                           (Files base info files)))))))
 1087 
 1088     (IterBases bases HeaderInfo))
 1089 
 1090   ;; PackageInfoFromFilesystem tries and find package pkg under one of
 1091   ;; the bases, which are filesystem directory names.  The result is a
 1092   ;; fresh instance of VedaTestingPackageFilesystemInfo if found, nil
 1093   ;; otherwise.
 1094   ;;
 1095   ;; If asyncHandler is nil, the function operates in synchronous mode
 1096   ;; and returns the result in the usual way.  If an asyncHandler is
 1097   ;; specified, the function returns nil, and the result is
 1098   ;; transmitted via the VedaPackageAsync protocol.
 1099   ;;
 1100   ;; Cf. PackageInfoFromBase for more information.
 1101   (defun PackageInfoFromFilesystem (pkg bases asyncHandler)
 1102     (let ((suffixes '(".il" ".ils")))
 1103       (cond
 1104         ((null asyncHandler)
 1105          (PackageInfoHelper pkg bases suffixes))
 1106         (t
 1107          (PackageInfoAsyncHelper asyncHandler
 1108                                  pkg bases suffixes
 1109                                  VedaPackageAsyncResult)
 1110          nil))))
 1111 
 1112   ;; PackageInfo returns metadata about the package named by the
 1113   ;; string pkg, either by querying a hook or by searching a number of
 1114   ;; preset filesystem bases.
 1115   ;;
 1116   ;; It returns a concrete subclass of AbstractInfo, or nil if not
 1117   ;; found.
 1118   ;;
 1119   ;; ?options, if non-nil, must be an instance of SearchOptions. If
 1120   ;; nil, a default-initialized instance is used.
 1121   ;;
 1122   ;; The hook, if present, must be named VedaPackageInfoHook and is
 1123   ;; invoked as:
 1124   ;;
 1125   ;;     (VedaPackageInfoHook pkg)
 1126   ;;
 1127   ;; where pkg is the package name.
 1128   ;;
 1129   ;; @ignore Cf. "bootstrapping" note above.
 1130   ;; @param {string} pkg
 1131   ;; @param (or VedaTestingPackageSearchOptions list) options
 1132   ;; @return (or VedaTestingPackageAbstractInfo list)
 1133   (defun PackageInfo (pkg @key options)
 1134     (cond
 1135       ((isCallable 'VedaPackageInfoHook)
 1136        (funcall 'VedaPackageInfoHook pkg))
 1137       (t
 1138        (let ((options (or options defaultOptions)))
 1139          (PackageInfoFromFilesystem pkg
 1140                                     (GetSearchPath options)
 1141                                     (GetAsyncHandler options))))))
 1142 
 1143   ;; LoaderFromPackageInfo returns a function which will load a
 1144   ;; specific subset of the package described by info, an instance of
 1145   ;; VedaTestingPackageFilesystemInfo.
 1146   (defun LoaderFromPackageInfo (info subset)
 1147     (let (files)
 1148       (when (setq files (get info subset))
 1149         (let ((dir (strcat info->base info->name "/")))
 1150           (FilesLoader files ?dir dir)))))
 1151 
 1152   ;; LoadSubsetFromPackageInfo loads a specific subset of the package
 1153   ;; described by info, an instance of VedaTestingPackageFilesystemInfo.
 1154   (defun LoadSubsetFromPackageInfo (info subset)
 1155     (let ((loader (LoaderFromPackageInfo info subset)))
 1156       (if loader
 1157           (funcall loader ?subset subset)
 1158           (error "Don't know how to load %s from package %L."
 1159                  subset info)))
 1160     t)
 1161 
 1162   ;; Recursive helper for RequirePackage.
 1163   (defun RequirePackageRec (pkg loaded options noPackageRequiresP)
 1164     (let (info)
 1165       (cond
 1166         ((arrayref loaded pkg))
 1167         ((setq info (PackageInfo pkg ?options options))
 1168          (unless noPackageRequiresP
 1169            (foreach require info->requires
 1170              (RequirePackageRec require loaded options noPackageRequiresP)))
 1171          (LoadSubsetFromPackageInfo info 'sources)
 1172          (setarray loaded pkg info))
 1173         (t
 1174          (error "Package %L not found." pkg)))))
 1175 
 1176   ;; RequirePackage loads the sources from pkg if and only if it is
 1177   ;; not already indexed in the loaded table.  Each package mentioned
 1178   ;; in options->requires is "RequirePackage'd" before this one, as is
 1179   ;; any package mentioned in @requires--unless inhibited by the
 1180   ;; noPackageRequiresP option.
 1181   (defun RequirePackage (pkg loaded options)
 1182     (letseq ((requires (GetRequires options))
 1183              (noPackageRequiresP (neq requires t)))
 1184       (when (pairp requires)
 1185         (foreach require requires
 1186           (RequirePackageRec require loaded options noPackageRequiresP)))
 1187       (RequirePackageRec pkg loaded options noPackageRequiresP)))
 1188 
 1189   ;; BootstrapPackageInfo tries and determine package information from
 1190   ;; filename, which must be a .ils file.  This is used for
 1191   ;; bootstrapping purposes only; cf. loadedTable.
 1192   (defun BootstrapPackageInfo (filename)
 1193     (when (SuffixP ".ils" filename)
 1194       (let ((n (strlen filename))
 1195             (suffix (rindex filename "/")))
 1196         (cond
 1197           (suffix
 1198            (let ((slen (strlen suffix)))
 1199              (let ((pkg (substring suffix 2 (slen - 5)))
 1200                    (dir (strcat (substring filename 1 (n - slen + 1)) "../")))
 1201                (PackageInfoFromFilesystem pkg (list dir) nil))))
 1202           (t
 1203            (let ((pkg (substring filename 1 (n - 4))))
 1204              (PackageInfoFromFilesystem pkg '("../") nil)))))))
 1205 
 1206   ;; BootstrapMarkLoaded tries and mark the package this file was
 1207   ;; loaded from as (pre)loaded.  Note that this only work for
 1208   ;; single-ils-file packages.
 1209   (defun BootstrapMarkLoaded (table filename)
 1210     (when filename
 1211       (let ((info (BootstrapPackageInfo filename)))
 1212         (when info
 1213           (setarray table (GetName info) info)))))
 1214 
 1215   ;; The table of loaded packages.
 1216   (define loadedTable nil)
 1217 
 1218   (let ((queryFn 'VedaPackage__getLoadedTable))
 1219     (cond
 1220       ((isCallable queryFn)
 1221        (setq loadedTable (funcall queryFn)))
 1222       (t
 1223        (setq loadedTable (makeTable 'loaded nil))
 1224        (putd queryFn (lambda () loadedTable)))))
 1225 
 1226   ;; Override any existing entry, as we're being loaded now.
 1227   (when (isCallable 'get_filename)
 1228     (BootstrapMarkLoaded loadedTable (get_filename piport)))
 1229 
 1230   ;; CleanupLoadedTable removes entries selected by forceReload from
 1231   ;; the table of loaded packages.  Cf. GetForceReload in package
 1232   ;; loading options for a description of the forceReload parameter.
 1233   (defun CleanupLoadedTable (forceReload)
 1234     (let ((pkgs (cond
 1235                   ((eq forceReload t)
 1236                    loadedTable->?)
 1237                   ((pairp forceReload)
 1238                    forceReload)
 1239                   (t
 1240                    (error "Unrecognized force reload option %L."
 1241                           forceReload)))))
 1242       (foreach pkg pkgs
 1243         (remove pkg loadedTable))))
 1244 
 1245   ;; PackageLoad loads the sources of the package named by the string
 1246   ;; pkg, as well as its dependencies, as necessary or requested via
 1247   ;; the ?options argument.
 1248   ;;
 1249   ;; ?options, if non-nil, must be an instance of LoadOptions.  If
 1250   ;; nil, a default-initialized instance is used.
 1251   ;;
 1252   ;; The PackageInfo function is used for locating the package and its
 1253   ;; dependencies, using the same ?options argument as PackageLoad.
 1254   ;; An error is raised if one of the packages cannot be found.
 1255   ;;
 1256   ;; The function returns the concrete subclass of
 1257   ;; VedaTestingPackageAbstractInfo corresponding to pkg.
 1258   ;;
 1259   ;; @ignore Cf. "bootstrapping" note above.
 1260   ;; @param {string} pkg
 1261   ;; @param (or VedaTestingPackageLoadOptions list) options
 1262   ;; @return (or VedaTestingPackageAbstractInfo list)
 1263   (defun PackageLoad (pkg @key options)
 1264     (letseq ((options (or options defaultOptions))
 1265              (forceReload (GetForceReload options)))
 1266       (when forceReload
 1267         (CleanupLoadedTable forceReload))
 1268       (RequirePackage pkg loadedTable options)))
 1269 
 1270   ;; Create a copy of the default loaded table with some well-known
 1271   ;; packages considered loaded.  (These well-known packages must
 1272   ;; still be PackageInfo'able.)
 1273   (defun MakeLoadedTable ()
 1274     (let ((table (makeTable 'loaded nil)))
 1275       (foreach key loadedTable
 1276         (setarray table key (arrayref loadedTable key)))
 1277       (foreach def '(("run"
 1278                       defines Xts__sprintf
 1279                       tentativep t)
 1280                      ("testing"))
 1281         (let ((pkg (car def)))
 1282           (when (and (not (arrayref table pkg))
 1283                      (or (null def->defines) (isCallable def->defines)))
 1284             (let ((info (PackageInfo pkg)))
 1285               (cond
 1286                 (info
 1287                  (setarray table pkg info))
 1288                 ((not def->tentativep)
 1289                  (error "Cannot mark %L as preloaded." pkg)))))))
 1290       table))
 1291 
 1292   ;; RunTestsOnPackage finds the set of source and test files
 1293   ;; associated with package pkg, reloads all the source files, then
 1294   ;; loads and runs all the tests contained in the test files.
 1295   ;;
 1296   ;; Cf. RunTests for more information about ?options.
 1297   ;;
 1298   ;; @param {string} pkg
 1299   ;; @param (or VedaTestingOptions list) options
 1300   ;; @return (or symbol list)
 1301   (defun RunTestsOnPackage (pkg @key options)
 1302     (letseq ((loaded (MakeLoadedTable))
 1303              (info (RequirePackage pkg loaded defaultOptions))
 1304              (packagePath (when (classp info 'VedaTestingPackageFilesystemInfo)
 1305                             (let ((baseDir (GetBaseDir info)))
 1306                               (when baseDir
 1307                                 (list baseDir)))))
 1308              (loader (LoaderFromPackageInfo info 'tests))
 1309              (tests (when loader
 1310                       (LoadTestsUsingLoader loader))))
 1311       (RunTestsInternal tests (or options defaultTestingOptions)
 1312                         ?pkg pkg
 1313                         ?packagePath packagePath)))
 1314 
 1315   (setq VedaTestingRunTests RunTests)
 1316   (setq VedaTestingRunTestsFromFiles RunTestsFromFiles)
 1317   (setq VedaTestingPackageInfo PackageInfo)
 1318   (setq VedaTestingPackageLoad PackageLoad)
 1319   (setq VedaTestingRunTestsOnPackage RunTestsOnPackage))
 1320 
 1321 ;;; testing.ils ends here