nasdf: Update to 0.1.7.

nasdf/compilation-tests.lisp

@@ -11,6 +11,11 @@
     :reader packages
     :documentation "Packages to check for unbound exports.
 Sub-packages are included in the check.")
+   (unbound-symbols-to-ignore
+    :initform '()
+    :initarg :unbound-symbols-to-ignore
+    :reader unbound-symbols-to-ignore
+    :documentation "Symbols to ignore when checking for unbound exports.")
    (undocumented-symbols-to-ignore
     :initform '()
     :initarg :undocumented-symbols-to-ignore
@@ -21,11 +26,37 @@ Likely, slot names (these don't have native `documentation' support."))
 (import 'nasdf-compilation-test-system :asdf-user)
 
 (defun valid-type-p (type-specifier)
-  (handler-case
-      (progn
-        (typep t type-specifier)
-        t)
-    (error () nil)))
+  "Check the TYPE-SPECIFIER for being a valid type.
+The logic is:
+- If the type is documented as a type, then a type it is.
+- Otherwise, if `typep' exits normally (with whatever return value)
+  when checking arbitrary value against this specifier, then
+  TYPE-SPECIFIER is valid.
+- And if there's an error about argument types, then TYPE-SPECIFIER is
+  the type requiring arguments. Which means: type exists, even if
+  requiring arguments.
+- If there's any other error raised by `typep', then TYPE-SPECIFIER is
+  likely not a type."
+  (or (ignore-errors (documentation type-specifier 'type))
+      (handler-case
+          (progn
+            (typep t type-specifier)
+            t)
+        #+sbcl
+        (sb-kernel::arg-count-error ()
+          t)
+        #+ccl
+        (ccl::simple-program-error (e)
+          (search "can't be destructured against the lambda list" (format nil "~a" e)))
+        #+ecl
+        (simple-error (e)
+          (or (search "Too few arguments" (format nil "~a" e))
+              (not (search "not a valid type specifier" (format nil "~a" e)))))
+        #+clisp
+        (simple-error (e)
+          (or (search "may not be called with 0 arguments" (format nil "~a" e))
+              (not (search "invalid type specification" (format nil "~a" e)))))
+        (error () nil))))
 
 (defun list-unbound-exports (package)
   (let ((result '()))
@@ -49,14 +80,30 @@ A sub-package has a name that starts with that of PACKAGE followed by a '/' sepa
   (remove-if (lambda (pkg) (not (subpackage-p pkg package))) (list-all-packages)))
 
 (defun list-undocumented-exports (package)
-  (let ((result '()))
-    (do-external-symbols (s (find-package package) result)
-      (unless (or (some (lambda (doctype) (documentation s doctype))
-                        '(variable function compiler-macro setf method-combination type structure))
-                  ;; Parenscript macros don't have documentation.
-                  (and (find-package :parenscript)
-                       (gethash s (symbol-value (find-symbol "*MACRO-TOPLEVEL*" :parenscript)))))
-        (push s result)))))
+  (let ((result '())
+        (classes (loop for s being the external-symbol in package
+                       when (find-class s nil)
+                         collect s)))
+    (flet ((accessor-p (symbol)
+             "Check whether the SYMBOL is a slot accessor.
+This is necessary because accessors rarely have documentation and thus
+have to be excluded from the undocumented symbols list.
+Uses the built-in MOP abilities of every Lisp."
+             (and (fboundp symbol)
+                  (typep (symbol-function symbol) 'generic-function)
+                  (some (lambda (class)
+                          (ignore-errors
+                           (typep (find-method (symbol-function symbol) '() (list (find-class class)))
+                                  '(or standard-accessor-method standard-reader-method standard-writer-method))))
+                        classes))))
+      (do-external-symbols (s (find-package package) result)
+        (unless (or (some (lambda (doctype) (ignore-errors (documentation s doctype)))
+                          '(variable function compiler-macro setf method-combination type structure))
+                    (accessor-p s)
+                    ;; Parenscript macros don't have documentation.
+                    (and (find-package :parenscript)
+                         (gethash s (symbol-value (find-symbol "*MACRO-TOPLEVEL*" :parenscript)))))
+          (push s result))))))
 
 (flet ((list-offending-packages (package export-lister testing-for)
          (let* ((package (find-package package)))
@@ -67,13 +114,27 @@ A sub-package has a name that starts with that of PACKAGE followed by a '/' sepa
                                (when exports
                                  (list package exports))))
                            (cons (find-package package) (list-subpackages package)))))))
-  (defun unbound-exports (package)
+  (defun unbound-exports (package symbols-to-ignore)
     "Report unbound exported symbols for PACKAGE and all its subpackages."
     ;; NOTE: these implementations throw errors on atypical type specifier, enabling `valid-type-p'
     #+(or sbcl ccl ecl clisp)
-    (let ((report (list-offending-packages package #'list-unbound-exports "unbound exports")))
+    (let* ((report (list-offending-packages package #'list-unbound-exports "unbound exports"))
+           (report (delete
+                    nil
+                    (mapcar (lambda (rep)
+                              (destructuring-bind (package symbols)
+                                  rep
+                                (let ((really-undocumented-symbols
+                                        (remove-if (lambda (sym)
+                                                     (member (symbol-name sym) symbols-to-ignore
+                                                             :key #'symbol-name :test #'equal))
+                                                   symbols)))
+                                  (if really-undocumented-symbols
+                                      (list package really-undocumented-symbols)
+                                      nil))))
+                            report))))
       (when report
-        (error "~a~&Found unbound exported symbols in ~a package~:p."
+        (error "~s~&Found unbound exported symbols in ~a package~:p."
                report (length report))))
     #-(or sbcl ccl ecl clisp) nil)
 
@@ -97,11 +158,11 @@ documentation (e.g. slot names)."
                                       nil))))
                             report))))
       (when report
-        (error "~a~&Found undocumented exported symbols in ~a package~:p."
+        (error "~s~&Found undocumented exported symbols in ~a package~:p."
                report (length report))))))
 
 (defmethod asdf:perform ((op asdf:test-op) (c nasdf-compilation-test-system))
   (logger "------- STARTING Compilation Testing: ~a" (packages c))
-  (mapc #'unbound-exports (packages c))
+  (mapc #'(lambda (p) (unbound-exports p (unbound-symbols-to-ignore c))) (packages c))
   (mapc #'(lambda (p) (undocumented-exports p (undocumented-symbols-to-ignore c))) (packages c))
   (logger "------- ENDING Compilation Testing: ~a" (packages c)))

nasdf/install.lisp

@@ -84,8 +84,8 @@ Destination directory is given by the `dest-source-dir' generic function."))
       (first (last (pathname-directory
                     ;; Ensure directory _after_ truenamizing, otherwise if
                     ;; non-directory file exists it may not yield a directory.
-                    (uiop:ensure-directory-pathname
-                     (uiop:ensure-pathname pathname :truenamize t)))))))
+                    (ensure-directory-pathname
+                     (ensure-pathname pathname :truenamize t)))))))
 
 (defun path-from-env (environment-variable default)
   (let ((env (getenv environment-variable)))
@@ -120,11 +120,16 @@ Destination directory is given by the `dest-source-dir' generic function."))
   *libdir*)
 
 (export-always '*dest-source-dir*)
-(defvar *dest-source-dir* (path-from-env "NASDF_SOURCE_PATH" *datadir*))
+(defvar *dest-source-dir* (path-from-env "NASDF_SOURCE_PATH" *datadir*)
+  "Root of where the source will be installed.
+Final path is resolved in `dest-source-dir'.")
 
 (export-always 'dest-source-dir)
 (defmethod dest-source-dir ((component nasdf-source-directory))
-  *dest-source-dir*)
+  "The directory into which the source is installed."
+  (let ((name (asdf:primary-system-name (asdf:component-system component))))
+    (ensure-directory-pathname
+     (merge-pathnames* name *dest-source-dir*))))
 
 (export-always '*chmod-program*)
 (defvar *chmod-program* "chmod")
@@ -158,12 +163,12 @@ Destination directory is given by the `dest-source-dir' generic function."))
   nil)
 
 (defmethod asdf:output-files ((op asdf:compile-op) (c nasdf-file))
-  (values (list (uiop:merge-pathnames* (pathname-name (asdf:component-name c))
-                                       *prefix*))
+  (values (list (merge-pathnames* (pathname-name (asdf:component-name c))
+                                  *prefix*))
           t))
 
 (defmethod asdf:output-files ((op asdf:compile-op) (c nasdf-binary-file))
-  (values (list (uiop:merge-pathnames* (basename (asdf:component-name c)) *bindir*))
+  (values (list (merge-pathnames* (basename (asdf:component-name c)) *bindir*))
           t))
 
 (defmethod asdf:perform ((op asdf:compile-op) (c nasdf-binary-file))
@@ -172,14 +177,14 @@ Destination directory is given by the `dest-source-dir' generic function."))
   nil)
 
 (defmethod asdf:output-files ((op asdf:compile-op) (c nasdf-library-file))
-  (values (list (uiop:merge-pathnames* (basename (asdf:component-name c)) (libdir c)))
+  (values (list (merge-pathnames* (basename (asdf:component-name c)) (libdir c)))
           t))
 
 (defmethod asdf:output-files ((op asdf:compile-op) (c nasdf-desktop-file))
-  (values (list (uiop:merge-pathnames* (uiop:merge-pathnames*
-                                        (basename (asdf:component-name c))
-                                        "applications/")
-                                       *datadir*))
+  (values (list (merge-pathnames* (merge-pathnames*
+                                   (basename (asdf:component-name c))
+                                   "applications/")
+                                  *datadir*))
           t))
 
 (defun scan-last-number (path)
@@ -192,7 +197,7 @@ Return NIL is there is none."
                                 (if result
                                     (return-from red result)
                                     result)))
-                          (uiop:native-namestring path)
+                          (native-namestring path)
                           :initial-value '()
                           :from-end t))))
     (when result
@@ -202,8 +207,8 @@ Return NIL is there is none."
   "Return all files of NASDF-ICON-DIRECTORY `type' in its directory.
 File must contain a number in their path."
   (let ((result (remove-if (complement #'scan-last-number)
-                           (uiop:directory-files (asdf:component-pathname c)
-                                                 (uiop:strcat "*." (asdf:file-type c))))))
+                           (directory-files (asdf:component-pathname c)
+                                            (strcat "*." (asdf:file-type c))))))
     (let* ((dimensions (mapcar #'scan-last-number result))
            (dups (set-difference dimensions
                                  (remove-duplicates dimensions)
@@ -242,13 +247,13 @@ File must contain a number in their path."
      (constantly t)
      (lambda (dir)
        (notany (lambda (exclusion)
-                 (uiop:string-suffix-p (basename dir) exclusion))
+                 (string-suffix-p (basename dir) exclusion))
                (mapcar #'basename exclude-subpath)))
      (lambda (subdirectory)
        (setf result (append result
                             (remove-if
                              (lambda (file) (file-excluded-type file exclude-types))
-                             (uiop:directory-files subdirectory))))))
+                             (directory-files subdirectory))))))
     result))
 
 (export-always 'copy-directory)
@@ -273,18 +278,18 @@ They are either listed with 'git ls-files' or directly if Git is not found."
   (let ((source (asdf:component-pathname component))
         (root (asdf:system-source-directory (asdf:component-system component))))
     (handler-case
-        (uiop:with-current-directory (root)
+        (with-current-directory (root)
           (let ((absolute-exclusions (mapcar (lambda (exclusion)
                                                (namestring
                                                 (merge-pathnames*
-                                                 (uiop:ensure-directory-pathname exclusion)
-                                                 (uiop:ensure-directory-pathname source))))
+                                                 (ensure-directory-pathname exclusion)
+                                                 (ensure-directory-pathname source))))
                                              (exclude-subpath component))))
             (remove-if (lambda (file)
                          (or (file-excluded-type file (exclude-types component))
                              (let ((file-string (namestring file)))
                                (some (lambda (exclusion)
-                                       (uiop:string-prefix-p exclusion file-string))
+                                       (string-prefix-p exclusion file-string))
                                      absolute-exclusions))))
                        (mapcar (lambda (path)
                                  (ensure-pathname path :truenamize t))
@@ -293,7 +298,7 @@ They are either listed with 'git ls-files' or directly if Git is not found."
                                 source)))))
       (error (c)
         (warn "~a~&Git error, falling back to direct listing." c)
-        (uiop:with-current-directory (root)
+        (with-current-directory (root)
           (list-directory source :exclude-subpath (exclude-subpath component)
                                  :exclude-types (exclude-types component)))))))
 
@@ -304,3 +309,20 @@ They are either listed with 'git ls-files' or directly if Git is not found."
                (merge-pathnames* (uiop:subpathp path root) (dest-source-dir component)))
              (asdf:input-files op component))
      t)))
+
+(export-always 'nasdf-source-file)
+(defclass nasdf-source-file (nasdf-file) ()
+  (:documentation "Common Lisp source files.
+
+Destination directory is given by the `dest-source-dir' generic function."))
+(import 'nasdf-source-file :asdf-user)
+
+(defmethod dest-source-dir ((component nasdf-source-file)) ; TODO: Factor with other method?
+  "The directory into which the source is installed."
+  (let ((name (asdf:primary-system-name (asdf:component-system component))))
+    (ensure-directory-pathname
+     (merge-pathnames* name *dest-source-dir*))))
+
+(defmethod asdf:output-files ((op asdf:compile-op) (c nasdf-source-file))
+  (values (list (merge-pathnames* (basename (asdf:component-name c)) (dest-source-dir c)))
+          t))

nasdf/nasdf.asd

@@ -2,7 +2,7 @@
 ;;;; SPDX-License-Identifier: BSD-3-Clause
 
 (defsystem "nasdf"
-  :version "0.1.3"
+  :version "0.1.7"
   :author "Atlas Engineer LLC"
   :homepage "https://github.com/atlas-engineer/ntemplate"
   :description "ASDF helpers for system setup, testing and installation."

nasdf/package.lisp

@@ -26,13 +26,33 @@
                 #:run-program
                 #:split-string
                 #:strcat
+                #:string-prefix-p
+                #:string-suffix-p
                 #:subpathp
-                #:symbol-call)
+                #:symbol-call
+                #:with-current-directory)
   (:import-from :asdf
                 #:clear-configuration
                 #:perform
                 #:system-relative-pathname
                 #:system-source-directory)
+  (:import-from
+   #+abcl      #:mop
+   #+allegro   #:mop
+   #+clisp     #:clos
+   #+clozure   #:ccl
+   #+cmu       #:clos-mop
+   #+ecl       #:clos
+   #+clasp     #:clos
+   #+lispworks #:clos
+   #+mcl       #:ccl
+   #+sbcl      #:sb-mop
+   #+scl       #:clos
+   #+mezzano   #:mezzano.clos
+   #+sicl      #:sicl-clos
+   #:standard-accessor-method
+   #:standard-reader-method
+   #:standard-writer-method)
   (:documentation "ASDF helpers for system setup, testing and installation.
 
 To tell ASDF to fail loading a system on warnings, add this line to the system

nasdf/submodules.lisp

@@ -45,6 +45,13 @@ A naive benchmark on a 16 Mbps bandwidth gives us
                (system-relative-pathname component path))))
     (setf (getenv "CL_SOURCE_REGISTRY")
           (strcat
+           ;; Register this repository's NASDF path first, to ensure we don't
+           ;; use any NASDF from submodules.
+           (native-namestring
+            (ensure-directory-pathname
+             (ensure-absolute-path "libraries/nasdf" component)))
+           (inter-directory-separator)
+           ;; Submodules:
            (native-namestring
             (ensure-directory-pathname
              (ensure-absolute-path *submodules-directory* component)))