Initial CL parser/generator implementation

lib/COPYING

@@ -0,0 +1,25 @@
+  Copyright (C) 1995-2017 Pierre R. Mai
+
+  Permission is hereby granted, free of charge, to any person obtaining
+  a copy of this software and associated documentation files (the
+  "Software"), to deal in the Software without restriction, including
+  without limitation the rights to use, copy, modify, merge, publish,
+  distribute, sublicense, and/or sell copies of the Software, and to
+  permit persons to whom the Software is furnished to do so, subject to
+  the following conditions:
+
+  The above copyright notice and this permission notice shall be
+  included in all copies or substantial portions of the Software.
+
+  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR
+  OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
+  ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+  OTHER DEALINGS IN THE SOFTWARE.
+
+  Except as contained in this notice, the name of the author shall
+  not be used in advertising or otherwise to promote the sale, use or
+  other dealings in this Software without prior written authorization
+  from the author.

lib/README

@@ -0,0 +1,3 @@
+This directory contains excerpts of the PMSF Common Lisp Library (PMSF-Lib)
+necessary for FMIBench.  See COPYING for the licence governing the files
+contained in this directory.

lib/aes-utilities.lisp

@@ -0,0 +1,244 @@
+;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; aes-utilities.lisp --- Utilities concerned with AES
+;;;; 
+;;;; $Id$
+
+(cl:in-package #:pmsf-lib)
+
+(pmsf-lib:file-version :pmsf-lib "$Id$")
+
+;;;; %File Description:
+;;;; 
+;;;; This file contains utilities for AES encryption
+;;;; 
+
+(defvar *aes-processing-pathname* nil)
+
+(define-condition aes-processing-error (simple-error)
+  ((pathname :initarg :pathname :initform *aes-processing-pathname*
+             :reader aes-processing-error-pathname))
+  (:report 
+   (lambda (c s)
+     (with-standard-io-syntax
+       (let ((*print-readably* nil))
+         (format s 
+                 "Error processing AES encryption~@[ for ~A~]: ~?"
+                 (aes-processing-error-pathname c)
+                 (simple-condition-format-control c)
+                 (simple-condition-format-arguments c)))))))
+
+(defun aes-processing-error (datum &rest arguments)
+  (error 'aes-processing-error :format-control datum :format-arguments arguments))
+
+(defparameter *crypt-aes-provider*
+  "Microsoft Enhanced RSA and AES Cryptographic Provider")
+(defconstant +prov-rsa-aes+ 24)
+(defconstant +crypt-verify-context+ #xF0000000)
+(defconstant +crypt-silent+ #x00000040)
+
+(fli:define-foreign-function (crypt-acquire-context "CryptAcquireContext" :dbcs)
+    ((:ignore (:reference-return win32:handle))
+     (container (:reference-pass (:ef-wc-string :external-format :unicode :null-terminated-p t) :allow-null t))
+     (provider (:reference-pass (:ef-wc-string :external-format :unicode :null-terminated-p t)))
+     (prov-type win32:dword)
+     (flags win32:dword))
+  :result-type win32:bool
+  :calling-convention :stdcall)
+
+(fli:define-foreign-function (crypt-release-context "CryptReleaseContext")
+    ((hprov win32:handle)
+     (flags win32:dword))
+  :result-type win32:bool
+  :calling-convention :stdcall)
+
+(fli:define-c-typedef crypt-aes-256-key-data
+  (:c-array (:unsigned :byte) 32))
+
+(fli:define-c-typedef crypt-aes-256-iv-data
+  (:c-array (:unsigned :byte) 16))
+
+(fli:define-c-struct crypt-aes-256-key
+  (type (:unsigned :byte))
+  (version (:unsigned :byte))
+  (reserved win32:word)
+  (alg-id (:unsigned :int))
+  (key-size win32:dword)
+  (key-data crypt-aes-256-key-data))
+
+(fli:define-foreign-function (crypt-gen-random "CryptGenRandom")
+    ((hprov win32:handle)
+     (data-len win32:dword)
+     (data (:pointer (:unsigned :byte))))
+  :result-type win32:bool
+  :calling-convention :stdcall)
+
+(fli:define-foreign-function (crypt-import-key "CryptImportKey")
+    ((hprov win32:handle)
+     (data (:pointer crypt-aes-256-key))
+     (data-len win32:dword)
+     (pub-key win32:handle)
+     (flags win32:dword)
+     (:ignore (:reference-return win32:handle)))
+  :result-type win32:bool
+  :calling-convention :stdcall)
+
+(fli:define-foreign-function (crypt-set-key-param "CryptSetKeyParam")
+    ((hkey win32:handle)
+     (param win32:dword)
+     (data (:pointer (:unsigned :byte)))
+     (flags win32:dword))
+  :result-type win32:bool
+  :calling-convention :stdcall)
+
+(fli:define-foreign-function (crypt-encrypt "CryptEncrypt")
+    ((hkey win32:handle)
+     (hhash win32:handle)
+     (finalp win32:bool)
+     (flags win32:dword)
+     (data (:pointer (:unsigned :byte)))
+     (data-len (:reference win32:dword))
+     (buf-len win32:dword))
+  :result-type win32:bool
+  :calling-convention :stdcall)
+
+(fli:define-foreign-function (crypt-decrypt "CryptDecrypt")
+    ((hkey win32:handle)
+     (hhash win32:handle)
+     (finalp win32:bool)
+     (flags win32:dword)
+     (data (:pointer (:unsigned :byte)))
+     (data-len (:reference win32:dword)))
+  :result-type win32:bool
+  :calling-convention :stdcall)
+
+(fli:define-foreign-function (crypt-destroy-key "CryptDestroyKey")
+    ((hkey win32:handle))
+  :result-type win32:bool
+  :calling-convention :stdcall)
+
+(defmacro with-aes-winapi-call (vars form cleanup &body body)
+  (with-unique-names (ok-p)
+    `(multiple-value-bind (,ok-p ,@vars) ,form
+       (unless ,ok-p
+         (aes-processing-error
+          "Failed CryptAPI call (~A), Error: ~A" ',(car form)
+          (win32:get-last-error-string)))
+       (unwind-protect (progn ,@body)
+         ,cleanup))))
+
+(defun aes-encode-buffer (buffer size &key key-in iv-in)
+  (with-aes-winapi-call (hprov) 
+      (crypt-acquire-context nil *crypt-aes-provider*
+                             +prov-rsa-aes+
+                             (logior +crypt-verify-context+
+                                     +crypt-silent+))
+      (crypt-release-context hprov 0)
+    (fli:with-dynamic-foreign-objects ((key crypt-aes-256-key)
+                                       (iv crypt-aes-256-iv-data))
+      (setf (fli:foreign-slot-value key 'type) #x8
+            (fli:foreign-slot-value key 'version) 2
+            (fli:foreign-slot-value key 'reserved) 0
+            (fli:foreign-slot-value key 'alg-id) #x00006610
+            (fli:foreign-slot-value key 'key-size) 32)
+      (let ((key-data (fli:foreign-slot-pointer key 'key-data)))
+        (if key-in
+            (loop for i upfrom 0 for val across key-in
+                  do (setf (fli:foreign-aref key-data i) val))
+          (with-aes-winapi-call ()
+              (crypt-gen-random hprov 32 (fli:foreign-array-pointer key-data 0))
+              t)))
+      (if iv-in
+          (loop for i upfrom 0 for val across iv-in
+                do (setf (fli:foreign-aref iv i) val))
+        (with-aes-winapi-call ()
+            (crypt-gen-random hprov 16 (fli:foreign-array-pointer iv 0))
+            t))
+      (with-aes-winapi-call (hkey)
+          (crypt-import-key hprov key (+ 32 4 4 4) 0 0)
+          (crypt-destroy-key hkey)
+        (with-aes-winapi-call ()
+            (crypt-set-key-param hkey 1 (fli:foreign-array-pointer iv 0) 0)
+            t
+          (fli:with-dynamic-lisp-array-pointer (buffer-ptr buffer :type '(:unsigned :byte))
+            (with-aes-winapi-call (enc-len)
+                (crypt-encrypt hkey 0 t 0 buffer-ptr size (length buffer))
+                t
+              (values
+               buffer
+               enc-len
+               (let ((key-out (make-array 32 :element-type '(unsigned-byte 8))))
+                 (fli:replace-foreign-array key-out (fli:foreign-slot-pointer key 'key-data))
+                 key-out)
+               (let ((iv-out (make-array 16 :element-type '(unsigned-byte 8))))
+                 (fli:replace-foreign-array iv-out iv)
+                 iv-out)))))))))
+
+(defun aes-decode-buffer (buffer size key-in iv-in)
+  (with-aes-winapi-call (hprov) 
+      (crypt-acquire-context nil *crypt-aes-provider*
+                             +prov-rsa-aes+
+                             (logior +crypt-verify-context+
+                                     +crypt-silent+))
+      (crypt-release-context hprov 0)
+    (fli:with-dynamic-foreign-objects ((key crypt-aes-256-key)
+                                       (iv crypt-aes-256-iv-data))
+      (setf (fli:foreign-slot-value key 'type) #x8
+            (fli:foreign-slot-value key 'version) 2
+            (fli:foreign-slot-value key 'reserved) 0
+            (fli:foreign-slot-value key 'alg-id) #x00006610
+            (fli:foreign-slot-value key 'key-size) 32)
+      (let ((key-data (fli:foreign-slot-pointer key 'key-data)))
+        (loop for i upfrom 0 for val across key-in
+              do (setf (fli:foreign-aref key-data i) val)))
+      (loop for i upfrom 0 for val across iv-in
+            do (setf (fli:foreign-aref iv i) val))
+      (with-aes-winapi-call (hkey)
+          (crypt-import-key hprov key (+ 32 4 4 4) 0 0)
+          (crypt-destroy-key hkey)
+        (with-aes-winapi-call ()
+            (crypt-set-key-param hkey 1 (fli:foreign-array-pointer iv 0) 0)
+            t
+          (fli:with-dynamic-lisp-array-pointer (buffer-ptr buffer :type '(:unsigned :byte))
+            (with-aes-winapi-call (dec-len)
+                (crypt-decrypt hkey 0 t 0 buffer-ptr size)
+                t
+              (values
+               buffer
+               dec-len))))))))
+
+(defun aes-encode-file (from to &key key-in iv-in)
+  (let ((*aes-processing-pathname* from))
+    (with-open-file (in from :element-type '(unsigned-byte 8))
+      (with-open-file (out to :element-type '(unsigned-byte 8)
+                           :direction :output)
+        (let* ((length (file-length in))
+               (buffer (make-array (* (ceiling (1+ length) 16) 16)
+                                   :element-type '(unsigned-byte 8)
+                                   :allocation :static)))
+          (unless (= length (read-sequence buffer in :end length))
+            (aes-processing-error 
+             "Failed to read ~D bytes from ~A!" length from))
+          (multiple-value-bind (out-buffer out-length key iv)
+              (aes-encode-buffer buffer length 
+                                 :key-in key-in :iv-in iv-in)
+            (write-sequence out-buffer out :end out-length)
+            (values length key iv)))))))
+
+(defun aes-decode-file (from to key-in iv-in)
+  (let ((*aes-processing-pathname* from))
+    (with-open-file (in from :element-type '(unsigned-byte 8))
+      (with-open-file (out to :element-type '(unsigned-byte 8)
+                           :direction :output)
+        (let* ((length (file-length in))
+               (buffer (make-array length
+                                   :element-type '(unsigned-byte 8)
+                                   :allocation :static)))
+          (unless (= length (read-sequence buffer in :end length))
+            (aes-processing-error
+             "Failed to read ~D bytes from ~A!" length from))
+          (multiple-value-bind (out-buffer out-length)
+              (aes-decode-buffer buffer length key-in iv-in) 
+            (write-sequence out-buffer out  :end out-length)
+            out-length))))))

lib/cmdline-utilities.lisp

@@ -0,0 +1,269 @@
+;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; cmdline-utilities.lisp --- Command Line Parsing and Access
+;;;; 
+;;;; $Id$
+
+(cl:in-package #:pmsf-lib)
+
+(pmsf-lib:file-version :pmsf-lib "$Id$")
+
+;;;; %File Description:
+;;;; 
+;;;; This file contains utilities to access the command line and to
+;;;; parse command line arguments for options and proper arguments.
+;;;; 
+
+(defun get-command-line-arguments ()
+  "Return the list of command line arguments passed to this process, including
+the program name as its first argument."
+  #+sbcl
+  (copy-list sb-ext:*posix-argv*)
+  #+lispworks
+  (copy-list system:*line-arguments-list*))
+
+;;;
+;;; Parsing
+;;;
+
+(define-condition command-line-argument-error (simple-error)
+  ((command-line :initarg :command-line 
+                 :reader command-line-argument-error-command-line)
+   (remaining-arguments :initarg :remaining-arguments 
+                        :reader 
+                        command-line-argument-error-remaining-arguments))
+  (:report 
+   (lambda (c s)
+     (with-standard-io-syntax
+       (let ((*print-readably* nil))
+         (format s 
+                 "Error parsing command-line: ~?~%~
+                  For command-line ~{~S~^ ~}, remaining arguments: ~{~S~^ ~}"
+                 (simple-condition-format-control c)
+                 (simple-condition-format-arguments c)
+                 (command-line-argument-error-command-line c)
+                 (command-line-argument-error-remaining-arguments c)))))))
+
+;;;
+;;; Main Entry Point
+;;;
+
+(defun parse-command-line-arguments (command-line 
+                                 &key (required-arguments 0) allowed-arguments
+                                 option-specs)
+  "Parse the command-line given in COMMAND-LINE for the program-name, the
+normal arguments and any options, based on the specifications given through
+REQUIRED-ARGUMENTS, ALLOWED-ARGUMENTS and OPTION-SPECS.  This function will
+signal a COMMAND-LINE-ARGUMENT-ERROR if any of those specifications can't be
+matched.  Returns three values, the name of the program as a string, the list
+of normal arguments after option processing finished, and an alist of options
+and their arguments, as specified by option-spec."
+  (let ((program-name (first command-line))
+        (arguments (rest command-line)))
+    (flet ((is-long-option-p (arg)
+             (when (and (>= (length arg) 2) (string= arg "--" :end1 2))
+               (subseq arg 2)))
+           (find-option-by-name (name)
+             (find name option-specs :key #'first :test #'string=))
+           (is-option-terminator-p (name)
+             (string= name ""))
+           (command-line-argument-error (rest control &rest args)
+             (error 'command-line-argument-error
+                    :command-line command-line
+                    :remaining-arguments rest
+                    :format-control control
+                    :format-arguments args)))
+      ;; Process and collect options
+      (loop with options = nil
+         with rest-arguments = arguments 
+         for arg = (pop rest-arguments)
+         for option-name = (and arg (is-long-option-p arg))
+         for option = (and option-name (find-option-by-name option-name))
+         while (and option-name (not (is-option-terminator-p option-name)))
+         do
+           (unless option
+             (command-line-argument-error 
+              rest-arguments
+              "Unknown option ~A, known options: ~{~A~^, ~}"
+              option-name (mapcar #'first option-specs)))
+           (destructuring-bind (option-matcher option-key option-arguments)
+               option
+             (unless (>= (length rest-arguments) option-arguments)
+               (command-line-argument-error 
+                rest-arguments
+                "Option ~A needs ~D arguments but has only ~D."
+                option-matcher option-arguments (length rest-arguments)))
+             (push (list* option-key
+                          (subseq rest-arguments 0 option-arguments))
+                   options)
+             (setq rest-arguments (nthcdr option-arguments rest-arguments)))
+         finally
+           (when arg
+             (unless (and option-name (is-option-terminator-p option-name))
+               (push arg rest-arguments)))
+           (unless (>= (length rest-arguments) required-arguments)
+             (command-line-argument-error 
+              rest-arguments
+              "~A needs ~D arguments but has only ~D."
+              program-name required-arguments (length rest-arguments)))
+           (unless (or (null allowed-arguments)
+                       (<= (length rest-arguments) allowed-arguments))
+             (command-line-argument-error 
+              rest-arguments
+              "~A needs at most ~D arguments but has ~D."
+              program-name allowed-arguments (length rest-arguments)))
+           (return (values program-name rest-arguments (nreverse options)))))))
+
+;;;
+;;; Parsing for lambda lists
+;;;
+
+(defun make-options-argument-list (options)
+  (loop with result = nil
+     for (option . args) in options
+     do
+       (cond
+         ((null args)
+          (setf (getf result option) t))
+         (t
+          (push args (getf result option nil))))
+     finally
+       (return
+         (loop for (key values) on result by #'cddr
+            collect key
+            collect
+              (cond
+                ((eq values t)
+                 values)
+                ((and (null (cdr values)) (null (cdar values)))
+                 (caar values))
+                ((null (cdr values))
+                 (car values))
+                (t
+                 (mapcar #'(lambda (x) (if (null (cdr x)) (car x) x))
+                         values)))))))
+
+(defun parse-command-line-for-argument-list (command-line &rest args)
+  "Parse the command-line given in COMMAND-LINE in order to construct an
+argument list for invoking another function, based on the specifications
+given through the remaining arguments, which will be passed to the function
+PARSE-COMMAND-LINE-ARGUMENTS for the parsing itself.  This function returns
+an argument list, which will contain a position argument for each normal
+argument to the function, followed by keyword arguments for each option
+present in the command-line.  Duplicate options are merged, options with
+no argument are turned into boolean T keyword arguments, and options with
+only single arguments are unwrapped into single keyword arguments."
+  (multiple-value-bind (prog-name arguments options)
+      (apply #'parse-command-line-arguments command-line args)
+    (declare (ignore prog-name))
+    (append arguments (make-options-argument-list options))))
+
+;;;
+;;; Main Entry Point
+;;;
+
+(defun call-with-parsed-arguments (function command-line &rest args)
+  "Invoke the given function with the arguments and options parsed out of the
+command-line as given by COMMAND-LINE."
+  (apply function 
+         (apply #'parse-command-line-for-argument-list command-line args)))
+
+(defun call-with-parsed-command-line (function &rest args)
+  "Invoke the given function with the arguments and options parsed out of the
+command-line as returned by GET-COMMAND-LINE-ARGUMENTS."
+  (apply function 
+         (apply #'parse-command-line-for-argument-list 
+                (get-command-line-arguments) args)))
+
+(defun parse-argument-lambda-list (lambda-list)
+  (loop with state = :required
+     with program-arg = nil
+     with required-args = nil
+     with optional-args = nil
+     with rest-arg = nil
+     with keyword-args = nil
+     for arg in lambda-list
+     do
+       (if (member arg '(&optional &rest &program &key))
+           (case arg
+             (&optional
+              (unless (eq state :required)
+                (error "Misplaced &OPTIONAL in command-line lambda list: ~S"
+                       lambda-list))
+              (setq state :optional))
+             (&rest
+              (unless (member state '(:required :optional))
+                (error "Misplaced &REST in command-line lambda list: ~S" 
+                       lambda-list))
+              (setq state :rest))
+             (&program
+              (unless (member state '(:required :optional :post-rest))
+                (error "Misplaced &PROGRAM in command-line lambda list: ~S" 
+                       lambda-list))
+              (setq state :program))
+             (&key
+              (unless (member state
+                              '(:required :optional :post-rest :post-program))
+                (error "Misplaced &KEY in command-line lambda list: ~S"
+                       lambda-list))
+              (setq state :key)))
+           (ecase state
+             (:required (push arg required-args))
+             (:optional (push arg optional-args))
+             (:rest (setq rest-arg arg
+                          state :post-rest))
+             (:program (setq program-arg arg
+                             state :post-program))
+             (:key (push arg keyword-args))))
+     finally
+       (when (eq state :rest)
+         (error "Missing &REST argument in command-line lambda list: ~S"
+                lambda-list))
+       (when (eq state :program)
+         (error "Missing &PROGRAM argument in command-line lambda list: ~S"
+                lambda-list))
+       (return
+         (values
+          program-arg
+          (nreverse required-args)
+          (nreverse optional-args)
+          rest-arg
+          (nreverse keyword-args)))))
+
+(defmacro with-parsed-arguments ((&rest lambda-list) command-line &body body)
+  (multiple-value-bind (program-arg required-args optional-args
+                                    rest-arg keyword-args)
+      (parse-argument-lambda-list lambda-list)
+    (let ((required-argcount (length required-args))
+          (allowed-argcount (unless rest-arg
+                              (+ (length required-args)
+                                 (length optional-args))))
+          (real-program-arg (or program-arg (gensym)))
+          (argument-ll (append required-args
+                               (when optional-args
+                                 (cons '&optional optional-args))
+                               (when rest-arg
+                                 (list '&rest rest-arg)))))
+      (multiple-value-bind (option-specs option-ll)
+          (loop for (var name args . default) in keyword-args
+             collect (list name var args) into option-specs
+             collect `((,var ,var) ,(car default)) into option-ll
+             finally
+               (return (values option-specs (list* '&key option-ll))))
+        (pmsf-lib:with-unique-names (arguments options)
+          `(multiple-value-bind (,real-program-arg ,arguments ,options)
+               (parse-command-line-arguments ,command-line 
+                                             :option-specs ',option-specs
+                                             :required-arguments 
+                                             ,required-argcount
+                                             :allowed-arguments
+                                             ,allowed-argcount)
+             (declare (ignorable ,real-program-arg))
+             (destructuring-bind ((,@argument-ll) (,@option-ll))
+                 (list ,arguments (make-options-argument-list ,options))
+               ,@body)))))))
+
+(defmacro with-parsed-command-line ((&rest lambda-list) &body body)
+  `(with-parsed-arguments (,@lambda-list) (get-command-line-arguments)
+     ,@body))

lib/common-utilities.lisp

@@ -0,0 +1,34 @@
+;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; common-utilities.lisp --- Common utilities
+;;;; 
+;;;; $Id$
+
+(cl:in-package #:pmsf-lib)
+
+;;;; %File Description:
+;;;; 
+;;;; This file contains common utilities for all kinds of processing
+;;;; and formatting.
+;;;; 
+
+(defun generate-printed-guid (&optional registry-format-p)
+  "Generate a version 4 (PRNG) UUID and return its printed representation."
+  (let ((state (make-random-state t)))
+    (with-output-to-string (stream)
+      (loop with chars = "0123456789abcdef"
+            for index upfrom 0 below 32
+            for value = (random 16 state)
+            for offset = (cond
+                          ((= index 12) 4)
+                          ((= index 16) (+ 8 (ldb (byte 2 0) value)))
+                          (t value))
+            do
+            (write-char (char chars offset) stream)
+            (when (member index '(7 11 15 20))
+              (write-char #\- stream))
+            initially
+            (when registry-format-p (write-char #\{ stream))
+            finally
+            (when registry-format-p (write-char #\} stream))))))

lib/doc.lisp

@@ -0,0 +1,87 @@
+;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; doc.lisp --- Documentation of file origins and versions
+;;;; 
+;;;; $Id$
+
+(cl:in-package #:pmsf-lib)
+
+;;;; %File Description:
+;;;; 
+;;;; This file provides mechanisms to record the id of files compiled
+;;;; and loaded to create a runtime image.
+;;;; 
+
+(defvar *file-versions* nil
+  "Associaton list of loaded file-ids.")
+
+(defmacro file-version (system id-string)
+  "Register the File-Id `id-string' in the system `system'."
+  ;; On CMUCL we use `ext:file-comment' in addition to our own
+  ;; tracking, so that the File-Id gets embedded in the fasl, and can
+  ;; be seen in descriptions of functions, etc.  See the documentation
+  ;; of `ext:file-comment' for more details.
+  `(progn
+    #+cmucl
+    (ext:file-comment ,id-string)
+    ;; Do compile-time processing by MD5 checksumming the file itself.
+    (process-file-version ',system *load-truename* ',id-string
+                          ',*compile-file-truename* 
+                          ',(md5:md5sum-file *compile-file-truename*))))
+
+(defun process-file-version (system file-name id-string 
+                             source-file-name source-md5)
+  "Load-time part of `file-version'."
+  (let* ((system-list (or (assoc system *file-versions*)
+                          (let ((sys (cons system nil)))
+                            (push sys *file-versions*)
+                            sys)))
+         (file-entry (or (assoc file-name (cdr system-list) :test #'equal)
+                         (let ((entry (cons file-name nil)))
+                           (push entry (cdr system-list))
+                           entry))))
+    (setf (cdr file-entry) 
+          (list id-string (md5:md5sum-file file-name) 
+                source-file-name source-md5))
+    nil))
+
+(defun get-file-versions (system)
+  (let ((system-list (assoc system *file-versions*)))
+    (if system-list
+        (cdr system-list)
+        (error "System ~S not found!" system))))
+
+(defun list-file-versions (system)
+  (loop for (path id) in (get-file-versions system)
+     do
+       (format t "~20A ~A~%" path id)
+     initially
+       (format t "~&~20A ~A~2%" "Path" "Version-Id")))
+
+(defun list-file-checksums (system)
+  (loop for (path nil md5) in (get-file-versions system)
+     do
+       (format t "~40A ~{~2,'0X~}~%" path (coerce md5 'list))
+     initially
+       (format t "~&~40A ~32A~2%" "Path" "MD5")))
+
+(defun list-source-checksums (system)
+  (loop for (nil nil nil source-path source-md5) in (get-file-versions system)
+     do
+       (format t "~40A ~{~2,'0X~}~%" source-path (coerce source-md5 'list))
+     initially
+       (format t "~&~40A ~32A~2%" "Source-Path" "MD5")))
+
+(defun md5-file-versions (system)
+  (md5:md5sum-string
+   (with-output-to-string (stream)
+     (loop for (path id md5) in (sort (copy-list (get-file-versions system))
+                                      #'string< :key 
+                                      (lambda (x) 
+                                        (if (pathnamep (car x))
+                                            (namestring (car x))
+                                            (car x))))
+        do
+          (format stream "~A!~A!~{~2,'0X~}~%" path id (coerce md5 'list))))
+   :external-format :utf-8))

lib/float-utilities.lisp

@@ -0,0 +1,318 @@
+;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; float-utilities.lisp --- Floating Point Utilities
+;;;; 
+;;;; $Id$
+
+(cl:in-package #:pmsf-lib)
+
+(pmsf-lib:file-version :pmsf-lib "$Id$")
+
+;;;; %File Description:
+;;;; 
+;;;; This file contains utilities for handling floating point
+;;;; numbers and their processing.
+;;;; 
+
+;;;
+;;; Prevent compilation errors in this file due to FPU issues
+;;;
+
+#+SBCL
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (sb-int:set-floating-point-modes :traps nil :rounding-mode :nearest
+				   :fast-mode nil
+				   #+X86 :precision #+X86 :53-bit))
+
+(defconstant single-float-positive-infinity
+  #+sbcl
+  sb-ext:single-float-positive-infinity
+  #-sbcl
+  (+ most-positive-single-float most-positive-single-float)
+  "Single Float Positivie Infinity")
+
+(defconstant single-float-negative-infinity
+  #+sbcl
+  sb-ext:single-float-negative-infinity
+  #-sbcl
+  (- (+ most-positive-single-float most-positive-single-float))
+  "Single Float Negative Infinity")
+
+(defconstant single-float-nan
+  ;; Ensure positive NaN
+  (float-sign 1.0f0 
+	      (/ single-float-negative-infinity single-float-negative-infinity))
+  "Single Float NaN")
+
+(defconstant double-float-positive-infinity
+  #+sbcl
+  sb-ext:double-float-positive-infinity
+  #-sbcl
+  (+ most-positive-double-float most-positive-double-float)
+  "Double Float Positive Infinity")
+
+(defconstant double-float-negative-infinity
+  #+sbcl
+  sb-ext:double-float-negative-infinity
+  #-sbcl
+  (- (+ most-positive-double-float most-positive-double-float))
+  "Double Float Negative Infinity")
+
+(defconstant double-float-nan
+  ;; Ensure positive NaN
+  (float-sign 1.0d0
+	      (/ double-float-negative-infinity double-float-negative-infinity))
+  "Double Float NaN")
+
+(defun float-infinity-p (float)
+  (and 
+   (floatp float)
+   #+sbcl
+   (sb-ext:float-infinity-p float)
+   #-sbcl
+   (etypecase float
+     (double-float (or (= float double-float-positive-infinity)
+		       (= float double-float-negative-infinity)))
+     (single-float (or (= float single-float-positive-infinity)
+		       (= float single-float-negative-infinity))))))
+
+(defun float-nan-p (float)
+  (and 
+   (floatp float)
+   #+sbcl
+   (sb-ext:float-nan-p float)
+   #+lispworks
+   (system::nan-p float)
+   #-(or sbcl lispworks)
+   (not (= float float))))
+
+(defun float-denormalized-p (float)
+  (and 
+   (floatp float)
+   #+sbcl
+   (sb-ext:float-denormalized-p float)
+   #-sbcl
+   (and (not (float-nan-p float))
+	(not (float-infinity-p float))
+	(not (zerop float))
+	(< (float-precision float) (float-digits float)))))
+
+;;;
+;;; Floating-Point Compare
+;;;
+
+(defun bit-decode-float (a)
+  "Decode the floating point number A into three numbers MANTISSA, EXPONENT
+and SIGN, so that A = SIGN * MANTISSA * 2^EXPONENT, and the returned MANTISSA
+is an integer that is bit-identical to the mantissa field of the floating
+point number in IEEE 754 with the hidden MSB included."
+  (multiple-value-bind (mantissa exp sign) (decode-float a)
+    (values (truncate (* mantissa (expt 2 (float-digits a))))
+	    (- exp (float-digits a))
+	    sign)))
+
+(defun ieee-decode-float (a)
+  "Decode the floating point number A into three numbers MANTISSA, EXPONENT
+and SIGN, so that A = SIGN * MANTISSA * 2^EXPONENT, and the returned MANTISSA
+is a floating point number with 1 <= MANTISSA < 2, thus matching the IEEE 754
+definition of the mantissa."
+  (multiple-value-bind (mantissa exp sign) (decode-float a)
+    (values (* mantissa 2)
+	    (1- exp)
+	    sign)))
+
+(defun float-equal (a b &key epsilon-bits)
+  "Compare to floating point numbers A and B on equality, treating two NaNs
+as equal as well.  If EPSILON-BITS is supplied it is the number of least
+significant bits that the two mantissas are allowed to differ to still be
+treated as equal for the purposes of the comparison."
+  (unless (or (null epsilon-bits)
+	      (<= 0 epsilon-bits (float-digits a)))
+    (error "Illegal value ~S for epsilon-bits in call to float-equal."
+	   epsilon-bits))
+  (or
+   ;; NaNs
+   (and (float-nan-p a) (float-nan-p b))
+   ;; Identical
+   (eql a b)
+   ;; Identical modulo epsilon bits differences
+   (when epsilon-bits
+     (unless (or (float-infinity-p a) (float-infinity-p b))
+       (multiple-value-bind (mant-a exp-a sign-a) (bit-decode-float a)
+	 (multiple-value-bind (mant-b exp-b sign-b) (bit-decode-float b)
+	   (and (= exp-a exp-b)
+		(= sign-a sign-b)
+		(< (abs (- mant-a mant-b)) (expt 2 epsilon-bits)))))))))
+
+;;;
+;;; Floating-Point I/O
+;;;
+
+(defun read-double-float-from-string (string)
+  (cond
+    ((string-equal string "NaN")
+     double-float-nan)
+    ((or (string-equal string "+Inf")
+	 (string-equal string "Inf"))
+     double-float-positive-infinity)
+    ((string-equal string "-Inf")
+     double-float-negative-infinity)
+    ((cl-ppcre:scan "^[-+]?([0-9]+)?[.]?(?(1)[0-9]*|[0-9]+)([eE][-+]?[0-9]+)?$"
+		    string)
+     (let ((*read-default-float-format* 'double-float)
+	   (*read-eval* nil))
+       #+lispworks
+       (hcl:parse-float string)
+       #-lispworks
+       (coerce
+        (read-from-string string)
+	'double-float)))
+    (t
+     (error "Value ~S is not a valid floating point number." string))))
+
+(defun read-single-float-from-string (string)
+  (cond
+    ((string-equal string "NaN")
+     single-float-nan)
+    ((or (string-equal string "+Inf")
+	 (string-equal string "Inf"))
+     single-float-positive-infinity)
+    ((string-equal string "-Inf")
+     single-float-negative-infinity)
+    ((cl-ppcre:scan "^[-+]?([0-9]+)?[.]?(?(1)[0-9]*|[0-9]+)([eE][-+]?[0-9]+)?$"
+		    string)
+     (let ((*read-default-float-format* 'single-float)
+	   (*read-eval* nil))
+       #+lispworks
+       (hcl:parse-float string)
+       #-lispworks
+       (coerce
+	(read-from-string string)
+	'single-float)))
+    (t
+     (error "Value ~S is not a valid floating point number." string))))
+
+(defun write-float (x stream)
+  (cond
+    ((float-infinity-p x)
+     (if (< x (float 0 x))
+	 (write-string "-INF" stream)
+	 (write-string "INF" stream)))
+    ((float-nan-p x)
+     (write-string "NaN" stream))
+    (t
+     (with-standard-io-syntax
+       (let ((*read-default-float-format* (if (typep x 'double-float)
+					      'double-float
+					      'single-float)))
+	 (write x :stream stream))))))
+
+(defun float-integer-value (a)
+  "Decode the floating point number A so as to produce the corresponding IEEE-754
+bit pattern as an integer value."
+  (let ((mantissa-bits (1- (float-digits a)))
+        (exponent-bits (etypecase a (double-float 11) (single-float 8))))
+    (multiple-value-bind (mantissa exponent sign)
+        (cond
+         ;; NaNs
+         ((float-nan-p a)
+          (values (1- (expt 2 mantissa-bits))
+                  (1- (expt 2 exponent-bits))
+                  0))
+         ;; Infinities
+         ((float-infinity-p a)
+          (values 0
+                  (1- (expt 2 exponent-bits))
+                  (if (minusp (float-sign a)) 1 0)))
+         ;; Zero is special as well
+         ((zerop a)
+          (values 0
+                  0
+                  (if (minusp (float-sign a)) 1 0)))
+         ;; Normals and Denormals
+         (t
+          (multiple-value-bind (mantissa exp sign) (ieee-decode-float a)
+            (if (not (plusp (+ exp (1- (expt 2 (1- exponent-bits))))))
+                ;; Denormals
+                (values (ldb (byte mantissa-bits 0) 
+                             (truncate 
+			      (* mantissa
+				 (expt 2 
+				       (+ mantissa-bits (1- exp)
+					  (1- (expt 2 (1- exponent-bits))))))))
+                        0
+                        (if (minusp sign) 1 0))
+                ;; Normals
+                (values (ldb (byte mantissa-bits 0) 
+                             (truncate (* mantissa (expt 2 mantissa-bits))))
+                        (+ exp (1- (expt 2 (1- exponent-bits))))
+                        (if (minusp sign) 1 0))))))
+      ;; Construct result
+      (dpb sign (byte 1 (+ mantissa-bits exponent-bits))
+           (dpb exponent (byte exponent-bits mantissa-bits)
+                mantissa)))))
+
+(defun write-hex (x width stream &optional hide-prefix)
+  (format stream "~:[0x~;~]~v,'0X"
+          hide-prefix
+          (ceiling width 4)
+          (if (floatp x)
+              (float-integer-value x)
+              (ldb (byte width 0) x))))
+
+(defun pprint-float (stream object &optional colon-p at-sign-p width)
+  (if (and at-sign-p width)
+      (write-hex object width stream colon-p)
+      (write-float object stream)))
+
+(defun integer-float-value (a type)
+  "Encode an integer A that is constructed according to the IEEE-754 format
+description into a floating point number of the given common lisp type."
+  (let ((mantissa-bits (ecase type (double-float 52) (single-float 23)))
+        (exponent-bits (ecase type (double-float 11) (single-float 8))))
+    (multiple-value-bind (mantissa exponent sign)
+        (values (ldb (byte mantissa-bits 0) a)
+                (ldb (byte exponent-bits mantissa-bits) a)
+                (ldb (byte 1 (+ exponent-bits mantissa-bits)) a))
+      (cond
+       ;; NaNs
+       ((and (= exponent (1- (expt 2 exponent-bits))) (/= mantissa 0))
+        (ecase type
+          (double-float double-float-nan)
+          (single-float single-float-nan)))
+       ;; Infinities
+       ((= exponent (1- (expt 2 exponent-bits)))
+        (if (= sign 1)
+            (ecase type
+              (double-float double-float-negative-infinity)
+              (single-float single-float-negative-infinity))
+            (ecase type
+              (double-float double-float-positive-infinity)
+              (single-float single-float-positive-infinity))))
+       ;; Zero is special as well
+       ((and (zerop exponent) (zerop mantissa))
+        (if (= sign 1)
+            (ecase type
+              (double-float -0.0d0)
+              (single-float -0.0f0))
+            (ecase type
+              (double-float 0.0d0)
+              (single-float 0.0f0))))
+       ;; Denormals
+       ((zerop exponent)
+        (float-sign
+         (coerce (if (= sign 1) -1 1) type)
+         (scale-float (coerce mantissa type)
+                      (- (+ (1- (expt 2 (1- exponent-bits))) (1- mantissa-bits))))))
+       ;; Normals
+       (t
+        (float-sign
+         (coerce (if (= sign 1) -1 1) type)
+         (scale-float (coerce (dpb 1 (byte 1 mantissa-bits) mantissa) type)
+                      (- exponent (1- (expt 2 (1- exponent-bits))) mantissa-bits))))))))
+
+(defun signed-integer-value (integer width)
+  (if (= 1 (ldb (byte 1 (1- width)) integer))
+      (- integer (expt 2 width))
+      integer))

lib/macro-utilities.lisp

@@ -0,0 +1,118 @@
+;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; macro-utilities.lisp --- Common utilities in macro writing
+;;;; 
+;;;; $Id$
+
+(cl:in-package #:pmsf-lib)
+
+;;;; %File Description:
+;;;; 
+;;;; This file contains a number of utility functions and macros which
+;;;; are useful in writing macros.
+;;;; 
+
+(defmacro with-unique-names ((&rest bindings) &body body)
+  "Executes a series of forms with each var bound to a fresh, uninterned
+symbol.  The uninterned symbol is created as if by a call to gensym with
+the string denoted by prefix -- or, if prefix is not supplied, the string
+denoted by var -- as argument.
+The variable bindings created are lexical unless special declarations are
+specified.
+The forms are evaluated in order, and the values of all but the last are
+discarded (that is, the body is an implicit progn)."
+  `(let ,(mapcar #'(lambda (binding)
+                     (destructuring-bind (var prefix)
+                         (if (consp binding) binding (list binding binding))
+                       `(,var (gensym ,(string prefix)))))
+                 bindings)
+     ,@body))
+
+(defmacro rebinding (bindings &body body)
+  "Bind each var in bindings to a gensym, bind the gensym to
+var's value via a let, return body's value wrapped in this let.
+Evaluates a series of forms in the lexical environment that is
+formed by adding the binding of each var to a fresh, uninterned
+symbol, and the binding of that fresh, uninterned symbol to var's
+original value, i.e., its value in the current lexical
+environment.
+The uninterned symbol is created as if by a call to gensym with the
+string denoted by prefix -- or, if prefix is not supplied, the string
+denoted by var -- as argument.
+The forms are evaluated in order, and the values of all but the last
+are discarded (that is, the body is an implicit progn)."
+  (loop for binding in bindings
+        for var = (car (if (consp binding) binding (list binding)))
+        for name = (gensym)
+        collect `(,name ,var) into renames
+        collect ``(,,var ,,name) into temps
+        finally (return `(let* ,renames
+                           (with-unique-names ,bindings
+                             `(let (,,@temps)
+                                ,,@body))))))
+
+(defun symbolicate (&rest pieces)
+  (intern
+   (apply #'concatenate 'string 
+            (loop for thing in pieces
+               collect (if (symbolp thing)
+                           (symbol-name thing)
+                           thing)))))
+
+(defun symbolicate* (package &rest pieces)
+  (intern
+   (apply #'concatenate 'string 
+            (loop for thing in pieces
+               collect (if (symbolp thing)
+                           (symbol-name thing)
+                           thing)))
+   package))
+
+;;; Parse-Body
+;;;
+;;;    Parse out declarations and doc strings, *not* expanding macros.
+;;;
+;;; Taken from CMU CL, which is in the public domain
+;;;
+(defun parse-body (body &optional (doc-string-allowed t))
+  "This function is to parse the declarations and doc-string out of the body of
+  a defun-like form.  Body is the list of stuff which is to be parsed.
+  Environment is ignored.  If Doc-String-Allowed is true, then a doc string
+  will be parsed out of the body and returned.  If it is false then a string
+  will terminate the search for declarations.  Three values are returned: the
+  tail of Body after the declarations and doc strings, a list of declare forms,
+  and the doc-string, or NIL if none."
+  (let ((decls ())
+        (doc nil))
+    (do ((tail body (cdr tail)))
+        ((endp tail)
+         (values tail (nreverse decls) doc))
+      (let ((form (car tail)))
+        (cond ((and (stringp form) (cdr tail))
+               (if doc-string-allowed
+                   (setq doc form
+                         ;; Only one doc string is allowed.
+                         doc-string-allowed nil)
+                   (return (values tail (nreverse decls) doc))))
+              ((not (and (consp form) (symbolp (car form))))
+               (return (values tail (nreverse decls) doc)))
+              ((eq (car form) 'declare)
+               (push form decls))
+              (t
+               (return (values tail (nreverse decls) doc))))))))
+
+;;; Required-Argument
+;;;
+;;; Taken from CMU CL, which is in the public domain
+;;;
+(declaim (ftype (function () nil) required-argument))
+(defun required-argument ()
+  "This function can be used as the default value for keyword arguments that
+  must be always be supplied.  Since it is known by the compiler to never
+  return, it will avoid any compile-time type warnings that would result from a
+  default value inconsistent with the declared type.  When this function is
+  called, it signals an error indicating that a required keyword argument was
+  not supplied.  This function is also useful for DEFSTRUCT slot defaults
+  corresponding to required arguments."
+  (error "A required keyword argument was not supplied."))

lib/parsing-utilities.lisp

@@ -0,0 +1,161 @@
+;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; parsing-utilities.lisp --- Parser writing support machinery
+;;;; 
+;;;; $Id$
+
+(cl:in-package #:pmsf-lib)
+
+;;;; %File Description:
+;;;; 
+;;;; This file contains various utility functions and macros for use
+;;;; when writing lexers and parsers.
+;;;; 
+
+;;;
+;;; Lexer Facility
+;;;
+
+(define-condition lexer-error (simple-error)
+  ((lexer :initarg :lexer :reader lexer-error-lexer)
+   (string :initarg :string :reader lexer-error-string)
+   (position :initarg :position :reader lexer-error-position))
+  (:report (lambda (c s)
+             (format s "Lexer ~A:~D:~S: ~?"
+                     (lexer-error-lexer c)
+                     (lexer-error-position c)
+                     (lexer-error-string c)
+                     (simple-condition-format-control c)
+                     (simple-condition-format-arguments c)))))
+
+(defmacro define-lexer (name (&rest options) &rest clauses)
+  (with-unique-names (string start end)
+    `(defun ,name (,string &key ((:start ,start) 0) ((:end ,end)))
+       (let ((,end (or ,end (length ,string))))
+         (lambda ()
+           ,(generate-lexer-body name string start end clauses options))))))
+
+(defmacro with-lexer ((name (&rest options) &rest clauses) string &body body)
+  (with-unique-names (string-var start end)
+    `(let* ((,string-var ,string) (,start 0) (,end (length ,string-var)))
+       (flet ((,name () 
+                ,(generate-lexer-body name string-var start end
+                                      clauses options)))
+         ,@body))))
+
+(defun generate-lexer-body (name string start end clauses options)
+  (destructuring-bind (&key (regex-code-limit cl-ppcre:*regex-char-code-limit*)
+                            (use-bmh-matchers cl-ppcre:*use-bmh-matchers*))
+      options
+    (with-unique-names (match-start match-end reg-starts reg-ends)
+      `(do ()
+           ((>= ,start ,end) nil)
+         ,@(loop for (pattern varlist . body) in clauses
+              for real-pattern = `(:sequence :start-anchor
+                                             ,(if (stringp pattern)
+                                                  `(:regex ,pattern)
+                                                  pattern))
+              collect
+                `(multiple-value-bind (,match-start 
+                                       ,match-end
+                                       ,reg-starts ,reg-ends)
+                     (cl-ppcre:scan 
+                      (load-time-value 
+                       (let ((cl-ppcre:*regex-char-code-limit* 
+                              ,regex-code-limit)
+                             (cl-ppcre:*use-bmh-matchers* ,use-bmh-matchers))
+                         (cl-ppcre:create-scanner ',real-pattern)))
+                      ,string 
+                      :start ,start :end ,end)
+                   (declare (ignorable ,match-end ,reg-starts ,reg-ends))
+                   (when (and ,match-start (= ,match-start ,start))
+                     (flet ((succeed (id &optional (value id))
+                              (setq ,start ,match-end)
+                              (return (values id value)))
+                            (skip ()
+                              (setq ,start ,match-end)
+                              (go restart))
+                            (fail (&optional (reason "No match!")
+                                             &rest args)
+                              (error 'lexer-error 
+                                     :lexer ',name
+                                     :position ,start
+                                     :string ,string
+                                     :format-control reason
+                                     :format-arguments args)))
+                       (declare (ignorable #'succeed #'skip #'fail))
+                       (let ,(loop for var in varlist
+                                for index upfrom 0
+                                collect
+                                  `(,var 
+                                    (when (aref ,reg-starts ,index)
+                                      (subseq ,string 
+                                              (aref ,reg-starts ,index)
+                                              (aref ,reg-ends ,index)))))
+                         ,@body)))))
+         (error 'lexer-error
+                :lexer ',name
+                :position ,start
+                :string ,string
+                :format-control "No match!"
+                :format-arguments nil)
+        restart))))
+
+;;;
+;;; Parsing Helpers
+;;;
+
+(defun infix-to-prefix (a b c) (list b a c))
+
+;;;
+;;; Regexp replacement helpers
+;;;
+
+(defun generate-replacement-template (replacement)
+  (let ((result nil))
+    (dolist (token (cl-ppcre::build-replacement-template replacement)
+                   (nreverse result))
+      (let ((actual (if (eq token :backslash) "\\" token)))
+        (if (and (stringp actual) (first result) (stringp (first result)))
+            (push (concatenate 'string (pop result) actual) result)
+          (push actual result))))))
+
+(defun derive-new-pattern (target-string match-start match-end reg-starts reg-ends replacement-template)
+  (loop with reg-bound = (if reg-starts (array-dimension reg-starts 0) 0)
+        for token in replacement-template
+        collect
+        (typecase token
+          (string token)
+          (integer
+           ;; replace numbers with the corresponding registers
+           (when (>= token reg-bound)
+             ;; but only if the register was referenced in the
+             ;; regular expression
+             (cl-ppcre::signal-invocation-error
+              "Reference to non-existent register ~A in replacement string."
+              (1+ token)))
+           (when (svref reg-starts token)
+             ;; and only if it matched, i.e. no match results
+             ;; in an empty string
+             (cl-ppcre:quote-meta-chars 
+              (subseq target-string
+                      (svref reg-starts token)
+                      (svref reg-ends token)))))
+          (symbol
+           (case token
+             ((:match)
+              ;; the whole match
+              (cl-ppcre:quote-meta-chars 
+               (subseq target-string match-start match-end)))
+             ((:before-match)
+              ;; the part of the target string before the match
+              (cl-ppcre:quote-meta-chars 
+               (subseq target-string 0 match-start)))
+             ((:after-match)
+              ;; the part of the target string after the match
+              (cl-ppcre:quote-meta-chars 
+               (subseq target-string match-end))))))
+        into result
+        finally (return (reduce (lambda (x y) (concatenate 'string x y)) result
+                                :initial-value ""))))

lib/pecoff-utilities.lisp

@@ -0,0 +1,571 @@
+;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; pecoff-utilities.lisp --- Utilities concerned with PE/COFF
+;;;; 
+;;;; $Id$
+
+(cl:in-package #:pmsf-pecoff)
+
+(pmsf-lib:file-version :pmsf-lib "$Id$")
+
+;;;; %File Description:
+;;;; 
+;;;; This file contains utilities for PE/COFF file handling
+;;;; 
+
+(defvar *pecoff-processing-pathname* nil)
+
+(define-condition pecoff-processing-error (simple-error)
+  ((pathname :initarg :pathname :initform *pecoff-processing-pathname*
+             :reader pecoff-processing-error-pathname))
+  (:report 
+   (lambda (c s)
+     (with-standard-io-syntax
+       (let ((*print-readably* nil))
+         (format s 
+                 "Error processing PE/COFF file~@[ for ~A~]: ~?"
+                 (pecoff-processing-error-pathname c)
+                 (simple-condition-format-control c)
+                 (simple-condition-format-arguments c)))))))
+
+(defun pecoff-processing-error (datum &rest arguments)
+  (error 'pecoff-processing-error :format-control datum
+         :format-arguments arguments))
+
+;;;
+;;; PE/COFF Structures
+;;;
+
+(defclass file ()
+  ((mz-stub :initarg :mz-stub :accessor file-mz-stub)
+   (signature :initarg :signature :accessor file-signature)
+   (header :initarg :header :accessor file-header)
+   (optional-header :initarg :optional-header 
+                    :accessor file-optional-header)
+   (sections :initarg :sections :accessor file-sections)
+   (raw-data :initarg :raw-data :accessor file-raw-data)))
+
+(defclass mz-stub ()
+  ((raw-magic :initarg :raw-magic :accessor mz-stub-raw-magic)
+   (pecoff-offset :initarg :pecoff-offset
+                  :accessor mz-stub-pecoff-offset)
+   (raw-data :initarg :raw-data :accessor mz-stub-raw-data)))
+
+(defconstant +header-machine-type-i386+ #x14c)
+(defconstant +header-machine-type-amd64+ #x8664)
+(defconstant +header-machine-type-arm+ #x1c0)
+(defconstant +header-machine-type-thumb+ #x1c2)
+(defconstant +header-machine-type-armnt+ #x1c4)
+(defconstant +header-machine-type-arm64+ #xaa64)
+
+(defclass header ()
+  ((machine-type :initarg :machine-type
+                 :accessor header-machine-type)
+   (number-of-sections :initarg :number-of-sections
+                       :accessor header-number-of-sections)
+   (time-date-stamp :initarg :time-date-stamp
+                    :accessor header-time-date-stamp)
+   (offset-to-symbol-table :initarg :offset-to-symbol-table
+                           :accessor header-offset-to-symbol-table)
+   (number-of-symbols :initarg :number-of-symbols
+                      :accessor header-number-of-symbols)
+   (size-of-optional-header :initarg :size-of-optional-header 
+                            :accessor header-size-of-optional-header)
+   (characteristics :initarg :characteristics 
+                    :accessor header-characteristics)))
+
+(defclass optional-header ()
+  ((linker-major-version :initarg :linker-major-version
+                         :accessor optional-header-linker-major-version)
+   (linker-minor-version :initarg :linker-minor-version
+                         :accessor optional-header-linker-minor-version)
+   (size-of-code :initarg :size-of-code
+                 :accessor optional-header-size-of-code)
+   (size-of-initialized-data :initarg :size-of-initialized-data
+                             :accessor optional-header-size-of-initialized-data)
+   (size-of-uninitialized-data :initarg :size-of-uninitialized-data
+                               :accessor optional-header-size-of-uninitialized-data)
+   (address-of-entry-point :initarg :address-of-entry-point
+                           :accessor optional-header-address-of-entry-point)
+   (base-of-code :initarg :base-of-code
+                 :accessor optional-header-base-of-code)
+   ;; Windows-specific part
+   (image-base :initarg :image-base 
+               :accessor optional-header-image-base)
+   (section-alignment :initarg :section-alignment
+                      :accessor optional-header-section-alignment)
+   (file-alignment :initarg :file-alignment
+                   :accessor optional-header-file-alignment)
+   (major-os-version :initarg :major-os-version
+                     :accessor optional-header-major-os-version)
+   (minor-os-version :initarg :minor-os-version
+                     :accessor optional-header-minor-os-version)
+   (major-image-version :initarg :major-image-version
+                        :accessor optional-header-major-image-version)
+   (minor-image-version :initarg :minor-image-version
+                        :accessor optional-header-minor-image-version)
+   (major-subsystem-version :initarg :major-subsystem-version
+                            :accessor optional-header-major-subsystem-version)
+   (minor-subsystem-version :initarg :minor-subsystem-version
+                            :accessor optional-header-minor-subsystem-version)
+   (win32-version-value :initarg :win32-version-value
+                        :accessor optional-header-win32-version-value)
+   (size-of-image :initarg :size-of-image
+                  :accessor optional-header-size-of-image)
+   (size-of-headers :initarg :size-of-headers
+                    :accessor optional-header-size-of-headers)
+   (checksum :initarg :checksum
+             :accessor optional-header-checksum)
+   (subsystem :initarg :subsystem
+              :accessor optional-header-subsystem)
+   (dll-characteristics :initarg :dll-characteristics
+                        :accessor optional-header-dll-characteristics)
+   (size-of-stack-reserve :initarg :size-of-stack-reserve
+                          :accessor optional-header-size-of-stack-reserve)
+   (size-of-stack-commit :initarg :size-of-stack-commit
+                         :accessor optional-header-size-of-stack-commit)
+   (size-of-heap-reserve :initarg :size-of-heap-reserve
+                         :accessor optional-header-size-of-heap-reserve)
+   (size-of-heap-commit :initarg :size-of-heap-commit
+                        :accessor optional-header-size-of-heap-commit)
+   (loader-flags :initarg :loader-flags
+                 :accessor optional-header-loader-flags)
+   (number-of-rva-and-sizes :initarg :number-of-rva-and-sizes
+                            :accessor optional-header-number-of-rva-and-sizes)
+   (data-directories :initarg :data-directories
+                     :accessor optional-header-data-directories)))
+
+(defclass data-directory ()
+  ((virtual-address :initarg :virtual-address
+                    :accessor data-directory-virtual-address)
+   (size :initarg :size :accessor data-directory-size)))
+
+(defclass optional-header-pe32 (optional-header)
+  ((base-of-data :initarg :base-of-data
+                 :accessor optional-header-base-of-data)))
+
+(defclass optional-header-pe32+ (optional-header)
+  ())
+
+(defclass section ()
+  ((name :initarg :name :accessor section-name)
+   (virtual-size :initarg :virtual-size :accessor section-virtual-size)
+   (virtual-address :initarg :virtual-address :accessor section-virtual-address)
+   (size-of-raw-data :initarg :size-of-raw-data :accessor section-size-of-raw-data)
+   (pointer-to-raw-data :initarg :pointer-to-raw-data :accessor section-pointer-to-raw-data)
+   (pointer-to-relocations :initarg :pointer-to-relocations :accessor section-pointer-to-relocations)
+   (pointer-to-line-numbers :initarg :pointer-to-line-numbers :accessor section-pointer-to-line-numbers)
+   (number-of-relocations :initarg :number-of-relocations :accessor section-number-of-relocations)
+   (number-of-line-numbers :initarg :number-of-line-numbers :accessor section-number-of-line-numbers)
+   (characteristics :initarg :characteristics :accessor section-characteristics)
+   (raw-data :initarg :raw-data :accessor section-raw-data)))
+
+(defclass export-directory ()
+  ((export-flags :initarg :export-flags 
+                 :accessor export-directory-export-flags)
+   (time-date-stamp :initarg :time-date-stamp
+                    :accessor export-directory-time-date-stamp)
+   (major-version :initarg :major-version
+                  :accessor export-directory-major-version)
+   (minor-version :initarg :minor-version
+                  :accessor export-directory-minor-version)
+   (name-rva :initarg :name-rva
+             :accessor export-directory-name-rva)
+   (name :initarg :name
+         :accessor export-directory-name)
+   (ordinal-base :initarg :ordinal-base
+                 :accessor export-directory-ordinal-name)
+   (address-table-entries :initarg :address-table-entries
+                          :accessor export-directory-address-table-entries)
+   (name-table-entries :initarg :name-table-entries
+                       :accessor export-directory-name-table-entries)
+   (address-table-rva :initarg :address-table-rva
+                      :accessor export-directory-address-table-rva)
+   (name-table-rva :initarg :name-table-rva
+                   :accessor export-directory-name-table-rva)
+   (ordinal-table-rva :initarg :ordinal-table-rva
+                      :accessor export-directory-ordinal-table-rva)
+   (address-table :initarg :address-table
+                  :accessor export-directory-address-table)
+   (name-table :initarg :name-table
+                  :accessor export-directory-name-table)
+   (ordinal-table :initarg :ordinal-table
+                  :accessor export-directory-ordinal-table)
+   (raw-data :initarg :raw-data
+             :accessor export-directory-raw-data)))
+
+;;;
+;;; Utility Accessors
+;;;
+
+(defun get-string-from-rva (file address)
+  (loop for section across (file-sections file)
+        for start = (section-virtual-address section)
+        for stop = (1- (+ start (section-virtual-size section)))
+        for raw-size = (section-size-of-raw-data section)
+        for raw-data = (section-raw-data section)
+        thereis
+        (when (and (<= start address stop)
+                   (<= (- address start) raw-size))
+          (let ((end (position 0 raw-data :start (- address start))))
+            (make-array (list (1+ (- end (- address start))))
+                        :element-type '(unsigned-byte 8)
+                        :displaced-to raw-data
+                        :displaced-index-offset (- address start))))))
+
+(defun access-data-directory-contents (file index)
+  (let* ((opt-header (file-optional-header file))
+         (entry (aref (optional-header-data-directories opt-header)
+                      index)))
+    (loop with address = (data-directory-virtual-address entry)
+          with size = (data-directory-size entry)
+          for section across (file-sections file)
+          for start = (section-virtual-address section)
+          for stop = (1- (+ start (section-virtual-size section)))
+          for raw-size = (section-size-of-raw-data section)
+          for raw-data = (section-raw-data section)
+          thereis
+          (when (and (<= start address stop)
+                     (<= start (1- (+ address size)) stop)
+                     (<= (- address start) raw-size))
+            (make-array (list size)
+                        :element-type '(unsigned-byte 8)
+                        :displaced-to raw-data
+                        :displaced-index-offset (- address start))))))
+
+;;;
+;;; Basic COFF I/O
+;;;
+
+(defvar *current-source*)
+(defvar *current-offset*)
+(defvar *current-kind*)
+
+(defmacro with-pecoff-reading (source &body body)
+  `(let ((*current-source* ,source)
+         (*current-offset* 0))
+     ,@body))
+
+(defmacro with-pecoff-reading-kind (kind &body body)
+  `(let ((*current-kind* ,kind))
+     ,@body))
+
+(defun read-coff-byte (&optional offset)
+  (when offset (setq *current-offset* offset))
+  (prog1 (aref *current-source* *current-offset*)
+    (incf *current-offset*)))
+
+(defun read-coff-half (&optional offset)
+  (let ((lsb (read-coff-byte offset)))
+    (dpb (read-coff-byte) (byte 8 8) lsb)))
+
+(defun read-coff-word (&optional offset)
+  (let* ((lsb (read-coff-byte offset))
+         (lsb2 (read-coff-byte))
+         (lsb3 (read-coff-byte))
+         (msb (read-coff-byte)))
+    (dpb msb (byte 8 24) (dpb lsb3 (byte 8 16) (dpb lsb2 (byte 8 8) lsb)))))
+
+(defun read-coff-xword (&optional offset)
+  (let* ((lsb (read-coff-byte offset))
+         (lsb2 (read-coff-byte))
+         (lsb3 (read-coff-byte))
+         (lsb4 (read-coff-byte))
+         (lsb5 (read-coff-byte))
+         (lsb6 (read-coff-byte))
+         (lsb7 (read-coff-byte))
+         (msb (read-coff-byte)))
+    (dpb msb (byte 8 56) 
+         (dpb lsb7 (byte 8 48) 
+              (dpb lsb6 (byte 8 40) 
+                   (dpb lsb5 (byte 8 32)
+                        (dpb lsb4 (byte 8 24)
+                             (dpb lsb3 (byte 8 16)
+                                  (dpb lsb2 (byte 8 8) lsb)))))))))
+
+(defun read-coff-word/xword (&optional offset)
+  (ecase *current-kind*
+    (:pe32 (read-coff-word offset))
+    (:pe32+ (read-coff-xword offset))))
+
+(defun read-coff-sequence (length &optional offset)
+  (when offset (setq *current-offset* offset))
+  (let ((result (make-array (list length) :element-type '(unsigned-byte 8)
+			    :displaced-to *current-source*
+			    :displaced-index-offset *current-offset*)))
+    (incf *current-offset* length)
+    result))
+
+;;;
+;;; Header Handling and Reading
+;;;
+
+(defun check-pecoff-file-p ()
+  (and
+   ;; MZ Stub
+   (eql (read-coff-byte 0) (char-code #\M))
+   (eql (read-coff-byte) (char-code #\Z))
+   (let ((pe-offset (read-coff-word #x3c)))
+     (and 
+      (eql (read-coff-byte pe-offset) (char-code #\P))
+      (eql (read-coff-byte) (char-code #\E))
+      (eql (read-coff-byte) 0)
+      (eql (read-coff-byte) 0)))))
+
+(defun read-mz-stub ()
+  (let ((identifier (read-coff-sequence 2 0))
+        (pecoff-offset (read-coff-word #x3c)))
+    (unless (every #'eql identifier (map 'list #'char-code "MZ"))
+      (pecoff-processing-error "Invalid MZ MAGIC:~{ 0x~2,'0X~}"
+                               (coerce identifier 'list)))
+    (make-instance 'mz-stub
+                   :raw-magic identifier
+                   :pecoff-offset pecoff-offset
+                   :raw-data
+                   (read-coff-sequence pecoff-offset 0))))
+
+(defun read-pecoff-signature (&optional offset)
+  (let ((signature (read-coff-sequence 4 offset)))
+    (unless (every #'eql signature
+                   (map 'list #'char-code
+                        (list #\P #\E #\NULL #\NULL)))
+      (pecoff-processing-error "Invalid PE Signature:~{ 0x~2,'0X~}"
+                               (coerce signature 'list)))
+    signature))
+
+(defun read-header (&optional offset)
+  (let ((machine-type (read-coff-half offset))
+        (number-of-sections (read-coff-half))
+        (time-date-stamp (read-coff-word))
+        (offset-to-symbol-table (read-coff-word))
+        (number-of-symbols (read-coff-word))
+        (size-of-optional-header (read-coff-half))
+        (characteristics (read-coff-half)))
+    (make-instance 'header
+                   :machine-type machine-type
+                   :number-of-sections number-of-sections
+                   :time-date-stamp time-date-stamp
+                   :offset-to-symbol-table offset-to-symbol-table
+                   :number-of-symbols number-of-symbols
+                   :size-of-optional-header size-of-optional-header
+                   :characteristics characteristics)))
+
+(defun read-optional-header (size &optional offset)
+  (unless (zerop size)
+    (let ((magic (read-coff-half offset)))
+      (cond
+       ((eql magic #x010b)
+        (read-optional-header-pe32))
+       ((eql magic #x020b)
+        (read-optional-header-pe32+))
+       (t
+        (pecoff-processing-error "Unsupported optional header magic 0x~4,'0X" magic))))))
+
+(defun read-optional-header-pe32 ()
+  (apply
+   #'make-instance
+   'optional-header-pe32
+   :linker-major-version (read-coff-byte)
+   :linker-minor-version (read-coff-byte)
+   :size-of-code (read-coff-word)
+   :size-of-initialized-data (read-coff-word)
+   :size-of-uninitialized-data (read-coff-word)
+   :address-of-entry-point (read-coff-word)
+   :base-of-code (read-coff-word)
+   :base-of-data (read-coff-word)
+   (with-pecoff-reading-kind :pe32
+     (read-optional-header-windows))))
+
+(defun read-optional-header-pe32+ ()
+  (apply
+   #'make-instance
+   'optional-header-pe32+
+   :linker-major-version (read-coff-byte)
+   :linker-minor-version (read-coff-byte)
+   :size-of-code (read-coff-word)
+   :size-of-initialized-data (read-coff-word)
+   :size-of-uninitialized-data (read-coff-word)
+   :address-of-entry-point (read-coff-word)
+   :base-of-code (read-coff-word)
+   (with-pecoff-reading-kind :pe32+
+     (read-optional-header-windows))))
+
+(defun read-optional-header-windows ()
+  (list*
+   :image-base (read-coff-word/xword)
+   :section-alignment (read-coff-word)
+   :file-alignment (read-coff-word)
+   :major-os-version (read-coff-half)
+   :minor-os-version (read-coff-half)
+   :major-image-version (read-coff-half)
+   :minor-image-version (read-coff-half)
+   :major-subsystem-version (read-coff-half)
+   :minor-subsystem-version (read-coff-half)
+   :win32-version-value (read-coff-word)
+   :size-of-image (read-coff-word)
+   :size-of-headers (read-coff-word)
+   :checksum (read-coff-word)
+   :subsystem (read-coff-half)
+   :dll-characteristics (read-coff-half)
+   :size-of-stack-reserve (read-coff-word/xword)
+   :size-of-stack-commit (read-coff-word/xword)
+   :size-of-heap-reserve (read-coff-word/xword)
+   :size-of-heap-commit (read-coff-word/xword)
+   :loader-flags (read-coff-word)
+   (let ((entries (read-coff-word)))
+     (list :number-of-rva-and-sizes entries
+           :data-directories
+           (coerce
+            (loop repeat entries
+                  collect
+                  (make-instance 'data-directory
+                                 :virtual-address (read-coff-word)
+                                 :size (read-coff-word)))
+            'vector)))))
+
+(defun read-section (&optional offset)
+  (let ((result
+         (make-instance 
+          'section
+          :name (read-coff-sequence 8 offset)
+          :virtual-size (read-coff-word)
+          :virtual-address (read-coff-word)
+          :size-of-raw-data (read-coff-word)
+          :pointer-to-raw-data (read-coff-word)
+          :pointer-to-relocations (read-coff-word)
+          :pointer-to-line-numbers (read-coff-word)
+          :number-of-relocations (read-coff-half)
+          :number-of-line-numbers (read-coff-half)
+          :characteristics (read-coff-word))))
+    (unless (zerop (section-size-of-raw-data result))
+      (let ((*current-offset* *current-offset*))
+        (setf (section-raw-data result)
+              (read-coff-sequence (section-size-of-raw-data result)
+                                  (section-pointer-to-raw-data result)))))
+    result))
+
+;;;
+;;; Parsing of directories
+;;;
+
+(defun parse-export-directory (file)
+  (let ((raw-data (access-data-directory-contents file 0)))
+    (with-pecoff-reading raw-data
+      (let* ((export-flags (read-coff-word))
+             (time-date-stamp (read-coff-word))
+             (major-version (read-coff-half))
+             (minor-version (read-coff-half))
+             (name-rva (read-coff-word))
+             (ordinal-base (read-coff-word))
+             (address-table-entries (read-coff-word))
+             (name-table-entries (read-coff-word))
+             (address-table-rva (read-coff-word))
+             (name-table-rva (read-coff-word))
+             (ordinal-table-rva (read-coff-word)))
+        (make-instance
+         'export-directory
+         :export-flags export-flags
+         :time-date-stamp time-date-stamp
+         :major-version major-version
+         :minor-version minor-version
+         :name-rva name-rva
+         :ordinal-base ordinal-base
+         :address-table-entries address-table-entries
+         :name-table-entries name-table-entries
+         :address-table-rva address-table-rva
+         :name-table-rva name-table-rva
+         :ordinal-table-rva ordinal-table-rva
+         :raw-data raw-data
+         :address-table
+         (loop with result = (make-array address-table-entries)
+               for i from 0 below address-table-entries
+               do (setf (aref result i) (read-coff-word))
+               finally (return result))
+         :name-table
+         (loop with result = (make-array name-table-entries)
+               for i from 0 below name-table-entries
+               for rva = (read-coff-word)
+               do (setf (aref result i) 
+                        (get-string-from-rva file rva))
+               finally (return result))
+         :ordinal-table
+         (loop with result = (make-array address-table-entries)
+               for i from 0 below address-table-entries
+               do (setf (aref result i) (read-coff-half))
+               finally (return result)))))))
+
+;;;
+;;; Checksum Updates
+;;;
+
+(defun calculate-checksum-offset (file)
+  (+ (mz-stub-pecoff-offset (file-mz-stub file))
+     4
+     20
+     64))
+
+(defun calculate-checksum (file)
+  (loop with raw-data = (file-raw-data file)
+        with checksum-offset = (calculate-checksum-offset file)
+        with checksum = 0
+        for offset upfrom 0 below (length raw-data) by 2
+        do
+        (unless (<= checksum-offset offset (+ 2 checksum-offset))
+          (incf checksum
+                (dpb (aref raw-data (1+ offset))
+                     (byte 8 8)
+                     (aref raw-data offset)))
+          (setq checksum
+                (+ (ldb (byte 16 16) checksum)
+                   (ldb (byte 16 0) checksum))))
+        finally
+        (return
+         (ldb (byte 32 0)
+              (+
+               (ldb (byte 16 0)
+                    (+ (ldb (byte 16 16) checksum)
+                       checksum))
+               (length raw-data))))))
+
+(defun update-checksum (file)
+  (let ((raw-data (file-raw-data file))
+        (checksum (calculate-checksum file))
+        (offset (calculate-checksum-offset file)))
+    (setf (aref raw-data offset) (ldb (byte 8  0) checksum)
+          (aref raw-data (+ offset 1)) (ldb (byte 8  8) checksum)
+          (aref raw-data (+ offset 2)) (ldb (byte 8 16) checksum)
+          (aref raw-data (+ offset 3)) (ldb (byte 8 24) checksum))))
+
+;;;
+;;; Main Entry Points
+;;;
+
+(defun read-image-file (pathname)
+  (with-open-file (in pathname :element-type '(unsigned-byte 8))
+    (let ((raw-data (make-array (list (file-length in))
+				:element-type '(unsigned-byte 8))))
+      (read-sequence raw-data in)
+      (with-pecoff-reading raw-data
+        (unless (check-pecoff-file-p)
+          (pecoff-processing-error "File is not in PE/COFF format!"))
+        (let* ((mz-stub (read-mz-stub))
+               (signature (read-pecoff-signature))
+               (header (read-header))
+               (optional-header (read-optional-header (header-size-of-optional-header header)))
+               (sections (coerce
+                          (loop repeat (header-number-of-sections header)
+                                collect (read-section))
+                          'vector)))
+          (make-instance 'file
+                         :mz-stub mz-stub
+                         :signature signature
+                         :header header
+                         :optional-header optional-header
+                         :sections sections
+                         :raw-data raw-data))))))
+
+(defun write-image-file (file pathname)
+  (with-open-file (out pathname :element-type '(unsigned-byte 8)
+                       :direction :output)
+    (write-sequence (file-raw-data file) out)))

lib/pipe-stream.lisp

@@ -0,0 +1,138 @@
+;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; pipe-stream.lisp --- A pipe-stream implementation
+;;;; 
+;;;; $Id$
+
+(cl:in-package #:pmsf-lib)
+
+(pmsf-lib:file-version :pmsf-lib "$Id$")
+
+;;;; %File Description:
+;;;; 
+;;;; This file contains a pipe-stream implementation based on
+;;;; the LispWorks example code supplied with LispWorks 6.1.1.
+;;;; The example code this was derived from falls under the
+;;;; following copyright notice.
+;;;; 
+
+;;----------------------------------------------------------------------------
+;; Copyright (c) 1987--2012 LispWorks Ltd. All rights reserved.
+;;----------------------------------------------------------------------------
+
+(defstruct storage-buffer
+  (data "")
+  (data-end 0)
+  (eofp nil)
+  (lock (mp:make-lock :name "Strorage Buffer Stream Lock")))
+
+(defun add-to-storage-buffer (storage string start end)
+  (let* ((len (- end start))
+	 (storage-data (storage-buffer-data storage))
+	 (storage-data-length (length storage-data))
+         (new-data-end (+ (storage-buffer-data-end storage) len)))
+    (when (> new-data-end storage-data-length)
+      (mp:process-wait "Waiting for storage buffer to empty."
+                       #'(lambda ()
+	                   (<= (setq new-data-end
+                                     (+ (storage-buffer-data-end storage) len))
+                               storage-data-length))))
+    (mp:with-lock
+        ((storage-buffer-lock storage))
+     (replace storage-data string
+              :start1 (storage-buffer-data-end storage)
+              :end1 new-data-end)
+     (setf (storage-buffer-data-end storage) new-data-end))))
+
+(defun remove-from-storage-buffer (storage string start end)
+  (flet ((readyp
+                 ()
+           (or (/= (storage-buffer-data-end storage) 0)
+               (storage-buffer-eofp storage))))
+    
+    (loop 
+     (mp:with-lock
+         ((storage-buffer-lock storage))
+       (when (readyp)
+         (return 
+          (let ((data-end (storage-buffer-data-end storage))
+                (data (storage-buffer-data storage)))
+            (if (> data-end 0)
+                (let ((used-len (min data-end (- end start))))
+                  (replace string data
+                           :start1 start
+                           :end1 (+ start used-len))
+                  (replace data data :start1 used-len)
+                  (decf (storage-buffer-data-end storage) used-len)
+                  used-len)
+              0)))))
+     (mp:process-wait "Waiting for storage buffer to fill." #'readyp))))
+
+(defun storage-buffer-listen (storage)
+  (/= (storage-buffer-data-end storage) 0))
+
+(defun storage-buffer-element-type (storage)
+  (array-element-type (storage-buffer-data storage)))
+
+
+(defclass lisp-pipe-stream (stream:buffered-stream)
+  ((input-storage :initarg :input-storage :initform nil)
+   (output-storage :initarg :output-storage :initform nil)))
+
+(defmethod stream:stream-read-buffer ((stream lisp-pipe-stream) buffer start end)
+  (with-slots (input-storage) stream
+    (remove-from-storage-buffer input-storage buffer start end)))
+
+(defmethod stream:stream-write-buffer ((stream lisp-pipe-stream) buffer start end)
+  (with-slots (output-storage) stream
+    (add-to-storage-buffer output-storage buffer start end)))
+
+(defmethod close ((stream lisp-pipe-stream) &key abort)
+  (declare (ignore abort))
+  (with-slots (output-storage) stream
+    (when output-storage
+      (setf (storage-buffer-eofp output-storage) t)))
+  t)
+
+(defmethod stream:stream-listen ((stream lisp-pipe-stream))
+  (with-slots (input-storage) stream
+    (storage-buffer-listen input-storage)))
+
+(defmethod stream:stream-check-eof-no-hang ((stream lisp-pipe-stream))
+  (with-slots (input-storage) stream
+    (and (storage-buffer-eofp input-storage)
+         :eof)))
+
+(defmethod stream-element-type ((stream lisp-pipe-stream))
+  (with-slots (input-storage output-storage) stream
+    (storage-buffer-element-type (or input-storage output-storage))))
+
+(defmethod stream:stream-read-byte ((stream lisp-pipe-stream))
+  (char-code (stream:stream-read-char stream)))
+
+(defmethod stream:stream-write-byte ((stream lisp-pipe-stream) integer)
+  (stream:stream-write-char stream (code-char integer)))
+
+(defun make-lisp-pipe-pair (&key (element-type 'base-char) (size 8192) (direction :io))
+  "Return two values, a pair of streams connected together.  The DIRECTION argument controls the direction of the first stream, the second stream having the opposite direction.  By default, both streams are bidirectional."
+  (check-type direction (member :input :output :io))
+  (let ((storage-1-to-2 (unless (eq direction :input)
+                          (make-storage-buffer
+	                   :data (make-string size :element-type element-type))))
+        (storage-2-to-1 (unless (eq direction :output)
+                          (make-storage-buffer
+	                   :data (make-string size :element-type element-type)))))
+    (values (make-instance 'lisp-pipe-stream
+                           :direction direction
+                           :input-storage storage-2-to-1
+                           :output-storage storage-1-to-2
+	                   :element-type element-type)
+	    (make-instance 'lisp-pipe-stream
+                           :direction (case direction
+                                        (:input :output)
+                                        (:output :input)
+                                        (otherwise direction))
+                           :input-storage storage-1-to-2
+                           :output-storage storage-2-to-1
+	                   :element-type element-type))))

lib/pkgdef.lisp

@@ -0,0 +1,262 @@
+;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; pkgdef.lisp --- Package Definition for PMSF-Lib
+;;;; 
+;;;; $Id$
+
+(cl:in-package #:cl-user)
+
+;;;; %File Description:
+;;;; 
+;;;; Package Definition of PMSF-Lib
+;;;; 
+
+(defpackage #:pmsf-lib
+  (:documentation
+   "PMSF Utility package by Pierre R. Mai.  See documentation for terms.")
+  (:use #:common-lisp)
+  (:export
+   ;; doc.lisp
+   #:file-version #:*file-versions* 
+   #:get-file-versions #:list-file-versions 
+   #:list-file-checksums #:list-source-checksums
+   #:md5-file-versions
+   ;; common-utilities.lisp
+   #:generate-printed-guid
+   ;; float-utilities.lisp
+   #:single-float-positive-infinity
+   #:single-float-negative-infinity
+   #:single-float-nan
+   #:double-float-positive-infinity
+   #:double-float-negative-infinity
+   #:double-float-nan
+   #:float-infinity-p
+   #:float-nan-p
+   #:float-denormalized-p
+   #:bit-decode-float
+   #:ieee-decode-float
+   #:float-equal
+   #:read-double-float-from-string
+   #:read-single-float-from-string
+   #:write-float
+   #:float-integer-value
+   #:write-hex
+   #:pprint-float
+   #:integer-float-value
+   #:signed-integer-value
+   ;; macro-utilities.lisp
+   #:with-unique-names #:rebinding #:symbolicate #:symbolicate*
+   #:parse-body #:required-argument
+   ;; time-utilities.lisp
+   #:format-iso8601-time
+   #:define-iso8601-time-format
+   #:list-iso8601-time-formats
+   #:query-performance-counter
+   #:query-performance-frequency
+   ;; parsing-utilities.lisp
+   #:lexer-error
+   #:lexer-error-lexer
+   #:lexer-error-string
+   #:lexer-error-position
+   #:define-lexer
+   #:with-lexer
+   #:succeed
+   #:skip
+   #:fail
+   #:infix-to-prefix
+   #:generate-replacement-template
+   #:derive-new-pattern
+   ;; printf.lisp
+   #:make-printf-format-parser
+   ;; cmdline-utilities.lisp
+   #:get-command-line-arguments
+   #:command-line-argument-error
+   #:command-line-argument-error-command-line
+   #:command-line-argument-error-remaining-arguments
+   #:parse-command-line-arguments
+   #:parse-command-line-for-argument-list
+   #:call-with-parsed-arguments
+   #:call-with-parsed-command-line
+   #:with-parsed-arguments
+   #:with-parsed-command-line
+   #:&program
+   ;; zip-utilities.lisp
+   #:zip-processing-warning
+   #:zip-processing-warning-pathname
+   #:zip-processing-error
+   #:zip-processing-error-pathname
+   #:is-zip-archive-p
+   #:read-zip-archive
+   #:zip-archive
+   #:zip-archive-p
+   #:zip-archive-entries
+   #:zip-entry
+   #:zip-entry-p
+   #:zip-entry-file-name
+   #:zip-entry-file-date
+   #:zip-entry-file-comment
+   #:zip-entry-file-offset
+   #:zip-entry-compression-method
+   #:zip-entry-crc-32
+   #:zip-entry-compressed-size
+   #:zip-entry-uncompressed-size
+   #:unzip-zip-entry-to-stream
+   #:unzip-zip-archive
+   ;; aes-utilities.lisp
+   #:aes-processing-error
+   #:aes-processing-error-pathname
+   #:aes-encode-buffer
+   #:aes-encode-file
+   #:aes-decode-buffer
+   #:aes-decode-file
+   ;; pipe-stream.lisp
+   #:lisp-pipe-stream
+   #:make-lisp-pipe-pair))
+
+(defpackage #:pmsf-mop
+  (:documentation
+   "PMSF Utility package by Pierre R. Mai.  See documentation for terms.")
+  (:import-from 
+   #+sbcl #:sb-mop #+lispworks #:clos
+   .
+   #1=(;; Direct class accessors
+       #:class-default-initargs
+       #:class-direct-default-initargs
+       #:class-direct-slots
+       #:class-direct-subclasses
+       #:class-direct-superclasses
+       #:class-finalized-p
+       #:class-precedence-list
+       #:class-prototype
+       #:class-slots
+       ;; Finalization
+       #:finalize-inheritance
+       #:validate-superclass
+       ;; Slot-Definition accessors
+       #:slot-definition-allocation
+       #:slot-definition-initargs
+       #:slot-definition-initform
+       #:slot-definition-initfunction
+       #:slot-definition-location
+       #:slot-definition-name
+       #:slot-definition-readers
+       #:slot-definition-writers
+       #:slot-definition-type
+       #:direct-slot-definition-class
+       #:effective-slot-definition-class
+       ;; Slot accessors
+       #:slot-value-using-class
+       #:slot-boundp-using-class
+       #:slot-makunbound-using-class))
+  (:export
+   .
+   #1#))
+
+(defpackage #:pmsf-pecoff
+  (:documentation
+   "PMSF PE/COFF Utility package by Pierre R. Mai.  See documentation for terms.")
+  (:nicknames #:pecoff)
+  (:use #:common-lisp #:pmsf-lib)
+  (:export
+   ;; Conditions
+   #:pecoff-processing-error
+   #:pecoff-processing-error-pathname
+   ;; Structures
+   #:file
+   #:file-mz-stub
+   #:file-signature
+   #:file-header
+   #:file-optional-header
+   #:file-sections
+   #:file-raw-data
+   #:mz-stub
+   #:mz-stub-raw-magic
+   #:mz-stub-pecoff-offset
+   #:mz-stub-raw-data
+   #:+header-machine-type-i386+
+   #:+header-machine-type-amd64+
+   #:+header-machine-type-arm+
+   #:+header-machine-type-thumb+
+   #:+header-machine-type-armnt+
+   #:+header-machine-type-arm64+
+   #:header
+   #:header-machine-type
+   #:header-number-of-sections
+   #:header-time-date-stamp
+   #:header-offset-to-symbol-table
+   #:header-number-of-symbols
+   #:header-size-of-optional-header
+   #:header-characteristics
+   #:optional-header
+   #:optional-header-linker-major-version
+   #:optional-header-linker-minor-version
+   #:optional-header-size-of-code
+   #:optional-header-size-of-initialized-data
+   #:optional-header-size-of-uninitialized-data
+   #:optional-header-address-of-entry-point
+   #:optional-header-base-of-code
+   #:optional-header-image-base
+   #:optional-header-section-alignment
+   #:optional-header-file-alignment
+   #:optional-header-major-os-version
+   #:optional-header-minor-os-version
+   #:optional-header-major-image-version
+   #:optional-header-minor-image-version
+   #:optional-header-major-subsystem-version
+   #:optional-header-minor-subsystem-version
+   #:optional-header-win32-version-value
+   #:optional-header-size-of-image
+   #:optional-header-size-of-headers
+   #:optional-header-checksum
+   #:optional-header-subsystem
+   #:optional-header-dll-characteristics
+   #:optional-header-size-of-stack-reserve
+   #:optional-header-size-of-stack-commit
+   #:optional-header-size-of-heap-reserve
+   #:optional-header-size-of-heap-commit
+   #:optional-header-loader-flags
+   #:optional-header-number-of-rva-and-sizes
+   #:optional-header-data-directories
+   #:data-directory
+   #:data-directory-virtual-address
+   #:data-directory-size
+   #:optional-header-pe32
+   #:optional-header-base-of-data
+   #:optional-header-pe32+
+   #:section
+   #:section-name
+   #:section-virtual-size
+   #:section-virtual-address
+   #:section-size-of-raw-data
+   #:section-pointer-to-raw-data
+   #:section-pointer-to-relocations
+   #:section-pointer-to-line-numbers
+   #:section-number-of-relocations
+   #:section-number-of-line-numbers
+   #:section-characteristics
+   #:section-raw-data
+   #:export-directory
+   #:export-directory-export-flags
+   #:export-directory-time-date-stamp
+   #:export-directory-major-version
+   #:export-directory-minor-version
+   #:export-directory-name-rva
+   #:export-directory-name
+   #:export-directory-ordinal-name
+   #:export-directory-address-table-entries
+   #:export-directory-name-table-entries
+   #:export-directory-address-table-rva
+   #:export-directory-name-table-rva
+   #:export-directory-ordinal-table-rva
+   #:export-directory-address-table
+   #:export-directory-name-table
+   #:export-directory-ordinal-table
+   #:export-directory-raw-data
+   ;; Parsing of Additional Information
+   #:get-string-from-rva
+   #:access-data-directory-contents
+   #:parse-export-directory
+   ;; I/O
+   #:read-image-file
+   #:write-image-file))

lib/printf.lisp

@@ -0,0 +1,89 @@
+;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; printf.lisp --- C printf parsing routines
+;;;; 
+;;;; $Id$
+
+(cl:in-package #:pmsf-lib)
+
+(pmsf-lib:file-version :pmsf-lib "$Id$")
+
+;;;; %File Description:
+;;;; 
+;;;; This file contains a parser for C-style printf format
+;;;; strings.
+;;;; 
+
+(defun make-printf-format-parser (string)
+  (with-lexer (scan ()
+                    ("%([-+ #0]+)?([1-9][0-9]*)?([.][0-9]*)?(hh|h|ll|l|L|z|j|t)?([diufFeEgGxXoscp%])"
+                     (flags width precision length type)
+                     (declare (ignore length))
+                     (let ((width (when width (ignore-errors (parse-integer width))))
+                           (precision (when precision (ignore-errors (parse-integer precision :start 1))))
+                           (type (char type 0)))
+                       (ecase type
+                         (#\% (succeed :literal "%"))
+                         ((#\e #\E) 
+                          (succeed :double-float 
+                                   (lambda (val)
+                                     (format nil 
+                                             (if (member #\+ flags) "~v,v,,,,v,v@E" "~v,v,,,,v,vE")
+                                             width precision (if (member #\0 flags) #\0 #\Space)
+                                             (if (upper-case-p type) #\E #\e)
+                                             val))))
+                         ((#\f #\F)
+                          (succeed :double-float 
+                                   (lambda (val)
+                                     (format nil 
+                                             (if (member #\+ flags) "~v,v,,,v@F" "~v,v,,,vF")
+                                             width precision (if (member #\0 flags) #\0 #\Space)
+                                             val))))
+                         ((#\g #\G) 
+                          (succeed :double-float 
+                                   (lambda (val)
+                                     (format nil 
+                                             (if (member #\+ flags) "~v,v,,,,v,v@G" "~v,v,,,,v,vG")
+                                             width precision (if (member #\0 flags) #\0 #\Space)
+                                             (if (upper-case-p type) #\E #\e)
+                                             val))))
+                         ((#\d #\i #\u)
+                          (succeed (if (char= type #\u) :unsigned :signed)
+                                   (lambda (val)
+                                     (format nil (if (member #\+ flags) "~v,v@D" "~v,vD")
+                                             width (if (member #\0 flags) #\0 #\Space)
+                                             val))))
+                         ((#\x #\X)
+                          (succeed :unsigned
+                                   (lambda (val)
+                                     (format nil (if (char= type #\X) "~:@(~v,vX~)" "~(~v,vX~)")
+                                             width (if (member #\0 flags) #\0 #\Space)
+                                             val))))
+                         ((#\o)
+                          (succeed :unsigned
+                                   (lambda (val)
+                                     (format nil "~v,vO"
+                                             width (if (member #\0 flags) #\0 #\Space)
+                                             val))))
+                         (#\s
+                          (succeed :string 
+                                   (lambda (val)
+                                     (format nil "~v@A"
+                                             width
+                                             (if precision 
+                                                 (subseq val 0 (min (length val) precision))
+                                               val)))))
+                         (#\c
+                          (succeed :char
+                                   (lambda (val)
+                                     (format nil "~A" val))))
+                         (#\p
+                          (succeed :pointer 
+                                   (lambda (val)
+                                     (format nil "~8,'0X" val)))))))
+                    ("([^%]+)" 
+                     (str)
+                     (succeed :literal str)))
+      string
+    #'scan))

lib/time-utilities.lisp

@@ -0,0 +1,156 @@
+;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; time-utilities.lisp --- Utilities concerned with time processing
+;;;; 
+;;;; $Id$
+
+(cl:in-package #:pmsf-lib)
+
+(pmsf-lib:file-version :pmsf-lib "$Id$")
+
+;;;; %File Description:
+;;;; 
+;;;; This file contains utilities for time processing, especially time
+;;;; formatting.
+;;;; 
+
+(defvar *defined-iso8601-time-formats* (make-hash-table :test #'eq))
+
+(defun format-iso8601-time (&key
+                            (time (get-universal-time)) 
+                            (format :human))
+  "Format time, which defaults to the current time as returned by 
+`get-universal-time' in a string that is more or less formatted according
+to ISO8601.  The exact format can be specified by the `format' parameter,
+which must be a format defined by `define-iso8601-time-format'.  The list
+of currently defined formats can be displayed with the function
+`list-iso8601-time-formats'.  The following set of formats are currently
+pre-defined:
+
+:human          YYYY-MM-DD HH:mm:ss [+|-]HH:mm
+:human-short    YYYY-MM-DD HH:mm:ss
+:strict         YYYY-MM-DD'T'HH:mm:ss[+|-]HH:mm
+:strict-short   YYYY-MM-DD'T'HH:mm:ss
+:date           YYYY-MM-DD
+:time           HH:mm:ss
+:timezone       [+|-]HH:mm"
+  (multiple-value-bind (second minute hour date month year day daylight-p zone)
+      (decode-universal-time time)
+    (declare (ignore day))
+    (multiple-value-bind (tz-hours tz-minutes) (truncate (- zone))
+      (let ((formatter (gethash format *defined-iso8601-time-formats* nil)))
+        (unless formatter
+          (error "Undefined time format ~S in call to format-iso8601-time."
+                 format))
+        (funcall formatter year month date hour minute second 
+                 (if (minusp tz-hours) #\- #\+)
+                 (abs (+ tz-hours (if daylight-p 1 0)))
+                 (abs (* tz-minutes 60)))))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro define-iso8601-time-format (name (&rest vars) &body body)
+    "Define a new time format named `name' with the given formatter.  The 
+formatter must take the following 9 parameters in the given order via 
+`vars' and must return a string with the formatted time according to
+the format.  It should not have any side-effects.
+
+Parameters:
+  - year
+  - month
+  - day-of-month
+  - hour
+  - minute
+  - second
+  - sign of timezone as a character + or - indicating east and west of UTC
+  - hours of the timezone
+  - minutes of the timezone"
+    `(ensure-iso8601-time-format ',name (lambda (,@vars) ,@body))))
+
+(defun list-iso8601-time-formats (&optional (time (get-universal-time)))
+  "Print a list of currently defined formats and their effect on formatting
+the time given in `time', which defaults to the current time as returned by
+`get-universal-time'."
+  (let ((formats (loop for key being the hash-keys of
+                      *defined-iso8601-time-formats*
+                      collect key)))
+    (loop for format in (sort formats #'string< :key #'symbol-name)
+       for result = (format-iso8601-time :time time :format format)
+       initially
+         (format t "~&~25A ~A~2%" "Format" "Formatted Time")
+       do
+         (format t "~25S ~A~%" format result))))
+
+(defun ensure-iso8601-time-format (name formatter)
+  (setf (gethash name *defined-iso8601-time-formats*) formatter))
+
+(define-iso8601-time-format :human
+    (year month date hour minute second tz-sign tz-hours tz-minutes)
+  (format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D ~C~2,'0D:~2,'0D"
+          year month date hour minute second tz-sign tz-hours tz-minutes))
+
+(define-iso8601-time-format :strict
+    (year month date hour minute second tz-sign tz-hours tz-minutes)
+  (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~C~2,'0D:~2,'0D"
+          year month date hour minute second tz-sign tz-hours tz-minutes))
+
+(define-iso8601-time-format :human-short
+    (year month date hour minute second tz-sign tz-hours tz-minutes)
+  (declare (ignore tz-sign tz-hours tz-minutes))
+  (format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
+          year month date hour minute second))
+
+(define-iso8601-time-format :strict-short
+    (year month date hour minute second tz-sign tz-hours tz-minutes)
+  (declare (ignore tz-sign tz-hours tz-minutes))
+  (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D"
+          year month date hour minute second))
+
+(define-iso8601-time-format :date
+    (year month date hour minute second tz-sign tz-hours tz-minutes)
+  (declare (ignore hour minute second tz-sign tz-hours tz-minutes))
+  (format nil "~4,'0D-~2,'0D-~2,'0D" year month date))
+
+(define-iso8601-time-format :time
+    (year month date hour minute second tz-sign tz-hours tz-minutes)
+  (declare (ignore year month date tz-sign tz-hours tz-minutes))
+  (format nil "~2,'0D:~2,'0D:~2,'0D" hour minute second))
+
+(define-iso8601-time-format :timezone
+    (year month date hour minute second tz-sign tz-hours tz-minutes)
+  (declare (ignore year month date hour minute second))
+  (format nil "~C~2,'0D:~2,'0D" tz-sign tz-hours tz-minutes))
+
+;;;
+;;; Access To High Precision Timers
+;;;
+
+#+(and lispworks win32)
+(fli:define-foreign-function (%query-performance-counter "QueryPerformanceCounter")
+    (&optional (counter (:reference-return :int64)))
+  :result-type :int
+  :calling-convention :stdcall)
+
+#+(and lispworks win32)
+(fli:define-foreign-function (%query-performance-frequency "QueryPerformanceFrequency")
+    (&optional (freq (:reference-return :int64)))
+  :result-type :int
+  :calling-convention :stdcall)
+
+(defun query-performance-counter ()
+  #+(and lispworks win32)
+  (multiple-value-bind (good counter)
+      (%query-performance-counter)
+    (unless (zerop good)
+      counter))
+  #-(and lispworks win32)
+  (get-internal-real-time))
+
+(defun query-performance-frequency ()
+  #+(and lispworks win32)
+  (multiple-value-bind (good freq)
+      (%query-performance-frequency)
+    (unless (zerop good)
+      freq))
+  #-(and lispworks win32)
+  internal-time-units-per-second)

lib/zip-utilities.lisp

@@ -0,0 +1,345 @@
+;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; zip-utilities.lisp --- Utilities concerned with ZIP archives
+;;;; 
+;;;; $Id$
+
+(cl:in-package #:pmsf-lib)
+
+(pmsf-lib:file-version :pmsf-lib "$Id$")
+
+;;;; %File Description:
+;;;; 
+;;;; This file contains utilities for ZIP archive processing.
+;;;; 
+
+(defvar *zip-processing-pathname*)
+
+(define-condition zip-processing-warning (simple-warning)
+  ((pathname :initarg :pathname :initform *zip-processing-pathname*
+             :reader zip-processing-warning-pathname))
+  (:report 
+   (lambda (c s)
+     (with-standard-io-syntax
+       (let ((*print-readably* nil))
+         (format s 
+                 "Warning processing ZIP archive ~A: ~?"
+                 (zip-processing-warning-pathname c)
+                 (simple-condition-format-control c)
+                 (simple-condition-format-arguments c)))))))
+
+(define-condition zip-processing-error (simple-error)
+  ((pathname :initarg :pathname :initform *zip-processing-pathname*
+             :reader zip-processing-error-pathname))
+  (:report 
+   (lambda (c s)
+     (with-standard-io-syntax
+       (let ((*print-readably* nil))
+         (format s 
+                 "Error processing ZIP archive ~A: ~?"
+                 (zip-processing-error-pathname c)
+                 (simple-condition-format-control c)
+                 (simple-condition-format-arguments c)))))))
+
+(defun zip-processing-error (datum &rest arguments)
+  (error 'zip-processing-error :format-control datum :format-arguments arguments))
+
+(defun zip-processing-warn (datum &rest arguments)
+  (warn 'zip-processing-warning :format-control datum :format-arguments arguments))
+
+(defun read-zip-field (stream length)
+  (ecase length
+    (1 (read-byte stream))
+    (2 (let ((low (read-byte stream)))
+         (dpb (read-byte stream) (byte 8 8) low)))
+    (4 (let* ((low (read-byte stream))
+              (mid1 (read-byte stream))
+              (mid2 (read-byte stream)))
+         (dpb (read-byte stream) (byte 8 24)
+              (dpb mid2 (byte 8 16)
+                   (dpb mid1 (byte 8 8)
+                        low)))))))
+
+(defun ensure-zip-signature (stream signature)
+  (let ((read-signature (read-zip-field stream 4)))
+    (unless (= signature read-signature)
+      (zip-processing-error
+       "Expected Record Signature ~8,'0X, but got ~8,'0X instead!"
+       signature read-signature))
+    read-signature))
+
+(defmacro define-zip-record (name signature &rest fields)
+  (loop with package = (symbol-package name)
+        with constructor-name = (symbolicate* package '#:make- name)
+        with reader-name = (symbolicate* package '#:read- name)
+        with size-name = (symbolicate* package name '#:-size)
+        for (field-name field-size) in fields
+        collect field-name into field-names
+        collect (intern (symbol-name field-name) (find-package "KEYWORD"))
+        into field-keys
+        collect field-size into field-sizes
+        sum field-size into total-size
+        finally
+        (return
+         `(progn
+            (defstruct ,name
+              ,@field-names)
+            (defun ,reader-name (stream)
+              (ensure-zip-signature stream ,signature)
+              (,constructor-name
+               ,@(loop for field-key in field-keys
+                       for field-size in field-sizes
+                       nconcing
+                       (list field-key `(read-zip-field stream ,field-size)))))
+            (defconstant ,size-name ,(+ 4 total-size))))))
+
+(define-zip-record zip-end-of-central-directory-record #x06054b50
+  (disk-no-this-disk 2)
+  (disk-no-central-directory 2)
+  (entries-this-disk 2)
+  (total-entries 2)
+  (size 4)
+  (offset 4)
+  (file-comment-length 2))
+
+(define-zip-record zip-central-directory-record #x02014b50
+  (version-made-by 2)
+  (version-needed 2)
+  (general-purpose 2)
+  (compression-method 2)
+  (last-mod-file-time 2)
+  (last-mod-file-date 2)
+  (crc-32 4)
+  (compressed-size 4)
+  (uncompressed-size 4)
+  (file-name-length 2)
+  (extra-field-length 2)
+  (file-comment-length 2)
+  (disk-number-start 2)
+  (internal-file-attributes 2)
+  (external-file-attributes 4)
+  (relative-offset-local-header 4))
+
+(define-zip-record zip-local-file-header-record #x04034b50
+  (version-needed 2)
+  (general-purpose 2)
+  (compression-method 2)
+  (last-mod-file-time 2)
+  (last-mod-file-date 2)
+  (crc-32 4)
+  (compressed-size 4)
+  (uncompressed-size 4)
+  (file-name-length 2)
+  (extra-field-length 2))
+
+(defun find-zip-end-of-central-directory-record (stream)
+  (let* ((buffer (make-array (+ 65536 zip-end-of-central-directory-record-size)
+                             :element-type '(unsigned-byte 8)))
+         (file-length (file-length stream))
+         (file-start (max 0 (- file-length (length buffer)))))
+    (file-position stream file-start)
+    (loop with end = (read-sequence buffer stream)
+          for start = (search #(#x50 #x4b #x05 #x06) buffer :start2 0 :end2 end)
+          then (search #(#x50 #x4b #x05 #x06) buffer :start2 (1+ start) :end2 end)
+          while start
+          do
+          (when (and (<= (+ start zip-end-of-central-directory-record-size)
+                         (length buffer))
+                     (= (+ file-start
+                           start
+                           zip-end-of-central-directory-record-size
+                           (dpb (aref buffer (+ start 21))
+                                (byte 8 8)
+                                (aref buffer (+ start 20))))
+                        file-length))
+            (file-position stream (+ file-start start))
+            (return t)))))
+
+(defstruct zip-archive
+  entries)
+
+(defstruct zip-entry
+  file-name
+  file-date
+  file-comment
+  file-offset
+  compression-method
+  crc-32
+  compressed-size
+  uncompressed-size)
+
+(defun zip-entry-directory-p (entry)
+  (let ((last (char (zip-entry-file-name entry)
+                    (1- (length (zip-entry-file-name entry))))))
+    (or (char= last #\/) (char= last #\\))))
+
+(defun is-zip-archive-p (pathname)
+  (let ((*zip-processing-pathname* (pathname pathname)))
+    (handler-bind ((zip-processing-error
+                    (lambda (c)
+                      (declare (ignore c))
+                      (return-from is-zip-archive-p nil))))
+      (with-open-file (stream pathname :element-type '(unsigned-byte 8))
+        (when (find-zip-end-of-central-directory-record stream)
+          (let ((end-record (read-zip-end-of-central-directory-record stream)))
+            (zerop 
+             (zip-end-of-central-directory-record-disk-no-this-disk
+              end-record))))))))
+
+(defun read-zip-archive (pathname)
+  (let ((*zip-processing-pathname* (pathname pathname)))
+    (with-open-file (stream pathname :element-type '(unsigned-byte 8))
+      (unless (find-zip-end-of-central-directory-record stream)
+        (zip-processing-error
+         "Did not locate end of central directory record, not a ZIP archive."))
+      (let ((end-record (read-zip-end-of-central-directory-record stream)))
+        (file-position stream 
+                       (zip-end-of-central-directory-record-offset end-record))
+        (loop repeat (zip-end-of-central-directory-record-total-entries end-record)
+              for raw = (read-zip-central-directory-record stream)
+              for name = (make-array 
+                          (zip-central-directory-record-file-name-length raw)
+                          :element-type '(unsigned-byte 8))
+              do
+              (read-sequence name stream)
+              (file-position 
+               stream 
+               (+ (file-position stream)
+                  (zip-central-directory-record-extra-field-length raw)
+                  (zip-central-directory-record-file-comment-length raw)))
+              collect
+              (make-zip-entry
+               :file-name 
+               (external-format:decode-external-string 
+                name 
+                (if (zerop 
+                     (ldb (byte 1 11) 
+                          (zip-central-directory-record-general-purpose raw)))
+                    #+mswindows '(win32:code-page :id 437)
+		    #-mswindows :latin-1-safe
+                  :utf-8))
+               :file-date
+               (let ((date (zip-central-directory-record-last-mod-file-date raw))
+                     (time (zip-central-directory-record-last-mod-file-time raw)))
+                 (encode-universal-time (min 59 (* 2 (ldb (byte 5 0) time)))
+                                        (min 59 (ldb (byte 6 5) time))
+                                        (min 23 (ldb (byte 5 11) time))
+                                        (min 31 (max 1 (ldb (byte 5 0) date)))
+                                        (min 12 (max 1 (ldb (byte 4 5) date)))
+                                        (+ 1980 (ldb (byte 7 9) date))))
+               :file-offset 
+               (zip-central-directory-record-relative-offset-local-header raw)
+               :compression-method 
+               (case (zip-central-directory-record-compression-method raw)
+                 (0 :stored)
+                 (1 :shrunk)
+                 (2 :reduced1)
+                 (3 :reduced2)
+                 (4 :reduced3)
+                 (5 :reduced4)
+                 (6 :imploded)
+                 (7 :tokenized)
+                 (8 :deflated)
+                 (9 :deflated64)
+                 (10 :dcl-imploded)
+                 (12 :bzip2)
+                 (14 :lzma)
+                 (18 :terse)
+                 (19 :lz77)
+                 (97 :wavpack)
+                 (98 :ppmd)
+                 (t (zip-central-directory-record-compression-method raw)))
+               :crc-32
+               (zip-central-directory-record-crc-32 raw)
+               :compressed-size
+               (zip-central-directory-record-compressed-size raw)
+               :uncompressed-size
+               (zip-central-directory-record-uncompressed-size raw))
+              into entries
+              finally (return (make-zip-archive :entries entries)))))))
+
+(defun unzip-zip-entry-from-stream-to-stream (stream entry output)
+  (file-position stream (zip-entry-file-offset entry))
+  (let ((header (read-zip-local-file-header-record stream)))
+    (file-position stream
+                   (+ (file-position stream)
+                      (zip-local-file-header-record-file-name-length header)
+                      (zip-local-file-header-record-extra-field-length header)))
+    (case (zip-entry-compression-method entry)
+      (:stored
+       (loop with bsize = 65536
+             with block = (make-array bsize :element-type '(unsigned-byte 8))
+             for length = (zip-entry-compressed-size entry)
+             then (- length read)
+             for read = (read-sequence block stream :end (min bsize length))
+             until (progn (write-sequence block output :end read)
+                     (or (zerop read) (zerop (- length read))))))
+      (:deflated
+       (deflate:inflate-stream stream output))
+      (t
+       (zip-processing-error
+        "Unsupported ZIP compression method: ~A." 
+        (zip-entry-compression-method entry))))))
+
+(defun unzip-zip-entry-to-stream (pathname entry output)
+  (with-open-file (stream pathname :element-type '(unsigned-byte 8))
+    (unzip-zip-entry-from-stream-to-stream stream entry output)))
+
+(defun sanitized-zip-entry-pathname (entry-filename)
+  (let ((pathname (pathname entry-filename)))
+    (make-pathname
+     :host
+     (when (pathname-host pathname)
+       (zip-processing-warn "Ignoring strange host component in zip entry filename: ~S" pathname)
+       nil)
+     :device
+     (when (pathname-device pathname)
+       (zip-processing-warn "Ignoring strange device component in zip entry filename: ~S" pathname)
+       nil)
+     :directory
+     (let ((directory (pathname-directory pathname)))
+       (when (and (consp directory)
+                  (not (eq (first directory) :relative)))
+         (zip-processing-warn "Ignoring non-relative directory in zip entry filename: ~S" pathname)
+       (if (keywordp (first directory))
+           (setf (first directory) :relative)
+         (push :relative directory)))
+       (when (and (consp directory) (member :back directory))
+         (zip-processing-warn "Ignoring :back entries in directory in zip entry filename: ~S" pathname)
+         (setq directory (delete :back directory)))
+       directory)
+     :name (pathname-name pathname)
+     :type (pathname-type pathname)
+     :version
+     (when (pathname-version pathname)
+       (zip-processing-warn "Ignoring strange version component in zip entry filename: ~S" pathname)
+       nil))))
+
+(defun unzip-zip-archive (pathname directory &key prefix)
+  (let* ((*zip-processing-pathname* (pathname pathname))
+         (archive (read-zip-archive pathname)))
+    (with-open-file (stream pathname :element-type '(unsigned-byte 8))
+      (dolist (entry (zip-archive-entries archive))
+        (let ((entry-filename (zip-entry-file-name entry)))
+          (when prefix
+            (multiple-value-bind (new matchp)
+                (cl-ppcre:regex-replace prefix entry-filename "")
+              (if matchp
+                  (setq entry-filename new)
+                (setq entry-filename nil))))
+          (cond
+           ((null entry-filename)
+            ;; Skip non-matched entries
+            t)
+           ((zip-entry-directory-p entry)
+            (ensure-directories-exist 
+             (merge-pathnames (make-pathname :name "dummy")
+                              (merge-pathnames (sanitized-zip-entry-pathname entry-filename) directory))))
+           (t
+            (let ((destination (merge-pathnames (sanitized-zip-entry-pathname entry-filename) directory)))
+              (ensure-directories-exist destination)
+              (with-open-file (output destination :direction :output
+                                      :if-exists :supersede
+                                      :element-type '(unsigned-byte 8))
+                (unzip-zip-entry-from-stream-to-stream stream entry output))))))))))