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))))))

 

 

---

Possibly related posts: (automatically generated)

• Progress update
• Porting SBCL ke Windows ?
• SBCL 1.0.21 di Windows