Source File package/package.ils

    1 ;;; package.ils --- Lightweight package system
    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 package implements a lightweight package system for SKILL.
   18 ;; It generally favors convention over configuration.
   19 ;;
   20 ;; A package is a directory which contains a SKILL or SKILL++ file
   21 ;; with the same base name (<directory>.{il,ils}, the "titular" file),
   22 ;; which in turn begins with a comment header formatted in a specific
   23 ;; way.  A minimal package foo would consist in a single file:
   24 ;;
   25 ;;     foo/foo.il
   26 ;;
   27 ;; with a single-line header:
   28 ;;
   29 ;;     ;;; foo.il --- Minimal package
   30 ;;
   31 ;; More complex packages may contain @-prefixed metadata tags in the
   32 ;; header comment, each beginning with:
   33 ;;
   34 ;;     ;; @<tag-name>
   35 ;;
   36 ;; The following tags are defined:
   37 ;;
   38 ;;     ;; @author   A.U.Thor <author@example.com>
   39 ;;     ;; @requires bar, baz
   40 ;;     ;; @load     a.il, b.ils, ...
   41 ;;
   42 ;; @author states the name and email address of an author of the
   43 ;; package.  If there are multiple authors, repeat the tag for each of
   44 ;; them.
   45 ;;
   46 ;; @requires and @load are discussed with the
   47 ;; VedaPackageFilesystemInfo class.
   48 ;;
   49 ;; Packages are normally searched for in two locations relative to the
   50 ;; execution directory: pkg/ and ../, in that order.
   51 ;;
   52 ;; See also PACKAGE FORMAT section of the new-package command
   53 ;; documentation, e.g.:
   54 ;;
   55 ;;     $ veda help new-package
   56 ;;
   57 ;; Basic usage:
   58 ;;
   59 ;;     $ ls pkg/
   60 ;;     csv  package
   61 ;;
   62 ;;     $ $CDSHOME/tools/dfII/bin/skill
   63 ;;     (load "pkg/package/package.ils")
   64 ;;     |- t
   65 ;;     (VedaPackageInfo "package")
   66 ;;     |- #<VedaPackageFilesystemInfo "package"; base: "pkg/">
   67 ;;     (isCallable 'VedaCsvParseFile)
   68 ;;     |- nil
   69 ;;     (setq csv (VedaPackageLoad "csv"))
   70 ;;     |- #<VedaPackageFilesystemInfo "csv"; base: "pkg/">
   71 ;;     (isCallable 'VedaCsvParseFile)
   72 ;;     |- t
   73 ;;     (GetDescription csv)
   74 ;;     |- "Simple CSV parser (Excel-style, text/csv)"
   75 ;;     (GetTestFilenames csv)
   76 ;;     |- ("csv-test.ils")
   77 
   78 ;;; Code:
   79 
   80 ;; Class VedaPackageAbstractInfo holds information that is common to
   81 ;; all packages, independently of their underlying representation.
   82 (defclass VedaPackageAbstractInfo ()
   83   (;; The name of the package, as understood by the Info/Load
   84    ;; functions.
   85    ;;
   86    ;; @type {string}
   87    (name
   88     @initarg name
   89     @reader GetName)
   90    ;; The package's synopsis.
   91    ;;
   92    ;; @type {string}
   93    (description
   94     @initarg description
   95     @reader GetDescription)
   96    ;; A (possibly empty) list of package authors strings, each having
   97    ;; the following form (cf. name-addr production in RFC 5322):
   98    ;;
   99    ;;     Human-readable Name <email@example.com>
  100    ;;
  101    ;; @type {list}
  102    (authors
  103     @initarg authors
  104     @reader GetAuthors)))
  105 
  106 ;; Class VedaPackageFilesystemInfo describes filesystem-based packages
  107 ;; as "natively" implemented by this package.
  108 (defclass VedaPackageFilesystemInfo (VedaPackageAbstractInfo)
  109   (;; The directory of the search path in which the package was found,
  110    ;; a /-terminated string.
  111    ;;
  112    ;; @type {string}
  113    (base
  114     @initarg base
  115     @reader GetBaseDir)
  116    ;; The titular file containing package information.
  117    ;;
  118    ;; @type {string}
  119    (header
  120     @initarg header
  121     @reader GetHeaderFilename)
  122    ;; A list of other packages required by this package.  The contents
  123    ;; of this field can be controlled via the @requires tag, e.g.:
  124    ;;
  125    ;;     ;; @requires bar, baz
  126    ;;
  127    ;; @type {list}
  128    (requires
  129     @initarg requires
  130     @reader GetPackageRequires)
  131    ;; The package's source files, in load order.
  132    ;;
  133    ;; The contents of this field can be controlled via the @load tag,
  134    ;; e.g.:
  135    ;;
  136    ;;     ;; @load foo.il, bar.ils
  137    ;;
  138    ;; or
  139    ;;
  140    ;;     ;; @load foo.il, bar.ils, ...
  141    ;;
  142    ;; where the ellipsis means that any other source file found in the
  143    ;; package's directory is to be loaded after foo.il and bar.ils (in
  144    ;; an undefined order).
  145    ;;
  146    ;; @type {list}
  147    (sources
  148     @initarg sources
  149     @reader GetSourceFilenames)
  150    ;; Package test files, in load order.
  151    ;;
  152    ;; @type {list}
  153    (tests
  154     @initarg tests
  155     @reader GetTestFilenames)))
  156 
  157 ;; printObject formats unreadable VedaPackageFilesystemInfo instances
  158 ;; for diagnostic purposes.
  159 (defmethod printObject ((pi VedaPackageFilesystemInfo) @optional (port poport))
  160   (fprintf port "#<%s %L; base: %L>"
  161            (className (classOf pi)) pi->name pi->base))
  162 
  163 ;; Class VedaPackageSearchOptions holds options that are used for
  164 ;; locating packages; cf. PackageLoad and PackageInfo.
  165 (defclass VedaPackageSearchOptions ()
  166   (;; The list of /-terminated directories which are searched (in
  167    ;; order) for packages.  Non-anchored directories are relative to
  168    ;; the execution directory.
  169    ;;
  170    ;; Defaults to searching pkg/ then ../.
  171    ;;
  172    ;; @type {list}
  173    (searchPath
  174     @initarg searchPath
  175     @initform '("pkg/" "../")
  176     @reader GetSearchPath
  177     @writer SetSearchPath)
  178    ;; When non-nil, gather package information in an asynchronous
  179    ;; manner. The handler must obey a specific VedaPackageAsync
  180    ;; protocol, which is left undocumented for now.
  181    ;;
  182    ;; @type {t}
  183    (asyncHandler
  184     @initarg asyncHandler
  185     @initform nil
  186     @reader GetAsyncHandler
  187     @writer SetAsyncHandler)))
  188 
  189 ;; Class VedaPackageLoadOptions holds options that are used when
  190 ;; loading packages; cf. PackageLoad.
  191 (defclass VedaPackageLoadOptions (VedaPackageSearchOptions)
  192   (;; When t, honor the package's @requires tag.  Otherwise, a
  193    ;; (possibly) empty list of packages which are to be required
  194    ;; before the target.
  195    ;;
  196    ;; Defaults to t.
  197    ;;
  198    ;; @type (or symbol list)
  199    (requires
  200     @initarg requires
  201     @initform t
  202     @reader GetRequires
  203     @writer SetRequires)
  204    ;; When t, reset the table of loaded packages before loading the
  205    ;; target.  Otherwise, a (possibly) empty list of package names to
  206    ;; be evicted from the table of loaded packages before loading the
  207    ;; target.
  208    ;;
  209    ;; Defaults to nil.
  210    ;;
  211    ;; @type (or symbol list)
  212    (forceReload
  213     @initarg forceReload
  214     @initform nil
  215     @reader GetForceReload
  216     @writer SetForceReload)))
  217 
  218 ;; Package entry points.
  219 
  220 (define VedaPackageInfo nil)
  221 (define VedaPackageLoad nil)
  222 
  223 ;; Scope/hide utility functions and related data.
  224 (let ()
  225   ;; Default options used by Load/Info, if not overriden by ?options.
  226   (define defaultOptions
  227       (makeInstance 'VedaPackageLoadOptions))
  228 
  229   ;; @region Common header parsing
  230 
  231   ;; Generic utilities.
  232 
  233   ;; TrimLeftIndex indicates how to trim the substring of string
  234   ;; delimited by (from, to) to remove all leading characters
  235   ;; contained in string characterBag.
  236   ;;
  237   ;; Both from and to are 1-based, inclusive indices; use 1 and
  238   ;; (strlen string) to trim the whole string.
  239   ;;
  240   ;; Returns the start index of the resulting substring.
  241   (defun TrimLeftIndex (characterBag string from to)
  242     (while (and (from <= to)
  243                 (nindex characterBag (getchar string from)))
  244       (setq from (from + 1)))
  245     from)
  246 
  247   ;; TrimLeft returns a substring of string with all characters in
  248   ;; characterBag stripped off the beginning.
  249   ;;
  250   ;; If no characters need to be trimmed, string is returned.
  251   (defun TrimLeft (characterBag string)
  252     (let ((a (TrimLeftIndex characterBag string 1 (strlen string))))
  253       (cond
  254         ((onep a)
  255          string)
  256         ((a > (strlen string))
  257          "")
  258         (t
  259          (substring string a)))))
  260 
  261   ;; TrimRightIndex indicates how to trim the substring of string
  262   ;; delimited by (from, to) to remove all trailing characters
  263   ;; contained in string characterBag.
  264   ;;
  265   ;; Both from and to are 1-based, inclusive indices; use 1 and
  266   ;; (strlen string) to trim the whole string.
  267   ;;
  268   ;; Returns the end index in the resulting substring.
  269   (defun TrimRightIndex (characterBag string from to)
  270     (while (and (from <= to)
  271                 (nindex characterBag (getchar string to)))
  272       (setq to (to - 1)))
  273     to)
  274 
  275   ;; TrimRight returns a substring of string with all characters in
  276   ;; characterBag stripped off the end.
  277   ;;
  278   ;; If no characters need to be trimmed, string is returned.
  279   (defun TrimRight (characterBag string)
  280     (letseq ((n (strlen string))
  281              (b (TrimRightIndex characterBag string 1 n)))
  282       (if (equal b n)
  283           string
  284           (substring string 1 b))))
  285 
  286   ;; PrefixP returns the length of needle if it is a prefix of
  287   ;; haystack, nil otherwise.
  288   (defun PrefixP (needle haystack)
  289     (let ((n (strlen needle)))
  290       (when (n <= (strlen haystack))
  291         (let ((i 1))
  292           (while (and i (i <= n))
  293             (setq i (when (eq (getchar needle i) (getchar haystack i))
  294                       (i + 1))))
  295           i))))
  296 
  297   ;; SuffixP returns the index of the last character before needle in
  298   ;; haystack when the former is a suffix of the latter.  Otherwise,
  299   ;; returns nil.
  300   (defun SuffixP (needle haystack)
  301     (let ((n (strlen needle))
  302           (m (strlen haystack)))
  303       (when (n <= m)
  304         (let ((i 1)
  305               (offset (m - n)))
  306           (while (and i (i <= n))
  307             (setq i (when (eq (getchar needle i)
  308                               (getchar haystack (offset + i)))
  309                       (i + 1))))
  310           (when i
  311             offset)))))
  312 
  313   ;; Constants.
  314 
  315   ;; Minimum @-tag length, including @.
  316   (define minAtTagLength
  317       4)
  318 
  319   ;; An alist maping known @-tags to the corresponding DPL key.  Also
  320   ;; determines the DPL key order.
  321   (define knownTags
  322       '((nil            header)
  323         ("@description" description)
  324         ("@language"    language)
  325         ("@load"        load)
  326         ("@requires"    requires)
  327         ("@author"      authors)
  328         (nil            tags)))
  329 
  330   ;; Characters recognized as normal whitespace in headers.
  331   (define whitespaceBag
  332       " \t")
  333 
  334   ;; Characters recognized as trailing whitespace at the end of a
  335   ;; header line.
  336   (define trailingWhitespaceBag
  337       (strcat "\n" whitespaceBag))
  338 
  339   ;; TrimWs1 trims at most one whitespace character from the left of
  340   ;; the substring of line starting at from and whose length is n, as
  341   ;; well all of the trailing whitespace.
  342   (defun TrimWs1 (line from n)
  343     (letseq ((a (TrimLeftIndex whitespaceBag line from (min (from + 1) n)))
  344              (b (TrimRightIndex trailingWhitespaceBag line a n)))
  345       (cond
  346         ((a > b)
  347          "")
  348         (t
  349          (substring line a (b - a + 1))))))
  350 
  351   ;; TrimLineComment trims the leading line comment characters, the
  352   ;; first subsequent whitespace character, if any, and the trailing
  353   ;; whitespace off line.
  354   ;;
  355   ;; Returns the trimmed line, or nil if line isn't a line comment.
  356   (defun TrimLineComment (line)
  357     (letseq ((n (strlen line))
  358              (ic (TrimLeftIndex ";" line 1 n)))
  359       (when (ic > 1)
  360         (TrimWs1 line ic n))))
  361 
  362   ;; TrimBlockComment trims the leading banner characters (whitespace
  363   ;; followed by an asterisk), the first subsequent whitespace
  364   ;; character, if any, and the trailing whitespace off line, which
  365   ;; should be coming from a block comment.
  366   ;;
  367   ;; Returns the trimmed line.
  368   (defun TrimBlockComment (line)
  369     (letseq ((n (strlen line))
  370              (iw (TrimLeftIndex whitespaceBag line 1 n))
  371              (is (TrimLeftIndex "*" line iw (min (iw + 1) n))))
  372       (if (equal iw is)
  373           (TrimRight trailingWhitespaceBag line)
  374           (TrimWs1 line is n))))
  375 
  376   ;; Assoc list mapping prefix characters to the corresponding
  377   ;; trimmer.
  378   (define trimmers
  379       `((";"  ,TrimLineComment)
  380         ("/*" ,TrimBlockComment)))
  381 
  382   ;; SelectTrimmers select the header trimmer to use based on line,
  383   ;; which must be the first non-shebang line of the header block.
  384   (defun SelectTrimmer (line)
  385     (cadar (exists trimmer trimmers
  386              (PrefixP (car trimmer) line))))
  387 
  388   ;; ParseDescription parses a package's description line, which is
  389   ;; the first line in the package's titular file and has one of the
  390   ;; following formats:
  391   ;;
  392   ;;     ;;; <filename> --- <description>
  393   ;;
  394   ;;     /* <filename> --- <description>
  395   ;;
  396   ;; Returns the description, or nil if the line does not match one of
  397   ;; the required syntaxes.
  398   (defun ParseDescription (line filename)
  399     ;; FIXME: Should preserve tabs and multiple spaces.
  400     (let ((pieces (parseString line " \t\n")))
  401       (when (and (member (car pieces) '(";;;" "/*"))
  402                  (equal (cadr pieces) filename)
  403                  (equal (caddr pieces) "---"))
  404         (buildString (nthcdr 3 pieces)))))
  405 
  406   ;; SplitTag splits rawtag, which must start with an @-tag, at the
  407   ;; first tab and space character.
  408   ;;
  409   ;; Returns a 2-list with the parts, or (rawtag "") if no whitespace
  410   ;; character was found.
  411   (defun SplitTag (rawtag)
  412     (let ((i minAtTagLength)
  413           (n (strlen rawtag)))
  414       ;; Advance until first space or tab.
  415       (while (and (i <= n)
  416                   (not (nindex whitespaceBag (getchar rawtag i))))
  417         (setq i (i + 1)))
  418       (if (i > n)
  419           (list rawtag "")
  420           (list (substring rawtag 1 (i - 1))
  421                 (substring rawtag (i + 1))))))
  422 
  423   ;; MakeHeaderDpl generates a DPL by combining arguments and
  424   ;; extracting/parsing known tags out of the tags assoc list.
  425   (defun MakeHeaderDpl (header description languagep tags)
  426     (let ((kvs (makeTable 'knownTags nil)))
  427       (setarray kvs 'header header)
  428       (setarray kvs 'description description)
  429       (foreach tag tags
  430         (let ((key (cadr (assoc (car tag) knownTags)))
  431               (raw (cadr tag)))
  432           (cond
  433             ((and (eq key 'language) languagep)
  434              (setarray kvs key (concat (TrimLeft whitespaceBag raw))))
  435             ((memq key '(load requires))
  436              (setarray kvs key (parseString raw ", \t")))
  437             ((eq key 'authors)
  438              (setarray kvs key (cons (TrimLeft whitespaceBag raw)
  439                                      (arrayref kvs key))))
  440             ((eq key 'description)
  441              (setarray kvs key (TrimLeft whitespaceBag raw)))
  442             (t
  443              (let ((key 'tags))
  444                (setarray kvs key (cons tag (arrayref kvs key))))))))
  445       (cons nil
  446             (foreach mapcan entry knownTags
  447               (letseq ((key (cadr entry))
  448                        (cooked (arrayref kvs key)))
  449                 (when cooked
  450                   (list key cooked)))))))
  451 
  452   ;; ParseHeader tries and parses a comment header out of liner, a
  453   ;; function which returns the next line or nil on EOF.  If non-nil,
  454   ;; ?mustDescribe is the name of a package's titular file and is used
  455   ;; to parse/validate the description line.
  456   ;;
  457   ;; Returns a DPL on success, and nil if the header was absent or not
  458   ;; properly formatted.
  459   (defun ParseHeader (liner @key mustDescribe allowShebangP languagep)
  460     (let ((line nil)
  461           (lineno 0)
  462           (trimmer nil)
  463           (trimmed nil)
  464           (description nil)
  465           (tags nil)
  466           (tag nil)
  467           (it nil)
  468           (donep nil))
  469       (while (and (not donep) (setq line (funcall liner)))
  470         (setq lineno (lineno + 1))
  471         ;; Block comments end at the first */, but have a potentially
  472         ;; incomplete last line.
  473         (when (and (eq trimmer TrimBlockComment)
  474                    (setq it (nindex line "*/")))
  475           (setq line (substring line 1 (it - 1)))
  476           (setq donep t))
  477         (cond
  478           ((equal line "\n")
  479            ;; Continue, but prevent @-tag continuation.
  480            (setq tag nil))
  481           ((and allowShebangP (onep lineno) (PrefixP "#!" line))
  482            ;; Continue.
  483            )
  484           ((null (or trimmer (setq trimmer (SelectTrimmer line))))
  485            ;; No properly-formatted comment in here.
  486            (setq donep 'fail))
  487           ((or (null (setq trimmed (funcall trimmer line)))
  488                (member trimmed '("Commentary:" "Code:")))
  489            ;; The first non-comment line, or comment line consisting
  490            ;; of one of these markers, signals the end of the headers.
  491            (setq donep t))
  492           ((and mustDescribe (null description)
  493                 (not (setq description (ParseDescription line mustDescribe))))
  494            ;; Failed to parse the description line; this is not the
  495            ;; header we are looking for.
  496            (setq donep 'fail))
  497           ((and (PrefixP "@" trimmed)
  498                 ((strlen trimmed) >= minAtTagLength))
  499            (setq tag (SplitTag trimmed))
  500            (push tag tags))
  501           ((and tag (nequal trimmed ""))
  502            ;; @-tag continuation line.
  503            (let ((v (strcat (cadr tag) " " (TrimLeft " \t" trimmed))))
  504              (rplaca (cdr tag) v)))
  505           (t
  506            (setq tag nil))))
  507       (unless (eq donep 'fail)
  508         (MakeHeaderDpl mustDescribe description languagep tags))))
  509 
  510   ;; @endregion Common header parsing
  511 
  512   ;; BasicParseHeader invokes ParseHeader on liner, if non-nil, and
  513   ;; returns its results; it returns nil otherwise.  The header
  514   ;; ?mustDescribe filename.
  515   ;;
  516   ;; The liner, if any, must be callable with a single argument, t, in
  517   ;; which case it must close/free its resources (e.g. port).
  518   (defun BasicParseHeader (liner filename)
  519     (when liner
  520       (prog1
  521           (ParseHeader liner ?mustDescribe filename)
  522         ;; Close.
  523         (funcall liner t))))
  524 
  525   ;; MaybeFileLiner tries to return a closable liner
  526   ;; (cf. BasicParseHeader) reading from path, and returns nil if path
  527   ;; cannot be open for reading.
  528   (defun MaybeFileLiner (path)
  529     (let ((port (infile path))
  530           (line nil))
  531       (when port
  532         (lambda (@optional closep)
  533           (cond
  534             ((not closep)
  535              (gets line port))
  536             (t
  537              (close port)
  538              nil))))))
  539 
  540   ;; FilesLoader returns a function which loads the provided list of
  541   ;; filenames in order.  If ?dir is non-nil, it is prepended to each
  542   ;; file before attempting the load operation.
  543   (defun FilesLoader (filenames @key dir)
  544     (lambda (@rest _ignored)
  545       (foreach filename filenames
  546         (when dir
  547           (setq filename (strcat dir filename)))
  548         (load filename))
  549       t))
  550 
  551   ;; The ellipsis marker is used at the end of Load directives to
  552   ;; indicate that the other source files ought to be loaded, too.
  553   (define ellipsis
  554       "...")
  555 
  556   ;; ProcessLoadDirective checks that each entry in directive is also
  557   ;; present in files or is a trailing ellipsis.  Returns a list of
  558   ;; three values: the files from directive, whether a trailing
  559   ;; ellipsis was present, and the rest of the files.
  560   (defun ProcessLoadDirective (directive files)
  561     (let ((files (copy files))
  562           (ellipsisp nil))
  563       (let ((loads (foreach maplist dtail directive
  564                      (let ((file (car dtail)))
  565                        (cond
  566                          ((let ((ftail (member file files)))
  567                             (when ftail
  568                               (rplaca ftail nil)
  569                               file)))
  570                          ((and (equal file ellipsis)
  571                                (null (cdr dtail)))
  572                           (setq ellipsisp t)
  573                           nil)
  574                          (t
  575                           (error "No such file: %L; Load header: %L"
  576                                  file directive)))))))
  577         (list (remove nil loads) ellipsisp (remove nil files)))))
  578 
  579   ;; ClassifyFiles saves the files which match one of the subsets in a
  580   ;; correspondingly-named slot of a fresh DPL (Cf. fileSubsets
  581   ;; variable for an example of subset designators), and returns the
  582   ;; DPL.
  583   (defun ClassifyFiles (files subsets)
  584     (let ((dpl (list nil)))
  585       (foreach file files
  586         (exists subset subsets
  587           (let ((suffixes (car subset)))
  588             (exists suffix suffixes
  589               (when (SuffixP suffix file)
  590                 (letseq ((key (cadr subset))
  591                          (accum (get dpl key)))
  592                   (putprop dpl (cons file accum) key)))))))
  593       dpl))
  594 
  595   ;; fileSubsets holds subset designators for test and source files.
  596   (define fileSubsets
  597       '(;; Files ending with these two suffixes are test files.
  598         (("-test.ils" "-test.il") tests)
  599         ;; Files ending in .ils or .il and which are not considered
  600         ;; test files are source files.
  601         ((".ils" ".il")           sources)))
  602 
  603   ;; Helper function for PackageInfoFromBase.
  604   (defun FinalizePackageInfo (base pkg headerInfo loads ellipsisp files)
  605     (letseq ((filesInfo (ClassifyFiles files fileSubsets))
  606              (sources (cond
  607                         ((and loads ellipsisp)
  608                          (append loads filesInfo->sources))
  609                         (loads)
  610                         (t
  611                          filesInfo->sources))))
  612       (makeInstance 'VedaPackageFilesystemInfo
  613                     ?name pkg
  614                     ?description headerInfo->description
  615                     ?authors headerInfo->authors
  616                     ?base base
  617                     ?header headerInfo->header
  618                     ?requires headerInfo->requires
  619                     ?sources sources
  620                     ?tests filesInfo->tests)))
  621 
  622   ;; PackageInfoFromBase returns file-based information about package
  623   ;; pkg (contained below base, and for which some header info has
  624   ;; been found).  It combines the header and file-gathered data into
  625   ;; a fresh instance of VedaPackageFilesystemInfo.
  626   (defun PackageInfoFromBase (base pkg headerInfo files)
  627     (apply FinalizePackageInfo base pkg headerInfo
  628            (if headerInfo->load
  629                (ProcessLoadDirective headerInfo->load files)
  630                (list nil t files))))
  631 
  632   ;; PackageInfoHelper implements the logic of looking up and parsing
  633   ;; a package's titular file in a straightforward manner.
  634   (defun PackageInfoHelper (pkg bases suffixes)
  635     (let (info)
  636       (exists base bases
  637         (let ((dir (strcat base pkg)))
  638           (exists suffix suffixes
  639             (letseq ((filename (strcat pkg suffix))
  640                      (liner (MaybeFileLiner (strcat dir "/" filename)))
  641                      (headerInfo (BasicParseHeader liner filename)))
  642               (when headerInfo
  643                 (let ((files (getDirFiles dir)))
  644                   (setq info (PackageInfoFromBase base pkg headerInfo
  645                                                   files))))))))
  646       info))
  647 
  648   ;; PackageInfoAsyncHelper implements the logic of looking up and
  649   ;; parsing a package's titular file in an asynchronous manner.  It
  650   ;; performs the same steps as PackageInfoHelper above, but is
  651   ;; written in continuation-passing style, and performs filesystem
  652   ;; queries via the specified handler.
  653   (defun PackageInfoAsyncHelper (handler pkg bases suffixes k)
  654 
  655     (defun IterSuffixes (base suffixes k)
  656       (if (null suffixes)
  657           (k nil)
  658           (letseq ((filename (strcat pkg (car suffixes)))
  659                    (path (strcat base pkg "/" filename)))
  660             (VedaPackageAsyncMakeLiner handler path
  661               (lambda (liner)
  662                 (let ((info (BasicParseHeader liner filename)))
  663                   (if info
  664                       (k info)
  665                       (IterSuffixes base (cdr suffixes) k))))))))
  666 
  667     (defun IterBases (bases k)
  668       (if (null bases)
  669           (k nil nil)
  670           (IterSuffixes (car bases) suffixes
  671                         (lambda (info)
  672                           (if info
  673                               (k (car bases) info)
  674                               (IterBases (cdr bases) k))))))
  675 
  676     (defun Files (base info files)
  677       (let ((packageInfo (when files
  678                            (PackageInfoFromBase base pkg info files))))
  679         (k handler packageInfo)))
  680 
  681     (defun HeaderInfo (base info)
  682       (cond
  683         ((null info)
  684          (k handler nil))
  685         (t
  686          (let ((dir (strcat base pkg "/")))
  687            (VedaPackageAsyncGetDirFiles handler dir
  688                                         (lambda (files)
  689                                           (Files base info files)))))))
  690 
  691     (IterBases bases HeaderInfo))
  692 
  693   ;; PackageInfoFromFilesystem tries and find package pkg under one of
  694   ;; the bases, which are filesystem directory names.  The result is a
  695   ;; fresh instance of VedaPackageFilesystemInfo if found, nil
  696   ;; otherwise.
  697   ;;
  698   ;; If asyncHandler is nil, the function operates in synchronous mode
  699   ;; and returns the result in the usual way.  If an asyncHandler is
  700   ;; specified, the function returns nil, and the result is
  701   ;; transmitted via the VedaPackageAsync protocol.
  702   ;;
  703   ;; Cf. PackageInfoFromBase for more information.
  704   (defun PackageInfoFromFilesystem (pkg bases asyncHandler)
  705     (let ((suffixes '(".il" ".ils")))
  706       (cond
  707         ((null asyncHandler)
  708          (PackageInfoHelper pkg bases suffixes))
  709         (t
  710          (PackageInfoAsyncHelper asyncHandler
  711                                  pkg bases suffixes
  712                                  VedaPackageAsyncResult)
  713          nil))))
  714 
  715   ;; PackageInfo returns metadata about the package named by the
  716   ;; string pkg, either by querying a hook or by searching a number of
  717   ;; preset filesystem bases.
  718   ;;
  719   ;; It returns a concrete subclass of VedaPackageAbstractInfo, or nil
  720   ;; if not found.
  721   ;;
  722   ;; ?options, if non-nil, must be an instance of
  723   ;; VedaPackageSearchOptions. If nil, a default-initialized instance
  724   ;; is used.
  725   ;;
  726   ;; The hook, if present, must be named VedaPackageInfoHook and is
  727   ;; invoked as:
  728   ;;
  729   ;;     (VedaPackageInfoHook pkg)
  730   ;;
  731   ;; where pkg is the package name.
  732   ;;
  733   ;; @param {string} pkg
  734   ;; @param (or VedaPackageSearchOptions list) options
  735   ;; @return (or VedaPackageAbstractInfo list)
  736   (defun PackageInfo (pkg @key options)
  737     (cond
  738       ((isCallable 'VedaPackageInfoHook)
  739        (funcall 'VedaPackageInfoHook pkg))
  740       (t
  741        (let ((options (or options defaultOptions)))
  742          (PackageInfoFromFilesystem pkg
  743                                     (GetSearchPath options)
  744                                     (GetAsyncHandler options))))))
  745 
  746   ;; LoaderFromPackageInfo returns a function which will load a
  747   ;; specific subset of the package described by info, an instance of
  748   ;; VedaPackageFilesystemInfo.
  749   (defun LoaderFromPackageInfo (info subset)
  750     (let (files)
  751       (when (setq files (get info subset))
  752         (let ((dir (strcat info->base info->name "/")))
  753           (FilesLoader files ?dir dir)))))
  754 
  755   ;; LoadSubsetFromPackageInfo loads a specific subset of the package
  756   ;; described by info, an instance of VedaPackageFilesystemInfo.
  757   (defun LoadSubsetFromPackageInfo (info subset)
  758     (let ((loader (LoaderFromPackageInfo info subset)))
  759       (if loader
  760           (funcall loader ?subset subset)
  761           (error "Don't know how to load %s from package %L."
  762                  subset info)))
  763     t)
  764 
  765   ;; Recursive helper for RequirePackage.
  766   (defun RequirePackageRec (pkg loaded options noPackageRequiresP)
  767     (let (info)
  768       (cond
  769         ((arrayref loaded pkg))
  770         ((setq info (PackageInfo pkg ?options options))
  771          (unless noPackageRequiresP
  772            (foreach require info->requires
  773              (RequirePackageRec require loaded options noPackageRequiresP)))
  774          (LoadSubsetFromPackageInfo info 'sources)
  775          (setarray loaded pkg info))
  776         (t
  777          (error "Package %L not found." pkg)))))
  778 
  779   ;; RequirePackage loads the sources from pkg if and only if it is
  780   ;; not already indexed in the loaded table.  Each package mentioned
  781   ;; in options->requires is "RequirePackage'd" before this one, as is
  782   ;; any package mentioned in @requires--unless inhibited by the
  783   ;; noPackageRequiresP option.
  784   (defun RequirePackage (pkg loaded options)
  785     (letseq ((requires (GetRequires options))
  786              (noPackageRequiresP (neq requires t)))
  787       (when (pairp requires)
  788         (foreach require requires
  789           (RequirePackageRec require loaded options noPackageRequiresP)))
  790       (RequirePackageRec pkg loaded options noPackageRequiresP)))
  791 
  792   ;; BootstrapPackageInfo tries and determine package information from
  793   ;; filename, which must be a .ils file.  This is used for
  794   ;; bootstrapping purposes only; cf. loadedTable.
  795   (defun BootstrapPackageInfo (filename)
  796     (when (SuffixP ".ils" filename)
  797       (let ((n (strlen filename))
  798             (suffix (rindex filename "/")))
  799         (cond
  800           (suffix
  801            (let ((slen (strlen suffix)))
  802              (let ((pkg (substring suffix 2 (slen - 5)))
  803                    (dir (strcat (substring filename 1 (n - slen + 1)) "../")))
  804                (PackageInfoFromFilesystem pkg (list dir) nil))))
  805           (t
  806            (let ((pkg (substring filename 1 (n - 4))))
  807              (PackageInfoFromFilesystem pkg '("../") nil)))))))
  808 
  809   ;; BootstrapMarkLoaded tries and mark the package this file was
  810   ;; loaded from as (pre)loaded.  Note that this only work for
  811   ;; single-ils-file packages.
  812   (defun BootstrapMarkLoaded (table filename)
  813     (when filename
  814       (let ((info (BootstrapPackageInfo filename)))
  815         (when info
  816           (setarray table (GetName info) info)))))
  817 
  818   ;; The table of loaded packages.
  819   (define loadedTable nil)
  820 
  821   (let ((queryFn 'VedaPackage__getLoadedTable))
  822     (cond
  823       ((isCallable queryFn)
  824        (setq loadedTable (funcall queryFn)))
  825       (t
  826        (setq loadedTable (makeTable 'loaded nil))
  827        (putd queryFn (lambda () loadedTable)))))
  828 
  829   ;; Override any existing entry, as we're being loaded now.
  830   (when (isCallable 'get_filename)
  831     (BootstrapMarkLoaded loadedTable (get_filename piport)))
  832 
  833   ;; CleanupLoadedTable removes entries selected by forceReload from
  834   ;; the table of loaded packages.  Cf. GetForceReload in package
  835   ;; loading options for a description of the forceReload parameter.
  836   (defun CleanupLoadedTable (forceReload)
  837     (let ((pkgs (cond
  838                   ((eq forceReload t)
  839                    loadedTable->?)
  840                   ((pairp forceReload)
  841                    forceReload)
  842                   (t
  843                    (error "Unrecognized force reload option %L."
  844                           forceReload)))))
  845       (foreach pkg pkgs
  846         (remove pkg loadedTable))))
  847 
  848   ;; PackageLoad loads the sources of the package named by the string
  849   ;; pkg, as well as its dependencies, as necessary or requested via
  850   ;; the ?options argument.
  851   ;;
  852   ;; ?options, if non-nil, must be an instance of
  853   ;; VedaPackageLoadOptions.  If nil, a default-initialized instance
  854   ;; is used.
  855   ;;
  856   ;; The PackageInfo function is used for locating the package and its
  857   ;; dependencies, using the same ?options argument as PackageLoad.
  858   ;; An error is raised if one of the packages cannot be found.
  859   ;;
  860   ;; The function returns the concrete subclass of
  861   ;; VedaPackageAbstractInfo corresponding to pkg.
  862   ;;
  863   ;; @param {string} pkg
  864   ;; @param (or VedaPackageLoadOptions list) options
  865   ;; @return (or VedaPackageAbstractInfo list)
  866   (defun PackageLoad (pkg @key options)
  867     (letseq ((options (or options defaultOptions))
  868              (forceReload (GetForceReload options)))
  869       (when forceReload
  870         (CleanupLoadedTable forceReload))
  871       (RequirePackage pkg loadedTable options)))
  872 
  873   (setq VedaPackageInfo PackageInfo)
  874   (setq VedaPackageLoad PackageLoad))
  875 
  876 ;;; package.ils ends here