Symlinks under Windows using SBCL — #’truename & ASDF

This post applies to running Steel Bank Common Lisp version 1.0.16 – 1.0.17.14 on Windows Vista. It may apply to later or earlier versions of SBCL, but I cannot directly attest to that. It may apply to certain functionality under Windows XP, but I cannot attest to that either.

[Update 07 June 2008]  I have made a few modifications to the attached code in order to:
- place (D. Lichteblau’s) support for SHORTCUT files in a separate function PARSE-WINDOWS-SHORTCUT (to ensure stream-read-invariance wrt TRUENAME);
- add a redefinition for FILE-WRITE-DATE to mimic Unix behavior under Windows;
- add behavior so that TRUENAME of a recursive or dangling link returns the pathname of the link, and does not signal an error;
- add support for symbolic links containing relative pathnames;
- add support for symbolic links to different disks/volumes.

With reference to:

http://robert.zubek.net/blog/2008/04/09/sbcl-emacs-windows-vista/
http://sbcl-internals.cliki.net/Build%20on%20Windows
http://www.sbcl.org/
http://brainrack.wordpress.com/2008/05/29/running-sbcl-on-windows/
http://brainrack.wordpress.com/2008/05/28/broken-and-ill-documented-api-for-windows-mount-points/

Broken #’truename and annoying ASDF under Windows using SBCL

The CLtL2 specification requires #’truename to return the “canonical” pathname of a file.  Most lisps interpret this to mean that when a pathname refers to a link, the link should be followed in order to return the pathname under which the file actually resides.  Indeed, this is the way the UNIX implementation of SBCL functions with regard to #’truename.  However, the Windows implementation of SBCL does not function the same as the UNIX implementation: (truename pathspec) will not follow links under Windows.

Complaining about this would be a petty bit of specs-manship were it not for the fact that the standard system definition facility ASDF relies on following links in order to function as designed.  I find the intended behavior of ASDF to be elegant and convenient and so I set out to restore the ANSI functionality of #’truename under SBCL Windows.

[This issue has a history: see Stephan Lang's http://marc.info/?l=sbcl-devel&m=117357216708358&w=2; David Lichteblau's http://www.lichteblau.com/blubba/shortcut/asdf.lisp; and a discussion initiated by Nikodemus Siivola at http://article.gmane.org/gmane.lisp.cclan.general/740.]

Fixing the problem required me to delve deeply into some very dark recesses of the Microsoft Windows API, as well as SBCL’s FFI.  Along the way I encountered all the usual abominations one must deal with when trying to program in Microsoftland: incorrect documentation, broken functions, vague and underspecified behaviors, inconsistent functionality between related functions, bizarre designs, Hungarian variable notation, and generally rococo APIs seemingly still implemented in a pre-1980 version of ‘C’ and modified from a cribbed copy of CPM.  Some details are here.  I feel most highly-privileged to have encountered the rare and wonderful ‘dammit-the-documentation-changed-while-I-was-reading-it!’ experience at http://msdn.microsoft.com/en-us/library/ms791514.aspx.

My plaints should not be taken to slight the abominations in SBCL’s FFI, however, for they are truly ghastly and profound.  (Try to figure out exactly how c-strings and (* char)’s are handled sometime!)

Nonetheless, I have a working version of

(LINKED-TRUENAME filespec) — if the last part of the path of /filespec/ points to a link, return a pathname in which the link is resolved, else return the usual truename.

I have tested this function to verify that it works on file symlinks, directory symlinks, and mount points (aka junctions) as produced by mklink, mklink /D, mklink /J, mountvol, and the Disk Manager.

I don’t know if the fix will ever make it into the SBCL distribution.  I’m not sure I want to jump through all the hoops necessary.  In the meantime, it works for me, and hopefully for you.

Here’s the source:

;;;
;;;
;;; Code for following symlinks under Windows Vista
;;; Redefined truename so truename returns pathname of linked file
;;; This functionality is necessary for running asdf as it is designed
;;; - Neil Haven, June 2008
;;;
;;; For Microsoft reparse-points handling see:
;;; http://blog.kalmbach-software.de/2008/02/28/howto-correctly-read-reparse-data-in-vista/
;;;
;;; For Windows .lnk file handling see:
;;; "Jesse Hager: The Windows Shortcut File Format."
;;; http://www.wotsit.org/list.asp?fc=13
;;; Some code excerpted from David Lichteblau's modifications to asdf.lisp
;;; http://www.lichteblau.com/blubba/shortcut/asdf.lisp
;;;

(defpackage #:winlinks
    (:nicknames #:wl)
  (:documentation "Package for redefining truename so it follows links.")
  (:use #:cl #:sb-alien #:sb-ext)
  (:shadow #:truename #:file-write-date)
  (:export #:override-truename #:override-file-write-date
           #:parse-windows-shortcut))

(in-package #:wl)

#|
To create a mount point under Vista use mklink /J ...
To create a symbolic file link use mklink ...
To create a directory link use mklink ...
|#

#|
typedef struct _REPARSE_DATA_BUFFER {
  ULONG  ReparseTag;
  USHORT  ReparseDataLength;
  USHORT  Reserved;
  union {
    struct {
      USHORT  SubstituteNameOffset;
      USHORT  SubstituteNameLength;
      USHORT  PrintNameOffset;
      USHORT  PrintNameLength;
      ULONG   Flags; // it seems that the docu is missing this entry (at least 2008-03-07)
      WCHAR  PathBuffer[1];
      } SymbolicLinkReparseBuffer;
    struct {
      USHORT  SubstituteNameOffset;
      USHORT  SubstituteNameLength;
      USHORT  PrintNameOffset;
      USHORT  PrintNameLength;
      WCHAR  PathBuffer[1];
      } MountPointReparseBuffer;
    struct {
      UCHAR  DataBuffer[1];
    } GenericReparseBuffer;
  };
} REPARSE_DATA_BUFFER, *PREPARSE_DATA_BUFFER;

#define MAXIMUM_REPARSE_DATA_BUFFER_SIZE  ( 16 * 1024 )

//
// The reparse tags are a DWORD. The 32 bits are laid out as follows:
//
//   3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1
//   1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
//  +-+-+-+-+-----------------------+-------------------------------+
//  |M|R|N|R|     Reserved bits     |       Reparse Tag Value       |
//  +-+-+-+-+-----------------------+-------------------------------+
//
// M is the Microsoft bit. When set to 1, it denotes a tag owned by Microsoft.
//   All ISVs must use a tag with a 0 in this position.
//   Note: If a Microsoft tag is used by non-Microsoft software, the
//   behavior is not defined.
//
// R is reserved.  Must be zero for non-Microsoft tags.
//
// N is name surrogate. When set to 1, the file represents another named
//   entity in the system.
//

|#

(defun override-truename (&optional (package *package*))
  "replace definition of truename in /package/ "
  (shadowing-import 'wl::truename package))

(defun override-file-write-date (&optional (package *package*))
  "replace definition of file-write-date in /package/ "
  (shadowing-import 'wl::file-write-date package))

(defun wchar-string->lisp-string (wstring &optional (length -1))
  "
  Arguments: /wstring/ is a pointer to a zero-terminated
    array of wchars (unsigned shorts)
    /length/, if supplied, truncates the translation after
    /length/ number of characters if a zero-termination is not
    encountered before that
  Semantics: translates /wstring/ to a lisp string.  If
    /wstring/ is a null pointer, returns nil
  Returns: a lisp string or nil.
  "
  (declare (type (alien (* unsigned-short)) wstring)
           (type integer length))
  (when (null-alien wstring)
    (return-from wchar-string->lisp-string nil))
  ;; calculate the length
  (when (minusp length)
    (do ((index 0 (incf index)))
        ((= (deref wstring index) 0) (setq length index))))
  (do* ((index 0 (incf index))
        (wchar (deref wstring index) (deref wstring index))
        (lisp-string (make-array length :element-type 'character)))
       ((= index length) lisp-string)
    (declare (type integer index)
             (type (unsigned-byte 16) wchar)
             (type string lisp-string))
    (setf (aref lisp-string index) (code-char wchar))))

(defun lisp-string->wchar-string (string)
  "
  Semantics: converts the lisp /string/ into an alien pointer to
    a zero-terminated array of wide (16-bit) chars.  Any
    characters in /string/ with a unicode code point
    > #xFFFF are given a representation as #xFFFD -- the
    standard unicode Replacement Character
  Returns: Two values: an alien pointer to a zero-terminated array of
    16-bit chars suitable for passing to a Windows API;
    and the length of the string
  "
  (let* ((size (length string))
         (wchar-string (make-alien (unsigned 16) (1+ size)))
         (unicode 0)
         (wchar 0))
    (declare (type integer size unicode)
             (type (unsigned-byte 16) wchar))
    (dotimes (index size)
      (setq unicode (char-code (elt string index)))
      (when (> unicode #xFFFF) (setq unicode #xFFFD)) ; coerce to 16-bits
      (setq wchar (coerce unicode '(unsigned-byte 16)))
      (setf (deref wchar-string index) wchar))
    (setf (deref wchar-string size) 0)
    (return-from lisp-string->wchar-string
      (values wchar-string size))))

(defun lisp-string->char-string (string)
  "
  Semantics: converts the lisp /string/ into an alien pointer to
    a zero-terminated array of 8-bit chars.  Any
    characters in /string/ with a unicode code point
    > #xFF are given a representation as #x1A -- the
    standard unicode Substitute control
  Returns: Two values: an alien pointer to a zero-terminated array of
    8-bit chars suitable for passing to a Windows API;
    and the length of the string
  "
  (let* ((size (length string))
         (char-string (make-alien (unsigned 8) (1+ size)))
         (unicode 0)
         (char 0))
    (declare (type integer size unicode)
             (type (unsigned-byte 8) char))
    (dotimes (index size)
      (setq unicode (char-code (elt string index)))
      (when (> unicode #xFF) (setq unicode #x1A)) ; coerce to 8-bits
      (setq char (coerce unicode '(unsigned-byte 8)))
      (setf (deref char-string index) char))
    (setf (deref char-string size) 0)
    (return-from lisp-string->char-string
      (values char-string size))))

(define-alien-type nil
    (struct SymbolicLinkStructure
            (substitute-name-offset unsigned-short) ; 2 bytes
            (substitute-name-length unsigned-short) ; 2 bytes
            (print-name-offset unsigned-short) ; 2 bytes
            (print-name-length unsigned-short) ; 2 bytes
            (flags unsigned-long)       ; 4 bytes
            (path-buffer (array unsigned-short 246)))) ; 492 bytes

(define-alien-type nil
    (struct MountPointStructure
            (substitute-name-offset unsigned-short) ; 2 bytes
            (substitute-name-length unsigned-short) ; 2 bytes
            (print-name-offset unsigned-short) ; 2 bytes
            (print-name-length unsigned-short) ; 2 bytes
            (path-buffer (array unsigned-short 248)))) ; 496 bytes

(define-alien-type nil
    (struct GenericReparseStructure
            (data-buffer (array char 504)))) ; 504 bytes

(define-alien-type nil
    (union ReparseUnion
           (symbolic-link-structure (struct SymbolicLinkStructure))
           (mount-point-structure (struct MountPointStructure))
           (generic-reparse-structure (struct GenericReparseStructure))))

(define-alien-type nil
    (struct ReparseStructure
            (reparse-tag unsigned-long) ; 4 bytes
            (length unsigned-short)     ; 2 bytes
            (reserved unsigned-short)   ; 2 bytes
            (reparse-union (union ReparseUnion)))) ; 504 bytes

(defmacro reparse-tag-p (reparse-tag)
  "Is /reparse-tag/ a legal Microsoft reparse tag?"
  ;(declare (type (unsigned-byte 32) reparse-tag))
  `(= #x80000000 (logand ,reparse-tag #x80000000)))

(defmacro name-surrogate-p (reparse-tag)
  "Is the /reparse-tag/ from a surrogate for another file?"
  ;(declare (type (unsigned-byte 32) reparse-tag))
  `(= #x20000000 (logand ,reparse-tag #x20000000)))

(defmacro mount-point-p (reparse-tag)
  "Is the /reparse-tag/ a Microsoft mount point?"
  ;(declare (type (unsigned-byte 32)) reparse-tag)
  `(= #xA0000003 (logand ,reparse-tag #xA0000003)))

(defmacro symlink-p (reparse-tag)
  "Is the /reparse-tag/ a Microsoft symlink?"
  ;(declare (type (unsigned-byte 32)) reparse-tag)
  `(= #xA000000C (logand ,reparse-tag #xA000000C)))

#|
HANDLE WINAPI CreateFile(
  __in      LPCTSTR lpFileName,
  __in      DWORD dwDesiredAccess,
  __in      DWORD dwShareMode,
  __in_opt  LPSECURITY_ATTRIBUTES lpSecurityAttributes,
  __in      DWORD dwCreationDisposition,
  __in      DWORD dwFlagsAndAttributes,
  __in_opt  HANDLE hTemplateFile
);

BOOL WINAPI DeviceIoControl(
  __in         HANDLE hDevice,
  __in         DWORD dwIoControlCode,
  __in_opt     LPVOID lpInBuffer,
  __in         DWORD nInBufferSize,
  __out_opt    LPVOID lpOutBuffer,
  __in         DWORD nOutBufferSize,
  __out_opt    LPDWORD lpBytesReturned,
  __inout_opt  LPOVERLAPPED lpOverlapped
);
|#

(load-shared-object "Kernel32")

(declaim (inline CreateFileA))

(declaim (inline CloseHandle))

(declaim (inline DeviceIoControl))

(declaim (inline GetVolumeNameForVolumeMountPointA))

(define-alien-routine ("GetVolumeNameForVolumeMountPointA" GetVolumeNameForVolumeMountPointA) int
  (mount-point (* unsigned-char))
  (volume-name (* unsigned-char))
  (buffer-length unsigned-int))

(define-alien-routine ("CreateFileA" CreateFileA) int
  (filename (* unsigned-char))
  (access unsigned-int)
  (sharemode unsigned-int)
  (security unsigned-int)
  (create unsigned-int)
  (flags unsigned-int)
  (template unsigned-int))

(define-alien-routine ("CloseHandle" CloseHandle) int
  (device int))

(define-alien-routine ("DeviceIoControl" DeviceIoControl) int
  (device unsigned-int)
  (control unsigned-int)
  (inBuffer (* t))
  (inSize unsigned-int)
  (outBuffer (* (struct ReparseStructure)))
  (outSize unsigned-int)
  (bytesReturned (* unsigned-int))
  (overlapped (* t)))

(defun get-link-handle (filespec)
  "returns -1 on failure, otherwise returns handle for /filespec/"
  (let ((filename (lisp-string->char-string (namestring filespec))))
    ;; for the interpretation of the magic numbers, see the kalmbach reference
    (CreateFileA filename #x8 #x7 #x0 #x3 #x02200000 #x0)))

(defun get-volume-name (mount-point)
  "
  Semantics: returns lisp string for underlying volume name of mount point
    If there is no underlying volume name, return /mount-point/
  Arguments: /mount-point/ is a string pathname designator
  Returns: lisp string in form \\\\?\\Volume{GUID}\\ if /mount-point/ exists
    else returns original /mount-point/
  "
  ;; GetVolumePathNamesForVolumeName, does not seem to work for me.
  ;; So this is a tedious bit of kludgy sequential search.
  (let ((volume-name (make-alien unsigned-char 64)) ; Microsoft doco says the max length is 50
        (result 0))
    (declare (type integer result))
    ;; read the low-level volume name given a normal path
    (setq result
          (GetVolumeNameForVolumeMountPointA (lisp-string->char-string mount-point) volume-name 64))
    (when (zerop result)
      ;; if the call fails, the path isn't a mount point
      (return-from get-volume-name mount-point))
    ;; now create a lisp string from the character array
    (let ((volume (make-string 64)))
      (declare (type string volume))
      (dotimes (i 64)
        (let ((c (deref volume-name i)))
          (when (zerop c)
            ;; hit end of array, so truncate the string
            (setq volume (subseq volume 0 i))
            (return))
          (setf (char volume i) (code-char c))))
      volume)))

(defun volume-name->disk-name (volume-name)
  "
  Semantics: returns disk-name for low-level volume name
  Arguments: /volume-name/ is a low-level volume name
    of the form \\??\\Volume{GUID}\\
  Returns: lisp string in form X:\\ where X is the disk name.
    or /volume-name/ if there is no associated disk
  "
  (dotimes (disk 26 volume-name)
    (let* ((disk-name (concatenate 'string (string (code-char (+ disk (char-code #\A)))) ":\\"))
           (disk-volume-name (get-volume-name disk-name)))
      (when (and (>= (length volume-name) (length disk-volume-name) 4)
                 (equalp (subseq disk-volume-name 4) (subseq volume-name 4)))
        (return-from volume-name->disk-name disk-name)))))

(defun mount-point->disk-name (pathspec)
  "
  Semantics: Converts the mount point /pathspec/ into the name of the disk
    it points to.
  Arguments: /pathspec/ is the pathspec of a mount point
  Returns: the namestring of the disk pointed to by /pathspec/
  Error Conditions: signals
  "
  (let ((volume-name (get-volume-name (namestring (cl::truename pathspec)))))
    (volume-name->disk-name volume-name)))

(defun extract-path-from-mount-point (reparseStructure)
  "internal function for getting a path from a mount point"
  (declare (type (alien (struct ReparseStructure)) reparseStructure))
  ;; get the union fron the reparse structure
  (with-alien
      ((reparseUnion (union ReparseUnion) (slot reparseStructure 'reparse-union)))
    ;; get the mount-point from the union
    (with-alien
        ((mount-point (struct MountPointStructure) (slot reparseUnion 'mount-point-structure)))
      ;; get the string buffer from the mount-point
      (with-alien ((buffer (array unsigned-short 248) (slot mount-point 'path-buffer))
                   (sname-offset unsigned-short (slot mount-point 'substitute-name-offset))
                   (sname-length unsigned-short (slot mount-point 'substitute-name-length)))
        ;; adjust for size of wchar
        (setq sname-offset (/ sname-offset 2)) ; offset is returned in bytes
        (setq sname-length (/ sname-length 2)) ; length is returned in bytes
        ;; get the lisp equivalent
        (let ((sname-string
               (wchar-string->lisp-string (addr (deref buffer sname-offset)) sname-length)))
          ;; sname-string has form \??\Volume{GUID}\
          ;; OR sname-string has form \??\X:\ -- it all depends...
          (if (> (length sname-string) (length "\\??\\X:\\"))
              ;; we have to do this the hard way
              (volume-name->disk-name sname-string)
              ;; otherwise don't forget to lop off the \??\ part...
              (subseq sname-string 4)))))))

(defun extract-path-from-symlink (reparseStructure)
  "internal function for getting a path from a symlink"
  ;; get the union from the structure
  (with-alien
      ((reparseUnion (union ReparseUnion) (slot reparseStructure 'reparse-union)))
    ;; get the symlink from the union
    (with-alien
        ((symlink (struct SymbolicLinkStructure) (slot reparseUnion 'symbolic-link-structure)))
      ;; get the string buffer from the symlink
      (with-alien ((buffer (array unsigned-short 246) (slot symlink 'path-buffer)))
        (let ((sname-offset (slot symlink 'substitute-name-offset))
              (pname-offset (slot symlink 'print-name-offset))
              (sname-length (slot symlink 'substitute-name-length))
              (pname-length (slot symlink 'print-name-length)))
          (declare (type integer sname-offset pname-offset sname-length pname-length))
          ;; adjust for size of wchar
          (setq sname-offset (/ sname-offset 2)) ; offset is returned in bytes
          (setq pname-offset (/ pname-offset 2))
          (setq sname-length (/ sname-length 2)) ; length is returned in bytes
          (setq pname-length (/ pname-length 2))
          ;; convert the alien pointer to a lisp string
          (with-alien
              ((sname (* unsigned-short) (addr (deref buffer sname-offset))))
              ;; (pname (* short) (addr (deref buffer pname-offset))))
            (let ((slink (wchar-string->lisp-string sname sname-length))
                  (indicator-length (length "\\??\\")))
              ;; if linking another device, we need to strip a \\??\\ from the front...
              (if (and (>= (length slink) indicator-length)
                       (equal "\\??\\" (subseq slink 0 indicator-length)))
                  (subseq slink indicator-length)
                  slink))))))))

;;;; Windows shortcut support.  Based on:

;;; Jesse Hager: The Windows Shortcut File Format.
;;; http://www.wotsit.org/list.asp?fc=13
;;; Taken from David Lichteblau's modifications to asdf.lisp
;;; http://www.lichteblau.com/blubba/shortcut/asdf.lisp

;;; For the meaning of the magic numbers, see the Hager reference
(defparameter *link-initial-dword* 76)
(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))

(defun read-null-terminated-string (s)
  (with-output-to-string (out)
    (loop
        for code = (read-byte s)
        until (zerop code)
        do (write-char (code-char code) out))))

(defun read-little-endian (s &optional (bytes 4))
  (let ((result 0))
    (loop
        for i from 0 below bytes
        do
        (setf result (logior result (ash (read-byte s) (* 8 i)))))
    result))

(defun parse-file-location-info (s)
  (let ((start (file-position s))
        (total-length (read-little-endian s))
        (end-of-header (read-little-endian s))
        (fli-flags (read-little-endian s))
        (local-volume-offset (read-little-endian s))
        (local-offset (read-little-endian s))
        (network-volume-offset (read-little-endian s))
        (remaining-offset (read-little-endian s)))
    (declare (ignore total-length end-of-header local-volume-offset))
    (unless (zerop fli-flags)
      (cond
        ((logbitp 0 fli-flags)
         (file-position s (+ start local-offset)))
        ((logbitp 1 fli-flags)
         (file-position s (+ start
                             network-volume-offset
                             #x14))))
      (concatenate 'string
                   (read-null-terminated-string s)
                   (progn
                     (file-position s (+ start remaining-offset))
                     (read-null-terminated-string s))))))

(defun windows-link-p (filespec)
  "Is /filespec/ a Windows .lnk shortcut file?"
  ;; must end in .lnk
  (when (not (equalp (pathname-type filespec) "LNK"))
    (return-from windows-link-p nil))
  ;; needs to have the correct header
  (with-open-file (s filespec :element-type '(unsigned-byte 8))
    (handler-case
        (and (= (read-little-endian s) *link-initial-dword*)
             (let ((header (make-array (length *link-guid*))))
               (read-sequence header s)
               (equalp header *link-guid*)))
      (end-of-file () nil))))

(defun parse-windows-shortcut (pathname)
  (with-open-file (s pathname :element-type '(unsigned-byte 8))
    (handler-case
        (when (and (= (read-little-endian s) *link-initial-dword*)
                   (let ((header (make-array (length *link-guid*))))
                     (read-sequence header s)
                     (equalp header *link-guid*)))
          (let ((flags (read-little-endian s)))
            (file-position s 76)        ;skip rest of header
            (when (logbitp 0 flags)
              ;; skip shell item id list
              (let ((length (read-little-endian s 2)))
                (file-position s (+ length (file-position s)))))
            (cond
              ((logbitp 1 flags)
               (parse-file-location-info s))
              (t
               (when (logbitp 2 flags)
                 ;; skip description string
                 (let ((length (read-little-endian s 2)))
                   (file-position s (+ length (file-position s)))))
               (when (logbitp 3 flags)
                 ;; finally, our pathname
                 (let* ((length (read-little-endian s 2))
                        (buffer (make-array length)))
                   (read-sequence buffer s)
                   (map 'string #'code-char buffer)))))))
      (end-of-file ()
                   nil))))

(define-condition symlink-error (error) ())

(defun truename-aux (filespec &optional (depth 0))
  ;; RECURSIVE INVARIANT: /filespec/ is an absolute path, not relative
  ;; always returns an absolute pathname
  (when (> (incf depth) 16)
    ;; poor man's recursion detection...
    (error 'symlink-error))
  ;(when (windows-link-p filespec)
  ;  (return-from truename-aux (truename-aux (parse-windows-shortcut (namestring filespec)) depth)))
  (let ((handle (get-link-handle filespec)))
    (declare (type integer handle))
    ;; check for failure
    (when (eq handle -1)
      ;; generally, this means we can't find the file
      (error 'symlink-error))
    (with-alien ((reparseStructure (struct ReparseStructure))
                 (bytes-returned unsigned-int))
      ;; see kalmbach to interpret the constants here...
      (let ((result (DeviceIoControl handle #x900A8 nil #x0
                                     (addr reparseStructure)
                                     #x200 (addr bytes-returned) nil)))
        (declare (type integer result))
        ;; done with handle
        (CloseHandle handle)
        ;; check for failure, meaning device is not a link
        (when (zerop result)
          ;; we are done
          (return-from truename-aux filespec))
        (let ((tag (slot reparseStructure 'reparse-tag)))
          (cond
            ((not (reparse-tag-p tag))
             filespec)
            ((symlink-p tag)
             (let* ((sympath (extract-path-from-symlink reparseStructure))
                    (dirlist (pathname-directory sympath)))
               (case (car dirlist)
                 (:ABSOLUTE
                  ;; an :absolute directory can be used as is
                  (truename-aux sympath depth))
                 (otherwise
                  ;; a :relative directory must be merged with the base directory before continuing
                  (let ((merged-path (merge-pathnames sympath (directory-namestring filespec))))
                    (setq merged-path (sb-impl::simplify-win32-namestring (namestring merged-path)))
                    (truename-aux merged-path depth))))))
            ((mount-point-p tag)
             (pathname (extract-path-from-mount-point reparseStructure)))
            (t
             filespec)))))))

(defun truename (filespec)
  #.(concatenate 'string
                 (documentation 'cl::truename 'function)
  "

Under Windows, the TRUENAME of a symlink that does not
exist or of a recursive symlink, or a symlink more than
16 levels deep, is the name of the symlink.

  ")
  (let ((original-path (cl::truename filespec)))
    (handler-case
        (cl::truename (truename-aux original-path))
      (symlink-error () original-path)
      (file-error () original-path))))

(defun file-write-date (pathspec)
  #.(documentation 'cl::file-write-date 'function)
  (cl::file-write-date (truename pathspec)))

 

Running SBCL on Windows

This post applies to running Steel Bank Common Lisp version 1.0.16 and 1.0.17 on Windows Vista. It may apply to later or earlier versions of SBCL, but I cannot directly attest to that. It may apply to certain functionality under Windows XP, but I cannot attest to that either.

With reference to:

http://robert.zubek.net/blog/2008/04/09/sbcl-emacs-windows-vista/
http://sbcl-internals.cliki.net/Build%20on%20Windows
http://www.sbcl.org/

The following is a set of useful utilities for running SBCL in a windows environment.  The utilities deal with setting the default-pathname, the current working directory, and executing shell commands.  Your milage may vary.

Changing Directories

Lisp has a global variable called *default-pathname-defaults*.  This variable works like a “current directory” when executing lisp commands like #’load or #’directory.  However, when you are doing any work via the foreign function interface (that is: if you are calling out to use operating system commands) then there is also the notion of the “current working directory” which is the location the operating system thinks you are executing from.  This current working directory (aka “execution path” aka “execution directory”) is not necessarily the same as the *default-pathname-defaults* directory.

Here is source code for the following lisp commands under SBCL

(CWD pathname) — update current working directory to /pathname/

(CD pathname) — update both *default-pathname-default* and the current working directory to /pathname/

The source code uses the alien (foreign) function interface for SBCL.

(load-shared-object "Kernel32")

(declaim (inline SetCurrentDirectoryA))
(declaim (inline GetCurrentDirectoryA))

(define-alien-routine ("SetCurrentDirectoryA" SetCurrentDirectoryA) int
  (directory (* unsigned-char)))

(define-alien-routine ("GetCurrentDirectoryA" GetCurrentDirectoryA) unsigned-int
  (buffer-length unsigned-int)
  (buffer (* unsigned-char)))

(defun char-string->lisp-string (cstring &optional (length -1))
  "
  Arguments: /cstring/ is a pointer to a zero-terminated
    array of chars (unsigned bytes)
    /length/, if supplied, truncates the translation after
    /length/ number of characters if a zero-termination is not
    encountered before that
  Semantics: translates /cstring/ to a lisp string.  If
    /cstring/ is a null pointer, returns nil
  Returns: a lisp string or nil.
  "
  (declare (type integer length))
  (when (null-alien cstring)
    (return-from char-string->lisp-string nil))
  ;; calculate the length
  (when (minusp length)
    (do ((index 0 (incf index)))
        ((= (deref cstring index) 0) (setq length index))))
  (do* ((index 0 (incf index))
        (char (deref cstring index) (deref cstring index))
        (lisp-string (make-array length :element-type 'character)))
       ((or (= index length) (zerop char)) (subseq lisp-string 0 index))
    (declare (type integer index)
             (type (unsigned-byte 8) char)
             (type string lisp-string))
    (setf (aref lisp-string index) (code-char char))))

(defun lisp-string->char-string (string)
  "
  Semantics: converts the lisp /string/ into an alien pointer to
    a zero-terminated array of 8-bit chars.  Any
    characters in /string/ with a unicode code point
    > #xFF are given a representation as #x1A -- the
    standard unicode Substitute control
  Returns: Two values: an alien pointer to a zero-terminated array of
    8-bit chars suitable for passing to a Windows API;
    and the length of the string
  "
  (let* ((size (length string))
         (char-string (make-alien (unsigned 8) (1+ size)))
         (unicode 0)
         (char 0))
    (declare (type integer size unicode)
             (type (unsigned-byte 8) char))
    (dotimes (index size)
      (setq unicode (char-code (elt string index)))
      (when (> unicode #xFF) (setq unicode #x1A)) ; coerce to 8-bits
      (setq char (coerce unicode '(unsigned-byte 8)))
      (setf (deref char-string index) char))
    (setf (deref char-string size) 0)
    (return-from lisp-string->char-string
      (values char-string size))))

(defun get-cwd ()
  "
  Semantics: returns pathname for the current working (execution) directory.
    The current working directory is the directory the operating system
    believes the program is running in.  Shell commands execute here.
  Arguments:
  Returns: pathname of the current working directory
  "
  (let* ((size (GetCurrentDirectoryA 0 nil))
         (cwd (make-alien unsigned-char size)))
    (declare (type integer size))
    (GetCurrentDirectoryA size cwd)
    (char-string->lisp-string cwd size)
    (truename (char-string->lisp-string cwd size))))

(defun cwd (&optional dir)
  "
  Semantics: Set the current working directory to /dir/.
    If /dir/ is nil or omitted, get the current working directory.
  Arguments: /dir/ is a slash-terminated lisp string or directory
    pathspec
  Returns: the current working directory after execution
  Error Conditions: signals 'file-error if not possible
  "
  (when (null dir)
    (return-from cwd (get-cwd)))
  (let ((result (SetCurrentDirectoryA (lisp-string->char-string (namestring dir)))))
    (declare (type integer result))
    (if (zerop result)
        (error (make-condition 'file-error :pathname dir))
        (get-cwd))))

(defun set-default-directory (&optional (pathname ""))
  "Update *default-pathname-defaults* to /pathname/"
  (setf *default-pathname-defaults* (truename pathname)))

(defun cd (&optional (pathname ""))
  "Update both *default-pathname-defaults* and working directory to /pathname/"
  (set-default-directory pathname)
  (cwd *default-pathname-defaults*))

Executing Shell Commands

There is a facility in SBCL for sending a command to the enclosing operating system: #’sb-ext:run-program.  I’m sure run-program has been extensively debugged under *NIX, and it may even run well under (X)Emacs under *NIX, but it is not much fun to use under XEmacs on Windows.

The following is a Steel Bank Common Lisp implementation of a function to execute a dos command shell command

(SHELL command) — Run /command/ in a dos shell.  Return the result.

(defun shell (command &key silent)
  "
  Syntax (dos command [:silent silent])
  Semantics: Run the /command/ in a dos shell.  Return when /command/ does.
  Side Effects: /command/ is run in a dos shell.
  Arguments: /command/ is a string such as could be run from the dos cmd shell.
    If /silent/ is t return an empty string for the output.  Default is nil.
  Returns: (values output status) where /output/ is the output string.  If
    /silent/ is t, then /output/ is supressed to an empty string.
    /status/ is t if the /command/ succeeds, nil otherwise.
  "
  ;; Note: many of the options to #'run-program seem broken in Windows
  ;; under XEmacs.  E.g. the simple :output t option doesn't work under
  ;; XEmacs -- though it does in an SBCL shell.  I'm sure there's a
  ;; good reason for that involving XEmacs redirections and Slime,
  ;; but I don't really want to track it down.
  ;; This function kludges over all the problems by redirecting output
  ;; to a file, then reading the file and returning its contents.
  ;; The temporary file is discarded after use.
  ;; It works for me!
  (let ((args (list "/C" command))
        (filename "")
        (result ""))
    ;; get a safe temporary filename
    (do ((candidate-name (string (gensym "TEMPFILE")) (string (gensym "TEMPFILE"))))
        ((not (probe-file candidate-name)) (setq filename candidate-name)))
    (let ((proc (sb-ext:run-program "CMD" args :output filename :search t :wait t)))
      (setq result
            (with-open-file (stream filename :direction :input)
              (with-output-to-string
                (output)
                (do ((line (read-line stream nil stream) (read-line stream nil stream)))
                    ((eql line stream))
                  (format output "~A~%" line)))))
      (when (probe-file filename) (delete-file filename))
      (values
       (if silent
           ""
           (remove #\return result)) ;; handle dos carriage-return line-feed for nice display
       (zerop (sb-ext:process-exit-code proc))))))

 

 

Broken and Ill-Documented API for Windows Mount-Points

 

This note is written for programmers who must deal with mount points under Windows. It applies to Windows Vista Home Premium version 6.0.6000 with kernel32.dll version 6.0.6000.16386. It may apply to other versions of Microsoft’s operating systems, but I have no first-hand knowledge of such. If you are having trouble with GetVolumePathNamesForVolumeName, or other functions to manage links and junctions, the following may apply.

With reference to:

 http://blog.kalmbach-software.de/2008/02/28/howto-correctly-read-reparse-data-in-vista/

 http://blogs.msdn.com/adioltean/archive/2005/04/16/408947.aspx

 http://msdn.microsoft.com/en-us/library/aa365730(VS.85).aspx

 http://msdn.microsoft.com/en-us/library/aa365503(VS.85).aspx

Programmers who must manage links under Windows Vista should beware!  Of the several low-level functions which purport to manage links and junctions under Vista, it appears that at least two are completely broken and others will exhibit unexpected behavior depending on factors outside of your control.

The broken functions are GetVolumePathNamesForVolumeNameA and GetVolumePathNamesForVolumeNameW.

After extensive thrashing, I have come to the conclusion that these functions do not operate as
documented (see http://msdn.microsoft.com/en-us/library/aa364998(VS.85).aspx); indeed, I can not get these functions to work at all.  Both return 0 (BOOL FALSE) for all combinations of arguments applied as per the Microsoft documentation.

In addition to the broken functionality, unexpected behavior arises from the different facilities for creating mount points (variously called Junctions, Directory Junctions, Mount Points, and/or Volume Mount Points in Microsoft’s documentation) under Vista 6.0.6000.  These facilities are: mountvol, mklink, and /Control Panel/System and Maintenance/Administrative Tools/Computer Management/Storage/Disk Management/.   Mountvol and Disk Management function similarly; mklink is different.

When you create a mount point using mountvol or Disk Management, the substitute name in the REPARSE_DATA_BUFFER (see http://msdn.microsoft.com/en-us/library/ms791514.aspx) acquired via DeviceIoControl associated with the mount point is a low-level volume designator of the form \??\Volume{GUID}\.  When you create a mount point using mklink (e.g. via mklink /J MOUNTPATH X:), the substitute name in the REPARSE_DATA_BUFFER is a disk-name (X:), not a volume designator.  In neither case is the print-name field of the REPARSE_DATA_BUFFER populated. 

[Note that, until very recently the Microsoft documentation for REPARSE_DATA_BUFFER incorrectly omitted the flags field from the SymbolicLinkReparseBuffer part of the union.]

[For a description of how to acquire the REPARSE_DATA_BUFFER in C++ for Windows links, see  http://blog.kalmbach-software.de/2008/02/28/howto-correctly-read-reparse-data-in-vista/.]

Note also that mountvol displays volume designators with the syntax \\?\Volume{GUID}\ whereas the REPARSE_DATA_BUFFER returns volume designators with the syntax \??\Volume{GUID}\.  The functions GetVolumeNameForVolumeMountPointA and GetVolumeNameForVolumeMountPointW return volume designators with the syntax \\?\Volume{GUID}\.

What this means is that in order to acquire the actual disk name from a mount point you will need to examine the substitute name acquired in the REPARSE_DATA_BUFFER.  If the name is of the form \??\X:\ you are done.  If it is of the form \??\Volume{GUID}\, you will need to examine the 26 possible results from GetVolumeNameForVolumeMountPoint (one for each disk name of the form X:\).  If there is a match in the GUID’s, then you have found the actual disk to which the mount point refers.

I am sure this all makes sense to Microsoft somehow.  It doesn’t to me; but, hey.

I’ve implemented all this in Steel Bank Common Lisp’s FFI in order to fix the truename function under Windows.  You are welcome to look at the code for inspiration, but if you are a C/C++/C#/Java/etc. hacker it will probably be illegible.

Stability and CLtL2 Conformance Review of Corman Lisp

 
Background

The cl-ansi-tests application (I am using the July 2005 version) is a set of over 20,000 individual tests of various aspects of a lisp’s conformance with the Common Lisp standard.  It was written by Paul Dietz over the span of many years.  Running cl-ansi-tests is a good way to discover things about a particular lisp implementation, but, as Paul Dietz says, the “tests have not been selected to reflect the importance or relative frequency of different CL features”, so the numerical results of the tests must be interpreted carefully.  It is possible for a lisp implementation to fail many trivial conformance tests, but succeed at all the important ones.  Likewise, it is possible for a lisp implementation to pass nearly all the tests, but to fail a few critically important ones.

Since the cl-ansi-tests suite is a moderately-large, stressful application (~180,000 lines of code contained in ~850 files), running the cl-ansi-tests suite serves as a good stability test as well as a standards conformance test.  I will describe my conformance testing results separate from the stability testing results.  Then I will present my (subjective) interpretation of the tests.

The Procedure

Everything necessary to run the cl-ansi-tests suite under Corman Lisp is distributed here: ansi-tests.  The distribution includes source code for a modified version of the cl-ansi-tests suite (see ansi-tests/cl-ansi-tests-20050704.ccl/), some ANSI-compatibility patches for Corman Lisp (see ansi-tests/corman-patches/ and ansi-tests/compatibility.lisp), directions for running the tests (see the header for ansi-tests/run-cl-ansi-tests.lisp), and the results from running the tests (see ansi-tests/cl-ansi-tests.24052008.results).

The cl-ansi-tests suite from CLOCC will not load under Corman Lisp out of the box; modification to six files was required to get it running with Corman Lisp.  You can see a list of modifications by grepping “cormanlisp” on the source code located at ansi-tests/cl-ansi-tests-20050704.ccl/.  I wrote a replacement test driver for Corman Lisp called ‘run-cl-ansi-tests.lisp’; you should use this driver instead of the ‘doit.lsp’ file which is distributed with the cl-ansi-tests suite.

I ran the tests under Windows VISTA on a dual-core Pentium, using Corman Lisp version 3.02 (beta, pre-release).  I made a number of changes to the Corman Lisp release.  The changes are detailed in the file ‘compatibility.lisp’ from the distribution.

Usage instructions are available in the comments at the head of the ‘run-cl-ansi-tests.lisp’ file in the distribution.  If you attempt to run the tests via the usual ‘doit.lsp’, you will crash.

I ran as many of the tests as I could, given my time constraints.  In the end, I was able to run 17,271 tests out of a total of more than 21,000 tests.

The distribution includes a copy of the test output with a listing of all failed tests in the file ‘cl-ansi-tests.24052008.results’.

Results and Interpretation of the ANSI Conformance Tests

The result of my testing, as of 25 May 2008, using Corman Lisp version 3.02 (beta, pre-release) and a modified version of the cl-ansi-tests-20050704.orig test suite downloaded from the UBUNTU archives, was that ccl failed 4,643 tests and passed 12,628 tests.  I was able to run 17,271 tests; I was unable to run approximately 4,000 tests. 

The runnable tests were in the following categories:

  symbols
  iteration
  cons
  arrays
  hash-tables
  types-and-classes
  strings
  characters
  pathnames
  files
  streams
  conditions
  packages
  sequences
  system-construction
  objects
  numbers
  eval-and-compile
  data-and-control-flow
  structures

I was unable to run the following categories of tests:

  printer
  reader
  environment
  miscellaneous

I did not run those categories of tests because either the tests would not load, or, once loaded, the tests would hang or crash my system repeatedly.  I ran out of time to debug them.

The largest category of test failures resulted from non-conforming error-signaling behaviors: specifically, Corman Lisp often signals an error at the correct spot, but signals the incorrect error according to the spec.  For example, Corman Lisp will typically signal a ‘SIMPLE-ERROR if the wrong number of arguments is supplied to a function; the specification is for a ‘PROGRAM-ERROR.

The second largest category of tests failures was caused by deficiencies in ccl’s type system with
regard to the specification.

The next largest category of test failures was caused by improper handling of the :allow-other-keys
keyword: specifically, the spec states that any function or macro accepting any keyword must also
accept the :allow-other-keys keyword.  Corman Lisp incorrectly signals an error if :allow-other-keys
is used without being explicitly declared in the function or macro lambda list.

These three categories of failures accounted for approximately half of all test failures.

Other significant categories of test failures arose from ccl’s type system, incomplete implementation
of the crufty and byzantine ‘loop’ facility, and the failure of the :default-initargs option to
defclass.  You can peruse the complete listing of program output in the file
‘cl-ansi-tests.24052008.results’ from the distribution.

Users should be aware that a small number of test cases failed due to non-ANSI scoping rules for
special variables in certain unusual cases.

Based on the results of this round of testing, it appears that significant improvement could be made
very quickly to Corman Lisp’s ANSI compatibility by attending to the following (in order of sheer
numbers of tests):

1. Error signaling in accordance with CLtL2 (> 1150 cases);
2. Harmonizing ccl’s type system with the spec (> 700 cases);
3. Fixing :allow-other-keys (> 300 cases);
4. Implementing the rest of the LOOP spec (> 150 cases);
5. Fixing the :default-initargs option to defclass.

I estimate that fixing these issues would reduce the number of failed tests by an order of magnitude.

I should emphasize that the large majority of failures exhibited by ccl were rather trivial: improper error signaling, a nit-picking problem with :allow-other-keys, missing LOOP features that nobody uses anyway, etc.  A few of the failures were more serious in terms of incorrect code generation or missing, but useful, language features.  (For example, due to a code-generation error, #’with-package-iterator is broken.)  Generally, I would say the results of the testing were quite positive: ccl is a nearly ANSI compliant implementation of lisp, none of the non-compliant behaviors are difficult to fix, none of the non-compliant behaviors are terribly important, and a little effort can yield a big improvement.

Results of Stability Testing

Unfortunately, considered as a stability test, the results of running the test suite were disappointing.  I encountered context-dependent and intermittent instabilities in ccl during the course of testing.  I found several cases where, separately, I could run Program A, or I could run Program B, but if I tried to run Program A followed directly by Program B, ccl would hang or crash.
I also encountered several non-reproducible problems where ccl would run a program perfectly well part of the time, but would hang or crash other times.  Specifically, I cannot run the entire test suite at once: I must load and execute parts of the suite file-by-file.  If I try to load the entire test suite, ccl will hang.

Summary & Caveats

Corman Lisp conforms substantially to the CLtL2 spec, although significant areas of non-conformance exist.  I would estimate that the most significant areas of non-compliance in terms of numbers of pages of the CLtL2 specification violated are (in some rough order):

1. Error signaling with incorrect condition types
2. The type system mishandles many objects
3. The LOOP specification is not completely implemented

I would estimate that the most significant areas of non-conformance in practical terms of creating bugs and gotchas in code you are writing or trying to port are:

1. The :default-initargs option to defclass does not work
2. The :test-not option to several functions (member, adjoin, etc.) does not work
3. No support for synonym streams or broadcast streams
4. Some FORMAT directives (notably ~<~>) are broken

Subjectively, the most important current issue standing in the way of Corman Lisp’s suitability for product-deployment is not *any* of the ANSI conformance issues, which are relatively minor; the most important current issue is the stability of Corman Lisp measured by the frequency of opaque crashes and system hangs (hang = processor runs away and never comes back).  The stability issues must be fixed before Corman Lisp can be considered production-ready.

The strengths of Corman Lisp are its source-code (which is both readily-available and cleanly-written), its compatibility with Microsoft’s C/C++ compiler (which is the compiler of choice for a vast number of commercial applications), and its intuitive and versatile FFI (compare, for instance, how difficult it is to call Lisp from C in SBCL vs. how easy it is in Corman Lisp and you will see what I mean). 

Based on my experience over the past few months with Corman Lisp, including writing approximately 5000 lines of cormanlisp lisp, I would say the support I’ve received from Roger has been outstanding and the lisp implementation is generally reliable and fast.  If the stability issues with the Corman Lisp implementation can be fixed, I would not hesitate to recommend Corman Lisp for anyone who needs a tightly-integrated lisp/C/C++ solution at a quite reasonable cost.

May 2008

 

 

Lisp-Unit-Tester — a portable unit-tester for Lisp

Lisp-Unit-Tester (aka LUT)

[Note: this document is a revised version of the original written by Chris Riesbeck.  It has been modified to reflect changes made to the lisp-unit package (including a name change to lisp-unit-tester) at the pleasure of Neil Haven. When I posted this description yesterday, 25 May 2008, I neglected to include a link to download the package, my apologies -- it is now included below where it says download here.]

lisp-unit-tester (with nickname :lut) is a Common Lisp library that supports unit testing (download here).  Unit testing is the coding practice wherein a library of functionality tests is developed along with, or even ahead of, production code.  Unit testing helps detect regressions (code changes that break old functionality), helps focus design efforts on meeting practical and well-defined goals, and helps detect bugs.

There is a long history of testing packages in Lisp, traditionally called “regression” testers, see, for example,  RT (ca 1990), CLUnit (ca 2000), Heute (ca 2007).  Unit testing packages in Lisp and other languages benefit from inspiration by eXtreme Programming practices and JUnit for Java.

This page has two parts:

• An overview with examples
• A reference section with all forms and functions

Overview

Chris Riesbeck’s main goal for the original unit-tester package was to make it simple to use.  It is well-suited to both beginning and advanced Lisp programmers. The advantages of unit-tester, and the revised version lisp-unit-tester, are:

• Written in portable Common Lisp.  The package has been run under sbcl, clisp, corman common lisp, lispworks lisp, and so on…
• Just one file to load.
• Dead-simple to define and run tests. See example.
• Supports redefining functions and even macros without reloading tests.
• Supports test-first programming.
• Supports testing return values, printed output, macro expansions, and error conditions.
• Produces short readable output with a reasonable level of detail.
• Groups tests by package for modularity.

The changes from Chris Reisbeck’s original package now present in lisp-unit-tester are the following:

• Unexpected errors in test code no longer abort tests;
• All tests are automatically numbered sequentially for ease of reference;
• Groups of tests are executed in the order defined rather than alphabetically;
• The package now works under CormanLisp;
• All exported functions are now documented;
• The user has the option to set a verbose success mode so that successful tests are not silent;
• Unexpected errors in tests are tallied and reported.

How to Use lisp-unit-tester

1. Load (or compile and load) lisp-unit-tester.lisp.
2. Evaluate (use-package :lut) or, if you prefer a lot of typing, (use-package :lisp-unit-tester) 
3. Load a file of tests. See below for how to define tests. An example file (test-lisp-unit.lisp) is provided with the distribution.
4. Run the tests with test.

Uniquely numbered test results will be printed, along with a summary of how many tests were run, how many passed, how many failed, and how many error conditions were generated.  (It is possible to customize the behavior of :lut so that only test failures will be printed; it is also possible to customize the behavior of :lut so that unexpected error conditions halt testing.)

You define a test with define-test:

(define-test name exp₁ exp₂ …)

This defines a test called name. The expressions can be anything, but typically most will be assertion forms.

Tests can be defined before the code they test, even if they’re testing macros. This is to support test-first
programming.

After defining your tests and the code they test, run the tests with

(test)

This runs every test defined in the current package. To run just a specific test, use

(test name₁)

To run multiple specific tests, use

(test (name₁ name₂ …))

To run tests in a particular package named mypackage, use

(test (name₁ name₂ …) :in-package mypackage)

e.g., (test (greater summit) :in-package mypackage).

The following example

• defines some tests to see if pick-greater returns the larger of two arguments
• defines a deliberately broken version of pick-greater
• runs the tests

First, we define some tests.

> (define-test pick-greater
    (assert-equal 5 (pick-greater 2 5))
    (assert-equal 5 (pick-greater 5 2))
    (assert-equal 10 (pick-greater 10 10))
    (assert-equal 0 (pick-greater -5 0)) )
PICK-GREATER

Following good test-first programming practice, we run these tests before writing any code.

> (test pick-greater)
PICK-GREATER:1 (PICK-GREATER 2 5) failed:
   Expected 5 but saw #<Undefined-Function #x1719AD0>; …
PICK-GREATER:2 (PICK-GREATER 5 2) failed:
  Expected 5 but saw #<Undefined-Function #x175ACC0>; …
PICK-GREATER:3 (PICK-GREATER 10 10) failed:
  Expected 10 but saw #<Undefined-Function #x177A640>; …
PICK-GREATER:4 (PICK-GREATER -5 0) failed:
  Expected 0 but saw #<Undefined-Function #x179A170>; …
PICK-GREATER: 0 assertions passed, 4 failed; including 4 execution errors.

This shows that we need to do some work. So we define our broken version of pick-greater.

> (defun pick-greater (x y) x) ;; deliberately wrong
PICK-GREATER

Now we run the tests again:

> (test pick-greater)
PICK-GREATER:1 (PICK-GREATER 2 5) failed: Expected 5 but saw 2
PICK-GREATER:2 (PICK-GREATER 5 2) succeeded: Got 5
PICK-GREATER:3 (PICK-GREATER 10 10) succeeded: Got 10
PICK-GREATER:4 (PICK-GREATER -5 0) failed: Expected 0 but saw -5
PICK-GREATER: 2 assertions passed, 2 failed; including 0 execution errors.

This shows two failures. The first test failed because (pick-greater 2 5) returned 2 when 5 was expected, and the fourth test case failed because (pick-greater -5 0) returned -5 when 0 was expected.

Assertion Forms

The most commonly used assertion form is

(assert-equal value form)

This tallies a failure if form returns a value not #’equal to value. Both value and test are evaluated in the local lexical environment. This means that you can use local variables in tests. In particular, you can write loops that run many tests at once:

> (define-test my-sqrt
    (dotimes (i 5)
     (assert-equal i (my-sqrt (* i i)))))
MY-SQRT
> (defun my-sqrt (n) (/ n 2)) ;; wrong definition!!
> (set-verbose-success nil) ;; only show failures
> (test my-sqrt)
MY-SQRT:2 (MY-SQRT (* I I)) failed: Expected 1 but saw 1/2
MY-SQRT:4 (MY-SQRT (* I I)) failed: Expected 3 but saw 9/2
MY-SQRT:5 (MY-SQRT (* I I)) failed: Expected 4 but saw 8
MY-SQRT: 2 assertions passed, 3 failed; including 0 execution errors.

Notice that the above output doesn’t tell us for which values of i the code failed. Fortunately, you can fix this by adding expressions at the end of the assert-equal. These expression and their values will be printed when the results of an assertion are announced.

> (define-test my-sqrt
    (dotimes (i 5)
     (assert-equal i (my-sqrt (* i i)) i))) ;; added i at the end
MY-SQRT
> (run-tests my-sqrt)
MY-SQRT:2 (MY-SQRT (* I I)) failed: Expected 1 but saw 1/2
   I => 1
MY-SQRT:4 (MY-SQRT (* I I)) failed: Expected 3 but saw 9/2
   I => 3
MY-SQRT:5 (MY-SQRT (* I I)) failed: Expected 4 but saw 8
   I => 4
MY-SQRT: 2 assertions passed, 3 failed; including 0 execution errors.

The next most useful assertion form is

(assert-true test)

This tallies a failure if test returns false. Again, if you need to print out extra information, just add expressions after test.

There are also assertion forms to test what code prints, what errors code returns, or what a macro expands into. A complete list of assertion forms is in the reference section.

How to Organize Tests with Packages

Tests are grouped internally by the current package, so that a set of tests can be defined for one package of code without interfering with tests for other packages.

If your code is being defined in cl-user, which is common when learning Common Lisp, but not for production-level code, then you should define your tests in cl-user as well.

If your code is being defined in its own package, you should define your tests either in that same package, or in another package for test code. The latter approach has the advantage of making sure that your tests have access to only the exported symbols of your code package.

For example, if you were defining a date package, your date.lisp file would look like this:

(defpackage :date
   (:use :common-lisp)
   (:export #:date->string #:string->date))
 (in-package :date)
(defun date->string (date) …)
(defun string->date (string) …)

Your date-tests.lisp file would look like this:

(defpackage :date-tests
  (:use :common-lisp :lisp-unit-tester :date))
(in-package :date-tests)
(define-test date->string
   (assert-true (string= ... (date->string ...)))
    ...)
...  

You could then run all your date tests in the test package:

(in-package :date-tests) (test)   

Alternately, you could run all your date tests from any package with:

(lisp-unit-tester:test :in-package :date-tests)

Reference Section

Here is a list of the functions and macros exported by lisp-unit-tester.

Functions for managing tests

(define-test name exp₁ exp₂ …)

This macro defines a test called name with the expressions specified, in the package specified by the value of *package* in effect when define-test is executed. The expresssions are assembled into runnable code whenever needed by run-tests. Hence you can define or redefine macros without reloading tests using those macros.

(remove-tests names [package])

This function removes the tests named for the given package. If no package is given, the value of *package* is used.

(remove-all-tests [package])

This function removes the tests for the given package. If no package is given, it removes all tests for the current package. If nil is given, it removes all tests for all packages.

(test [test | (test*)] [:in-package package])

Arguments: test – (not evaluated) a symbol designating a test defined with define-test
    package – the package to run the tests in, defaults to *package*
Semantics: run the named test or tests in the package.  If the tests are not provided or are
  nil, then all tests in <package> are run sequentially.
Examples: 
(test test1)                    
(test (test1 test2) :in-package :cl-user)
See Also: define-test
Returns: no values 

(use-debugger flag)

 If <flag> is nil, errors will be caught by lisp-unit-tester and the debugger will not be invoked.  If <flag> is t, lisp-unit-tester will not attempt to intercept errors.  By default, lisp-unit-tester is configured to intercept errors so that testing can proceed without the debugger.

(set-verbose-success flag)

Set <flag> to t when you want lisp-unit-tester to announce successful tests as well as failures.  Set <flag> to nil when you want lisp-unit-tester only to announce failures.  By default, lisp-unit-tester is configured to announce successes as well as failures.

(set-abort-on-conditions flag)

Set <flag> to t if you want an unexpected error signal to abort an entire test.  Set <flag> to nil if you want a test to continue after encountering an unexpected error.  By default, lisp-unit-tester is configured to continue after encountering unexpected errors.

(set-tag number)

 By default, the assertions within a particular test suite are numbered sequentially starting at 1.  You can change the origin of the running sequence by calling 'set-tag.  This can be useful if you need to have a unique identifying tag for each assertion within a test.

Forms for assertions

All of the assertion forms are macros. They tally a failure if the associated predication returns false. Assertions can be made about return values, printed output, macro expansions, and even expected errors. Assertion form arguments are evaluated in the local lexical environment.

All assertion forms allow you to include additional expressions at the end of the form. These expressions and their values will be printed only when the test fails.

Return values are unspecified for all assertion forms.

Assertions Involving Equality

(assert-eq value form [form₁ form₂ ...])
(assert-eql value form [form₁ form₂ ...])
(assert-equal value form [form₁ form₂ ...])
(assert-equalp value form [form₁ form₂ ...])
(assert-equality predicate value form [form₁ form₂ ...])

These macros tally a failure if value is not equal to the result returned by form, using the specified equality predicate.  In general, assert-equal is used for most tests.

 

Example use of assert-equality:
  (assert-equality #’set-equal ‘(a b c) (unique-atoms ‘((b c) a ((b a) c))))

Assertions Involving Boolean Value

(assert-true test [form₁form₂ ...]) 
(assert-false test [form₁form₂ ...])

assert-true tallies a failure if test returns false.
assert-false tallies a failure if test returns true.

Assertions of What Gets Printed

(assert-prints “output” form [form₁ form₂ ...])

This macro tallies a failure if form does not print to standard output stream a string equal to the given string, ignoring differences in beginning and ending newlines.

Assertions Involving Macroexpansion

(assert-expands expansion form [form₁ form₂ ...])

This macro tallies a failure if (macroexpand-1 form) does not produce a value equal to expansion.

Assertions of Error Conditions

(assert-no-error form [form₁ form₂ ...])

This macro tallies a failure if form signals an unhandled condition.

 (assert-error condition-type form [form₁ form₂ ...])

This macro tallies a failure if form does not signal an error that is equal to or a subtype of condition-type. Use error to refer to any kind of error. See condition types in
the Common Lisp Hyperspec for other possible names.

 

For example, (assert-error ‘arithmetic-error (foo 0)) would assert that
foo is supposed to signal an arithmetic error when passed zero.

Utility predicates

Several predicate functions are exported that are often useful in writing
tests with assert-equality.

(logically-equal value₁value₂)

This predicate returns true of the two values are either both true, i.e.,
non-NIL, or both false.

(set-equal list₁list₂ [:test])

This predicate returns true the first list is a subset of the second and
vice versa. :test can be used to specify an equality predicate.
The default is eql.

 

Package Documentation for Corman Lisp

Note: Applies to Corman Lisp versions > 3.01 running under Windows XP or Vista. The current release of Corman Lisp (version 3.01) needs some patching to work with :document-package. When the next release of Corman Lisp happens, I will update things as needed; until then, if you have an urgent need for a package documentation library under Corman Lisp you may contact me at g n e i l .at. L i b e r t y R e a c h . c o m and I will send you the necessary patches.

Document-Package – a package for documenting packages in Corman Lisp

I am releasing a utility for documenting a lisp package — unsurprisingly called :document-package.  It is a brain-dead cousin to the familiar doxygen utility.  The major difference is that, in lisp, it is possible and considered good practice to include documentation strings as part of the definition of your lisp objects as you create them.  Thus, a properly-written lisp library should be self-documenting.

The :document-package package steps through all exported and local objects in a package, extracts their documentation strings and other information such as associated lambda-lists, types, etc., and displays it all in a legible format.  It is possible to produce package documentation as plain text or as formatted html.

You can download the source for the package from here.  There is a document-package.system file included in the distribution if you prefer to load via mk:defsystem.  There is also a load-me.lisp file if you wish to simply load a file to get the package.  In any event, (use-package :dp) will make the package available.  You can test the package by running it on itself via (document :dp).

The following documentation was produced by running (document :dp :html t).

Documentation for Package DOCUMENT-PACKAGE

Nicknames:

• DP

 

Package Uses:

• COMMON-LISP

 

The :document-package package defines several useful documentation functions for use with Corman

Common Lisp v3.02+. It is meant to help in collating and writing documentation for lisp packages.

The way to use this package is as follows (in order of importance):

1. Document your package by placing a nice informative documentation string in the defpackage

declaration. Like this one!

2. Document each of your exported functions. Ideally including preconditions, semantics, side

effects, error conditions, and return values for each function.

3. Document each of your exported variables. Describe their semantics and legal values.

4. Document each of your local functions at least by describing the semantics.

Run the function (document ‘package-name). All the documentation will be

collected and displayed.

To test this package:

1. Un-block-comment the series of definitions at the end of the document-package.lisp file.

2. Reload the document-package package.

3. Run document-package on itself via (dp:document :dp) or (dp:document ‘DP) or

(dp:document “DOCUMENT-PACKAGE”) — they should all work by printing documentation to stdout.

Author: Neil Haven

Contact: [DELETED]

Release Version: 1.0.0 [May 2008]

Legal Restrictions on Use: GNU LGPL

Symbols Exported from DOCUMENT-PACKAGE

DOCUMENT [FUNCTION]

Usage: (DOCUMENT PACKAGE &KEY (STREAM *STANDARD-OUTPUT*) (HTML NIL))

Syntax: (document package :stream stream :html flag)

Arguments: /package/ is a package designator. The output /stream/ defaults to *standard-output*.

/html/ defaults to nil.

Preconditions: /package/ is loaded.

Semantics: collect and print all documentation for /package/ onto the output /stream/. If

/html/ is t, then the documentation is formatted as html.

Side Effects:

Error Conditions: /package/ must be loaded

Returns: t on success, nil on failure.

Symbols Internal to DOCUMENT-PACKAGE

FORMAT-H2 [MACRO]

Usage: (FORMAT-H2 STREAM FMT &REST ARGS)

Creates an header2 element

DOCUMENT-TYPE-BINDING [FUNCTION]

Usage: (DOCUMENT-TYPE-BINDING SYM &OPTIONAL (STREAM *STANDARD-OUTPUT*))

documentation for a type from deftype

FORMAT-H1 [MACRO]

Usage: (FORMAT-H1 STREAM FMT &REST ARGS)

Centers a header1 element

FORMAT-TITLED-LIST [MACRO]

Usage: (FORMAT-TITLED-LIST STREAM TITLE LIST)

==> title: a, b, c

NOPKG [FUNCTION]

Usage: (NOPKG STREAM ARGUMENT COLON ATSIGN &REST X)

a callable print function to ignore package designators in output

DOCUMENT-STRUCT-BINDING [FUNCTION]

Usage: (DOCUMENT-STRUCT-BINDING SYM &OPTIONAL (STREAM *STANDARD-OUTPUT*))

documentation for a structure from defstruct

FIND-DOC-STRING [FUNCTION]

Usage: (FIND-DOC-STRING BODY)

searches for a documentation string in a method body

DOCUMENT-SYMBOL-MACRO [FUNCTION]

Usage: (DOCUMENT-SYMBOL-MACRO SYM &OPTIONAL (STREAM *STANDARD-OUTPUT*))

documentation for a symbol macro

DOCUMENT-FUNCTION-BINDING [FUNCTION]

Usage: (DOCUMENT-FUNCTION-BINDING SYM &OPTIONAL (STREAM *STANDARD-OUTPUT*))

dispatch depending on function type; defmacro, defun, defgeneric, define-modify-macro

FORMAT-HTML-HEADER [MACRO]

Usage: (FORMAT-HTML-HEADER STREAM TITLE)

Create a html header with a title

DOCUMENT-SETF [FUNCTION]

Usage: (DOCUMENT-SETF SYM &OPTIONAL (STREAM *STANDARD-OUTPUT*))

documentation for defsetf

DOCUMENT-SETF-EXPANDER [FUNCTION]

Usage: (DOCUMENT-SETF-EXPANDER SYM &OPTIONAL (STREAM *STANDARD-OUTPUT*))

documentation for define-setf-expander

DOCUMENT-METHOD-FUNCTION [FUNCTION]

Usage: (DOCUMENT-METHOD-FUNCTION METHOD &OPTIONAL (STREAM *STANDARD-OUTPUT*))

documentation for standard method functions from defmethod

REFORMAT-TEXT-FOR-HTML [MACRO]

Usage: (REFORMAT-TEXT-FOR-HTML TEXT)

==> text

DOCUMENT-STANDARD-FUNCTION [FUNCTION]

Usage: (DOCUMENT-STANDARD-FUNCTION SYM &OPTIONAL (STREAM *STANDARD-OUTPUT*))

documentation for a function from defun

DOCUMENT-CLASS-BINDING [FUNCTION]

Usage: (DOCUMENT-CLASS-BINDING SYM &OPTIONAL (STREAM *STANDARD-OUTPUT*))

documentation for a class from defclass

*HTML-VERSION* [SYMBOL]: T

set to t for output formatted as html, nil otherwise

FORMAT-HTML-FOOTER [MACRO]

Usage: (FORMAT-HTML-FOOTER STREAM)

Create a html footer

DOCUMENT-MACRO-FUNCTION [FUNCTION]

Usage: (DOCUMENT-MACRO-FUNCTION SYM &OPTIONAL (STREAM *STANDARD-OUTPUT*))

documentation for a macro from defmacro and define-modify-macro

DOCUMENT-GENERIC-FUNCTION [FUNCTION]

Usage: (DOCUMENT-GENERIC-FUNCTION SYM &OPTIONAL (STREAM *STANDARD-OUTPUT*))

documentation for a generic function from defgeneric

DOCUMENT-VARIABLE-BINDING [FUNCTION]

Usage: (DOCUMENT-VARIABLE-BINDING SYM &OPTIONAL (STREAM *STANDARD-OUTPUT*))

documentation for a special variable via defvar defparameter defconstant

PRINT-DOCUMENTATION [FUNCTION]

Usage: (PRINT-DOCUMENTATION VAR &OPTIONAL (STREAM *STANDARD-OUTPUT*))

print documentation for var on stream

DOCUMENT-COMPILER-MACRO-FUNCTION [FUNCTION]

Usage: (DOCUMENT-COMPILER-MACRO-FUNCTION SYM &OPTIONAL (STREAM *STANDARD-OUTPUT*))

documentation for a compiler macro from define-compiler-macro

BREAK-TEXT [FUNCTION]

Usage: (BREAK-TEXT TEXT)

substitutes [br/]
~% for all occurrences of
~% and #newline in text