Split virtual-fs.lisp into separate files.

Pascal J. Bourguignon [2012-01-15 00:09]
Split virtual-fs.lisp into separate files.
Filename
broadcast-stream.lisp
cl-stream.lisp
com.informatimago.common-lisp.virtual-file-system.asd
concatenated-stream.lisp
echo-stream.lisp
filenames.lisp
files.lisp
general.lisp
initialize.lisp
standard-streams.lisp
streams.lisp
string-input.lisp
string-output.lisp
synonym-stream.lisp
two-way-stream.lisp
utility.lisp
vfs-file-stream.lisp
vfs-packages.lisp
virtual-fs-test.lisp
virtual-fs.lisp
diff --git a/broadcast-stream.lisp b/broadcast-stream.lisp
new file mode 100644
index 0000000..5242827
--- /dev/null
+++ b/broadcast-stream.lisp
@@ -0,0 +1,124 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               broadcast-stream.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This file defines the broadcast stream operators.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-14 <PJB> Extracted from 'virtual-fs.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+
+(defclass broadcast-stream (stream)
+  ((streams :accessor %broadcast-stream-streams
+            :initarg :streams
+            :initform nil)))
+
+
+(defun make-broadcast-stream (&rest streams)
+  (dolist (stream streams)
+    (unless (output-stream-p stream)
+      (error (make-condition
+              'simple-type-error
+              :datum stream
+              :expected-type 'stream
+              :format-control "Stream is not an output stream"))))
+  (make-instance 'broadcast-stream :streams streams))
+
+
+(define-forward broadcast-stream-streams (broadcast-stream)
+  (declare (stream-argument broadcast-stream)
+           (check-stream-type broadcast-stream)))
+
+
+(defmacro do-broadcast ((output-stream broadcast-stream)
+                                      &body body)
+  `(let ((results '()))
+     (dolist (,output-stream (%broadcast-stream-streams ,broadcast-stream)
+              (values-list results))
+       (setf results (multiple-value-list (progn ,@body))))))
+
+
+
+(define-stream-methods broadcast-stream
+    (broadcast-stream-streams (%broadcast-stream-streams broadcast-stream))
+
+  (write-byte              (do-broadcast (ostream stream)
+                             (write-char byte ostream))
+                           byte)
+  (write-char              (do-broadcast (ostream stream)
+                             (write-char character ostream))
+                           character)
+  (terpri                  (do-broadcast (ostream stream)
+                             (terpri ostream))
+                           nil)
+  (fresh-line              (do-broadcast (ostream stream)
+                             (fresh-line ostream)))
+  (write-string            (do-broadcast (ostream stream)
+                             (write-string string ostream :start start :end end))
+                           string)
+  (write-line              (do-broadcast (ostream stream)
+                             (write-line string ostream :start start :end end))
+                           string)
+  (write-sequence          (do-broadcast (ostream stream)
+                             (write-sequence sequence ostream :start start :end end))
+                           sequence)
+  (clear-output            (do-broadcast (ostream stream)
+                             (clear-output ostream)))
+  (force-output            (do-broadcast (ostream stream)
+                             (force-output ostream)))
+  (finish-output           (do-broadcast (ostream stream)
+                             (finish-output ostream)))
+  (file-length             (if (%broadcast-stream-streams stream)
+                               (file-length
+                                (first (last (%broadcast-stream-streams stream))))
+                               0))
+  (file-position           (if (%broadcast-stream-streams stream)
+                               (file-position
+                                (first (last (%broadcast-stream-streams stream))))
+                               0))
+  (file-string-length      (if (%broadcast-stream-streams stream)
+                               (file-string-length
+                                (first (last (%broadcast-stream-streams stream))))
+                               1))
+  (stream-external-format  (if (%broadcast-stream-streams stream)
+                               (stream-external-format
+                                (car (last (%broadcast-stream-streams stream))))
+                               't))
+  (close                   (prog1 (%open-stream-p stream)
+                             (setf (%open-stream-p stream) nil
+                                   (%broadcast-stream-streams stream) nil))))
+
+
+
+
+;;;; THE END ;;;;
+
diff --git a/cl-stream.lisp b/cl-stream.lisp
new file mode 100644
index 0000000..78b5184
--- /dev/null
+++ b/cl-stream.lisp
@@ -0,0 +1,57 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               cl-stream.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This file defines the cl-stream operations.
+;;;;    CL-STREAMs are streams implemented as native CL streams.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-14 <PJB> Extracted from 'virtual-fs.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+
+(defclass cl-stream (stream)
+  ((stream :accessor cl-stream-stream
+           :initarg :cl-stream)))
+
+(defun cl-stream (stream)  (make-instance 'cl-stream :cl-stream stream))
+(defparameter *debug-io*        (cl-stream cl:*debug-io*))
+(defparameter *error-output*    (cl-stream cl:*error-output*))
+(defparameter *trace-output*    (cl-stream cl:*trace-output*))
+(defparameter *standard-output* (cl-stream cl:*standard-output*))
+(defparameter *standard-input*  (cl-stream cl:*standard-input*))
+(defparameter *terminal-io*     (cl-stream cl:*terminal-io*))
+
+
+
+
+
+;;;; THE END ;;;;
diff --git a/com.informatimago.common-lisp.virtual-file-system.asd b/com.informatimago.common-lisp.virtual-file-system.asd
index b4ea8ee..59d963f 100644
--- a/com.informatimago.common-lisp.virtual-file-system.asd
+++ b/com.informatimago.common-lisp.virtual-file-system.asd
@@ -4,7 +4,7 @@
     :name "Virtual File System"
     :description  "Implements a RAM-based Virtual File System."
     :author "<PJB> Pascal Bourguignon <pjb@informatimago.com>"
-    :version "0.0.1"
+    :version "0.0.4"
     :licence "GPL"
     :properties ((#:author-email                   . "pjb@informatimago.com")
                  (#:date                           . "Spring 2011")
@@ -17,6 +17,26 @@
                  :cl-ppcre
                  :com.informatimago.common-lisp.cesarum)
     :components ((:file "vfs-packages")
-                 (:file "virtual-fs"         :depends-on ("vfs-packages"))))
+                 (:file "utility"              :depends-on ("vfs-packages"))
+                 (:file "filenames"            :depends-on ("utility"))
+                 (:file "streams"              :depends-on ("utility"))
+
+                 (:file "virtual-fs"           :depends-on ("filenames"))
+                 (:file "files"                :depends-on ("streams" "filenames" "virtual-fs"))
+                 (:file "vfs-file-stream"      :depends-on ("streams" "filenames" "virtual-fs"))
+
+                 (:file "string-input"         :depends-on ("streams" "filenames"))
+                 (:file "string-output"        :depends-on ("streams" "filenames"))
+                 (:file "concatenated-stream"  :depends-on ("streams" "filenames"))
+                 (:file "broadcast-stream"     :depends-on ("streams" "filenames"))
+                 (:file "synonym-stream"       :depends-on ("streams" "filenames"))
+                 (:file "two-way-stream"       :depends-on ("streams" "filenames"))
+                 (:file "echo-stream"          :depends-on ("streams" "filenames"))
+                 (:file "standard-streams"     :depends-on ("string-input" "string-output" "two-way-stream"))
+                 (:file "cl-stream"            :depends-on ("standard-streams"))
+                 ;; ---
+                 (:file "initialize"           :depends-on ("cl-stream" "virtual-fs"))
+                 ))
+

 ;;;; THE END ;;;;
diff --git a/concatenated-stream.lisp b/concatenated-stream.lisp
new file mode 100644
index 0000000..14fdd71
--- /dev/null
+++ b/concatenated-stream.lisp
@@ -0,0 +1,140 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               concatenated-stream.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This file defines the concatenated stream operators.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-14 <PJB> Extracted from 'virtual-fs.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+
+(defclass concatenated-stream (stream)
+  ((streams :accessor %concatenated-stream-streams
+            :initarg :streams
+            :initform nil)))
+
+
+(defun make-concatenated-stream (&rest input-streams)
+  (dolist (stream streams)
+    (unless (input-stream-p stream)
+      (error (make-condition
+              'simple-type-error
+              :datum stream
+              :expected-type 'stream
+              :format-control "Stream is not an input stream"))))
+  (make-instance 'concatenated-stream :streams input-streams))
+
+
+(define-forward concatenated-stream-streams (concatenated-stream)
+  (declare (stream-argument concatenated-stream)
+           (check-stream-type concatenated-stream)))
+
+
+(defun !concatenated-read-element (read-element
+                                   stream eof-error-p eof-value recursive-p)
+  (let ((current (first (%concatenated-stream-streams stream))))
+    (if (null current)
+        (eof-error stream eof-error-p eof-value)
+        (let ((element (multiple-value-list
+                        (funcall read-element current nil stream recursive-p))))
+          (cond
+            ((eq (car element) stream)
+             (pop (%concatenated-stream-streams stream))
+             (!concatenated-read-element
+              read-element stream eof-error-p eof-value recursive-p))
+            ((second element)
+             (pop (%concatenated-stream-streams stream))
+             (multiple-value-bind (line missing-newline-p)
+                 (!concatenated-read-element
+                  read-element stream eof-error-p eof-value recursive-p)
+               (values (concatenate 'string (first element) line)
+                       missing-newline-p)))
+            (t (values-list element)))))))
+
+
+
+(define-stream-methods concatenated-stream
+    (read-byte         (!concatenated-read-element
+                        (lambda (s e v r) (declare (ignore r)) (read-byte s e v))
+                        stream eof-error-p eof-value nil))
+  (read-char         (!concatenated-read-element
+                      (function read-char)
+                      stream eof-error-p eof-value recursive-p))
+  (read-char-no-hang (!concatenated-read-element
+                      (function read-char-no-hang)
+                      stream eof-error-p eof-value recursive-p))
+  (peek-char         (!concatenated-read-element
+                      (lambda (s e v r) (peek-char peek-type s e v r))
+                      stream eof-error-p eof-value recursive-p))
+  (unread-char
+   (let ((current (first (%concatenated-stream-streams stream))))
+     (if (null current)
+         (push (make-string-input-stream (string character))
+               (%concatenated-stream-streams stream))
+         (unread-char character current))))
+  (read-line         (!concatenated-read-element
+                      (lambda (s e v r) (declare (ignore r)) (read-line s e v))
+                      stream eof-error-p eof-value recursive-p))
+  (read-sequence
+   (let ((current (first (%concatenated-stream-streams stream))))
+     (if (null current)
+         (eof-error stream eof-error-p eof-value)
+         (let* ((end      (or end (length sequence)))
+                (position (read-stream sequence current start end)))
+           (if (< position end)
+               (progn
+                 (pop (%concatenated-stream-streams stream))
+                 (setf current (first (%concatenated-stream-streams stream)))
+                 (if (null current)
+                     position
+                     (read-sequence sequence stream :start position :end end)))
+               position)))))
+  (listen
+   (let ((current (first (%concatenated-stream-streams stream))))
+     (warn "LISTEN may return NIL in the middle of a concatenated-stream when we're at the end of one of the substreams")
+     (listen current)))
+  (clear-input
+   (let ((current (first (%concatenated-stream-streams stream))))
+     (and current (clear-input current))))
+  (stream-external-format ;; or use the attribute?
+   (let ((current (first (%concatenated-stream-streams stream))))
+     (if current
+         (stream-external-format current)
+         :default)))
+  (close
+   (prog1 (%open-stream-p stream)
+     (setf (%open-stream-p stream) nil
+           (%concatenated-stream-streams stream) nil))))
+
+
+
+;;;; THE END ;;;;
diff --git a/echo-stream.lisp b/echo-stream.lisp
new file mode 100644
index 0000000..1e6ba31
--- /dev/null
+++ b/echo-stream.lisp
@@ -0,0 +1,110 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               echo-stream.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This file defines the echo stream operators.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-14 <PJB> Extracted from 'virtual-fs.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+(defclass echo-stream (stream)
+  ((input-stream  :accessor %echo-stream-input-stream
+                  :initarg :input-stream
+                  :initform nil)
+   (output-stream :accessor %echo-stream-output-stream
+                  :initarg :output-stream
+                  :initform nil)))
+
+(defun make-echo-stream (input-stream output-stream)
+  (unless (input-stream-p stream)
+    (error (make-condition
+            'simple-type-error
+            :datum input-stream
+            :expected-type 'stream
+            :format-control "Stream is not an input stream")))
+  (unless (output-stream-p stream)
+    (error (make-condition
+            'simple-type-error
+            :datum output-stream
+            :expected-type 'stream
+            :format-control "Stream is not an output stream")))
+  (make-instance 'echo-stream
+    :input-stream input-stream
+    :output-stream output-stream))
+
+(define-forward echo-stream-input-stream (echo-stream)
+  (declare (stream-argument echo-stream)
+           (check-stream-type echo-stream)))
+
+(define-forward echo-stream-output-stream (echo-stream)
+  (declare (stream-argument echo-stream)
+           (check-stream-type echo-stream)))
+
+(define-stream-methods echo-stream
+    (read-byte
+     (let ((byte (read-byte (%echo-stream-input-stream stream) nil stream)))
+       (if (eq byte stream)
+           (eof-error stream eof-error-p eof-value)
+           (progn
+             (write-byte byte  (%echo-stream-output-stream stream))
+             byte))))
+
+  (read-char
+   (let ((char (read-char (%echo-stream-input-stream stream) nil stream)))
+     (if (eq char stream)
+         (eof-error stream eof-error-p eof-value)
+         (progn
+           (write-char char (%echo-stream-output-stream stream))
+           char))))
+  (read-char-no-hang)
+  (peek-char)
+  (unread-char)
+  (read-line)
+  (read-sequence)
+  (terpri)
+  (fresh-line)
+  (write-byte  (write-byte byte      (%echo-stream-output-stream stream)))
+  (write-char  (write-char character (%echo-stream-output-stream stream)))
+  (write-string)
+  (write-line)
+  (write-sequence)
+  (listen)
+  (clear-input)
+  (clear-output)
+  (force-output)
+  (finish-output)
+
+  (file-length)
+  (file-position)
+  (file-string-length)
+  (stream-external-format)
+  (close))
diff --git a/filenames.lisp b/filenames.lisp
new file mode 100644
index 0000000..d125f2b
--- /dev/null
+++ b/filenames.lisp
@@ -0,0 +1,512 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               filenames.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This files implements CL filenames: pathnames, logical-pathnames,
+;;;;    translations.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-14 <PJB> Extracted from 'virtual-fs.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 19. Filenames
+;;; http://www.lispworks.com/documentation/HyperSpec/Body/19_.htm
+
+(define-condition simple-file-error (file-error simple-error)
+  ()
+  (:report (lambda (condition stream)
+             (format stream "~?"
+                     (simple-condition-format-control condition)
+                     (simple-condition-format-arguments condition)))))
+
+
+
+(defparameter *logical-pathname-regexp*
+  (let ((host "(([-A-Z0-9]+):)?")
+        (dire "(;)?(([-*A-Z0-9]+;|\\*\\*;)*)")
+        (name "([-*A-Z0-9]+)?")
+        (type "(.([-*A-Z0-9]+)(.([0-9]+|newest|NEWEST|\\*))?)?"))
+    (re-compile (concatenate 'string "^" host dire name type "$")
+                :extended t)))
+
+
+(defun parse-logical-pathname (string)
+  (flet ((wild (item part wild-inferiors-p)
+           (cond ((string= "*"  item) :wild)
+                 ((and wild-inferiors-p (string= "**" item)) :wild-inferiors)
+                 ((search  "**" item)
+                  (error "Invalid ~A part: ~S; ~
+                                \"**\" inside a wildcard-world is forbidden."
+                         part item))
+                 ((position #\* item) (list :wild-word item))
+                 (t item))))
+    (multiple-value-bind (all
+                          dummy0 host
+                          relative directories dummy1
+                          name
+                          dummy2 type dummy3 version)
+        (re-exec *logical-pathname-regexp* string)
+      (if all
+          (list (and host        (re-match-string string host))
+                (if relative :relative :absolute)
+                (and directories
+                     (mapcar
+                      (lambda (item) (wild item "directory" t))
+                      (butlast (split-sequence #\; (re-match-string
+                                                    string directories)))))
+                (and name
+                     (let ((item (re-match-string string name)))
+                       (wild item "name" nil)))
+                (and type
+                     (let ((item (re-match-string string type)))
+                       (wild item "type" nil)))
+                (and version
+                     (let ((version (re-match-string string version)))
+                       (cond
+                         ((string= "*" version) :wild)
+                         ((string-equal "NEWEST" version) :newest)
+                         (t (parse-integer version :junk-allowed nil))))))
+          (error "Syntax error parsing pathname ~S" string)))))
+
+
+(defun match-wild-word-p (item wild)
+  (flet ((concat (type list)
+           (let* ((totlen  (reduce (lambda (length item) (+ (length item) length))
+                                   list :initial-value 0))
+                  (result  (cond
+                             ((or (eq type 'string)
+                                  (and (consp type) (eq 'string (first type))))
+                              (make-string totlen))
+                             ((or (eq type 'vector)
+                                  (and (consp type) (eq 'vector (first type)))
+                                  (eq type 'array)
+                                  (and (consp type) (eq 'array (first type))))
+                              (make-array totlen))
+                             ((eq type 'list)
+                              (make-list totlen))
+                             (t (error "Invalid sequence type: ~S" type)))))
+             (loop
+                :for item :in list
+                :and start = 0 :then (+ start (length item))
+                :do (replace result item :start1 start)
+                :finally (return result)))))
+    (re-match
+     (concat 'string
+             (cons "^"
+                   (nconc
+                    (loop
+                       :for chunks :on (split-sequence #\* wild)
+                       :collect (car chunks) :when (cdr chunks) :collect ".*")
+                    (list "$"))))
+     item)))
+
+
+;;;---------------------------------------------------------------------
+;;; PATHNAME
+;;;---------------------------------------------------------------------
+;;;
+;;; Note: we implement pathnames just as CL logical pathnames.
+;;; pathnames are 'physical pathnames' in our virtual file system.
+;;; logical pathnames go thru logical pathname translations (have a
+;;; logical host instead of a 'physical' file system host).
+;;;
+
+
+(defclass pathname ()
+  ((host      :accessor %pathname-host
+              :initarg :host
+              :initform nil)
+   (device    :accessor %pathname-device
+              :initarg :device
+              :initform :unspecific)
+   (directory :accessor %pathname-directory
+              :initarg :directory
+              :initform nil)
+   (name      :accessor %pathname-name
+              :initarg :name
+              :initform nil)
+   (type      :accessor %pathname-type
+              :initarg :type
+              :initform nil)
+   (version   :accessor %pathname-version
+              :initarg :version
+              :initform nil))
+  (:documentation "A physical pathname."))
+
+(defmethod print-object ((self pathname) stream)
+  (flet ((present-item (item)
+           (cond ((null item) item)
+                 ((listp item) (second item))
+                 ((eq :wild item) "*")
+                 ((eq :wild-inferiors item) "**")
+                 (t item))))
+    #+(or)
+    (dolist (s '(*print-array* *print-base* *print-case*
+                 *print-circle* *print-escape* *print-gensym* *print-length*
+                 *print-level* *print-lines* *print-miser-width*
+                 *print-pprint-dispatch* *print-pretty* *print-radix*
+                 *print-readably* *print-right-margin*))
+      (format t "~A = ~A~%" s (symbol-value s)))
+    (format stream "~:[~;#P\"~]~A:~:[~;;~]~{~A;~}~:[~;~:*~A~]~
+                    ~:[~;.~:*~A~:[~;.~:*~A~]~]~0@*~:[~;\"~]"
+            *print-escape*
+            (pathname-host self)
+            (eq :relative (first (pathname-directory self)))
+            (mapcar (function present-item) (rest (pathname-directory self)))
+            (present-item (pathname-name self))
+            (present-item (pathname-type self))
+            (present-item (pathname-version self))))
+  self)
+
+
+(defun install-pathname-reader-macro (&optional (readtable *readtable*))
+  (set-dispatch-macro-character #\# #\p
+                                (lambda (stream disp char)
+                                  (declare (ignore disp char))
+                                  (pathname (read stream t nil t)))
+                                readtable))
+
+
+(defun reset-readtable ()
+  (setq *readtable* (copy-readtable nil)))
+
+
+
+
+
+(defmacro define-pathname-attribute (name &optional docstring)
+  `(defun ,(intern (format nil "PATHNAME-~A" name)) (pathname &key (case :local))
+     ,@(when docstring (list docstring))
+     (,(intern (format nil "%PATHNAME-~A" name)) (pathname pathname))))
+
+(define-pathname-attribute host
+    "Pathname Host Component: The name of the file system on which the
+file resides, or the name of a logical host.")
+
+(define-pathname-attribute device
+    "Pathname Device Component: Corresponds to the ``device'' or ``file
+structure'' concept in many host file systems: the name of a logical
+or physical device containing files.")
+
+(define-pathname-attribute directory
+    "Pathname Directory Component: Corresponds to the ``directory'' concept
+in many host file systems: the name of a group of related files. ")
+
+(define-pathname-attribute name
+    "Pathname Name Component: The ``name'' part of a group of files that
+can be thought of as conceptually related.")
+
+(define-pathname-attribute type
+    "Pathname Type Component: Corresponds to the ``filetype'' or
+``extension'' concept in many host file systems. This says what kind
+of file this is. This component is always a string, nil, :wild, or
+:unspecific.")
+
+(define-pathname-attribute version
+    "Pathname Version Component: Corresponds to the ``version number''
+concept in many host file systems.  The version is either a positive
+integer or a symbol from the following list: nil, :wild, :unspecific,
+or :newest (refers to the largest version number that already exists
+in the file system when reading a file, or to a version number greater
+than any already existing in the file system when writing a new
+file). Implementations can define other special version symbols.")
+
+
+
+(defun dump-pathname (path)
+  (format t "~&~A~%~
+             ~{~&HOST      = ~S~
+               ~&DEVICE    = ~S~
+               ~&DIRECTORY = ~S~
+               ~&NAME      = ~S~
+               ~&TYPE      = ~S~
+               ~&VERSION   = ~S~
+               ~&~}"
+          (class-name (class-of path))
+          (mapcar (lambda (f) (funcall f path :case :common))
+                             (list (function pathname-host)
+                                   (function pathname-device)
+                                   (function pathname-directory)
+                                   (function pathname-name)
+                                   (function pathname-type)
+                                   (function pathname-version)))))
+
+
+
+
+(defclass logical-pathname (pathname)
+  ()
+  (:documentation "A logical pathname."))
+
+;; Notice only the class changes from a physical PATHNAME to a LOGICAL-PATHNAME.
+
+
+
+
+
+
+(defgeneric pathname (pathspect))
+
+
+(defmethod pathname ((pathspec t))
+  (assert-type pathspec '(or string file-stream pathname)))
+
+
+(defmethod pathname ((pathspec pathname))
+  (call-next-method)
+  pathspec)
+
+
+(defmethod pathname ((pathspec string))
+  (call-next-method)
+  (destructuring-bind (host relative directory name type version)
+      (parse-logical-pathname pathspec)
+    ;; (print (list host relative directory name type version))
+    (make-instance (cond
+                     ((eql :wild host)       'pathname)
+                     ((logical-host-p host)  'logical-pathname)
+                     (t                      'pathname))
+        :host host :directory (cons relative directory)
+        :name name :type type :version version)))
+
+
+
+
+
+
+(defun check-host (host)
+  (cond
+    ((null host)              (name *default-file-system*))
+    ((eql :wild host)         host)
+    ((file-system-named host) host)
+    (t                        (error "Invalid host ~S" host))))
+
+(defun make-pathname (&key host device directory name type version (case :local)
+                      (defaults nil defaults-p))
+  (cond ((stringp directory)  (setf directory (list :absolute directory)))
+        ((eq :wild directory) (setf directory (list :absolute :wild-inferiors))))
+  (let ((host (check-host (or host (if defaults-p
+                                       (and defaults (pathname-host      defaults))
+                                       (pathname-host *default-pathname-defaults*))))))
+    (make-instance (cond
+                     ((eql :wild host)       'pathname)
+                     ((logical-host-p host)  'logical-pathname)
+                     (t                      'pathname))
+        :host        host
+        :device      (or device    (and defaults (pathname-device    defaults)))
+        :directory   (or directory (and defaults (pathname-directory defaults)))
+        :name        (or name      (and defaults (pathname-name      defaults)))
+        :type        (or type      (and defaults (pathname-type      defaults)))
+        :version     (or version   (and defaults (pathname-version   defaults))))))
+
+
+(defun pathnamep (object) (typep object 'pathname))
+
+
+
+(defparameter *logical-pathname-translations*
+  (make-hash-table :test (function equal)))
+
+(defun logical-host-p (host)
+  (nth-value 1 (gethash host *logical-pathname-translations*)))
+
+(defun logical-pathname-translations (host)
+  (assert-type host 'string)
+  (gethash host *logical-pathname-translations*))
+
+(defun (setf logical-pathname-translations) (value host)
+  (assert-type host 'string)
+  (assert (and (proper-list-p value)
+               (every (lambda (item)
+                        (and (proper-list-p item)
+                             (typep (first  item) '(or string logical-pathname))
+                             (typep (second item) '(or string pathname))))
+                      value)))
+  (setf (gethash host  *logical-pathname-translations*) value))
+
+
+(defun load-logical-pathname-translations (host)
+  (assert-type host 'string)
+  (if (nth-value 1 (logical-pathname-translations host))
+      nil
+      (with-open-file (input (make-pathname :host "SYS"
+                                            :directory '(:absolute "SITE")
+                                            :name host
+                                            :type "TRANSLATIONS"
+                                            :version :newest)
+                             :if-does-not-exist nil)
+        (if input
+            (setf (logical-pathname-translations host) (read input nil nil))
+            (error "No logical pathname translation file found for host ~S"
+                   host)))))
+
+
+(defun logical-pathname (pathspec)
+  (warn "LOGICAL-PATHNAME is not implemented correctly.")
+  (pathname pathspec))
+
+
+(defun parse-namestring (thing &optional host
+                         (default-pathname *default-pathname-defaults*)
+                         &key (start 0) (end nil) (junk-allowed nil))
+  (when (typep thing 'file-stream)
+    (setf thing (pathname thing)))
+  (error "parse-namestring not implemented yet"))
+
+
+(defun wild-pathname-p (pathname &optional field-key)
+  (assert-type pathname '(or pathname string file-stream))
+  (let ((pathname (pathname pathname)))
+    (flet ((wild-p (item)
+             (or (eq item :wild)
+                 (eq item :wild-inferiors)
+                 (and (consp item)
+                      (eq (first item) :wild-word)))))
+      (if (null field-key)
+          (or (wild-pathname-p pathname :host)
+              (wild-pathname-p pathname :device)
+              (wild-pathname-p pathname :directory)
+              (wild-pathname-p pathname :name)
+              (wild-pathname-p pathname :type)
+              (wild-pathname-p pathname :version))
+          (ecase field-key
+            (:host    (wild-p (pathname-host    pathname)))
+            (:device  (wild-p (pathname-device  pathname)))
+            (:directory (some (function wild-p)
+                              (cdr (pathname-directory pathname))))
+            (:name    (wild-p (pathname-name    pathname)))
+            (:type    (wild-p (pathname-type    pathname)))
+            (:version (wild-p (pathname-version pathname))))))))
+
+
+
+
+
+
+(defun match-item-p (item wild &optional match-wild-word-p)
+  (or (eq wild :wild)
+      (and (consp wild) (eq (first wild) :wild-word)
+           match-wild-word-p (match-wild-word-p item (second wild)))
+      (eq item wild)
+      (and (stringp item) (stringp wild) (string= item wild))))
+
+(defun match-directory-items-p (item wild)
+  (or (null item wild)
+      (if (eq (first wild) :wild-inferiors)
+          (loop
+             :for rest :on item
+             :thereis (match-directory-items-p rest (rest wild)))
+          (and (match-item-p (first item) (first wild) t)
+               (match-directory-items-p (rest item) (rest wild))))))
+
+
+(defun pathname-match-p (pathname wildcard)
+  (assert-type pathname '(or pathname string file-stream))
+  (assert-type wildcard '(or pathname string file-stream))
+  (let* ((pathname (pathname pathname))
+         (wildcard (merge-pathnames (pathname wildcard)
+                                    (load-time-value (make-pathname
+                                                      :host :wild
+                                                      :device :wild
+                                                      :directory :wild
+                                                      :name :wild
+                                                      :type :wild
+                                                      :version :wild)))))
+    (and (match-item-p (pathname-host    item) (pathname-host    wild) t)
+         (match-item-p (pathname-device  item) (pathname-device  wild) t)
+         (match-item-p (pathname-name    item) (pathname-name    wild) t)
+         (match-item-p (pathname-type    item) (pathname-type    wild) t)
+         (match-item-p (pathname-version item) (pathname-version wild) nil)
+         (or (and (eq :absolute (first (pathname-directory wild)))
+                  (eq :relative (first (pathname-directory item)))
+                  (eq :wild-inferiors (second  (pathname-directory wild))))
+             (and (eq (first (pathname-directory wild))
+                      (first (pathname-directory item)))
+                  (match-directory-items-p (rest (pathname-directory item))
+                                           (rest (pathname-directory wild))))))))
+
+
+(defun translate-logical-pathname (pathname &key)
+  (warn "translate-logical-pathname not implemented yet")
+  (pathname pathname))
+
+
+(defun translate-pathname (source from-wildcard to-wildcard &key)
+  (error "translate-pathname not implemented yet"))
+
+
+(defun delete-back (dir)
+  (loop
+     :with changed = t
+     :while changed
+     :do (loop
+            :for cur = dir :then (cdr cur)
+            :initially (setf changed nil)
+            :do (when (and (or (stringp (cadr cur)) (eq :wild (cadr cur)))
+                           (eq :back (caddr cur)))
+                  (setf (cdr cur) (cdddr cur)
+                        changed t)))
+     :finally (return dir)))
+
+
+(defun merge-pathnames (pathname
+                        &optional (default-pathname *default-pathname-defaults*)
+                        (default-version :newest))
+  (let ((pathname (pathname pathname)))
+    (make-pathname
+     :host    (or (pathname-host pathname) (pathname-host default-pathname))
+     :device  (if (and (stringp (pathname-host pathname))
+                       (stringp (pathname-host default-pathname))
+                       (member (pathname-device pathname) '(:unspecific nil))
+                       (string= (pathname-host pathname)
+                                (pathname-host default-pathname)))
+                  (pathname-device default-pathname)
+                  (or (pathname-device pathname) :unspecific))
+     :directory (if (eq :relative (car (pathname-directory pathname)))
+                    (delete-back
+                     (append (pathname-directory default-pathname)
+                             (copy-list (cdr (pathname-directory pathname)))))
+                    (or (pathname-directory pathname)
+                        (pathname-directory default-pathname)))
+     :name    (or (pathname-name pathname) (pathname-name default-pathname))
+     :type    (or (pathname-type pathname) (pathname-type default-pathname))
+     :version (cond ((pathname-name pathname)
+                     (or (pathname-version pathname) default-version))
+                    ((null default-version)
+                     (pathname-version pathname))
+                    (t
+                     (or (pathname-version pathname)
+                         (pathname-version default-pathname)))))))
+
+
+;;;; THE END ;;;;
diff --git a/files.lisp b/files.lisp
new file mode 100644
index 0000000..8fd9ed2
--- /dev/null
+++ b/files.lisp
@@ -0,0 +1,254 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               files.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    THis file defines the files operators.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-15 <PJB> Extracted from 'virtual-fs.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 20. Files
+;;; http://www.lispworks.com/documentation/HyperSpec/Body/20_.htm
+
+(defun collapse-sequences-of-wild-inferiors (list)
+  (if (search '(:wild-inferiors :wild-inferiors) list)
+      (labels ((collapse (list)
+                 (cond ((null list) list)
+                       ((and (eq :wild-inferiors (first  list))
+                             (eq :wild-inferiors (second list)))
+                        (collapse (rest list)))
+                       (t (cons (first list) (collapse (rest list)))))))
+        (collapse list))
+      list))
+
+
+(defun collect (current dpath fspath)
+  (cond
+    ((null dpath)
+     (if (pathname-name fspath)
+         (let ((entries
+                (select-entries
+                 current
+                 (lambda (item)
+                   (and (typep item 'fs-file)
+                        (match-item-p (name item) (pathname-name fspath) t)
+                        (match-item-p (type item) (pathname-type fspath) t))))))
+           (if  (pathname-version fspath)
+                (mapcan (lambda (item)
+                          (select-versions
+                           item
+                           (lambda (version)
+                             (match-item-p (version version)
+                                           (pathname-version fspath) nil))))
+                        entries)
+                entries))
+         (list current)))
+    ((eq :wild-inferiors (car dpath))
+     (nconc (mapcan (lambda (item) (collect item dpath fspath))
+                    (select-entries current (constantly t)))
+            (mapcan (lambda (item) (collect item (rest dpath) fspath))
+                    (select-entries current (constantly t)))))
+    (t
+     (mapcan
+      (lambda (item) (collect item (rest dpath) fspath))
+      (select-entries
+       current
+       (lambda (item) (and (typep item 'fs-directory)
+                           (match-item-p (name item) (car dpath) t))))))))
+
+
+(defun directory (pathspec &key)
+  (let* ((fspath (resolve-pathspec pathspec))
+         (fs  (if (pathname-host fspath)
+                  (file-system-named (pathname-host fspath))
+                  *default-file-system*)))
+    (if fs
+        (let ((d (cdr (pathname-directory fspath))))
+          (mapcar (function pathname)
+                  (collect fs (collapse-sequences-of-wild-inferiors d) fspath)))
+        (error "Invalid host ~S"  (pathname-host fspath)))))
+
+
+(defun ensure-directories-exist (pathspec &key verbose)
+  (declare (ignore verbose))
+  (let* ((fspath (resolve-pathspec pathspec))
+         (fs  (if (pathname-host fspath)
+                  (file-system-named (pathname-host fspath))
+                  *default-file-system*))
+         (dir (if (pathname-name fspath)
+                  (pathname-directory fspath)
+                  (butlast (pathname-directory fspath)))))
+    (if fs
+        (values pathspec (create-directories-at-path fs (cdr dir)))
+        (error "There's no file system named ~S" (pathname-host fspath)))))
+
+
+(defun truename (filespec)
+  "
+RETURN:      The truename of the filespec.
+URL:         http://www.lispworks.com/documentation/HyperSpec/Body/f_tn.htm
+COMMON-LISP: truename tries to find the file indicated by filespec and
+             returns its truename.  If the filespec designator is an
+             open stream, its associated file is used.  If filespec is
+             a stream, truename can be used whether the stream is open
+             or closed.  It is permissible for truename to return more
+             specific information after the stream is closed than when
+             the stream was open.  If filespec is a pathname it
+             represents the name used to open the file.  This may be,
+             but is not required to be, the actual name of the file.
+"
+  (let ((filespec (resolve-pathspec filespec)))
+    (if (wild-pathname-p filespec)
+        (error (make-condition 'simple-file-error
+                               :pathname filespec
+                               :format-control "~A: Filespec ~S is a wild pathname. "
+                               :format-arguments (list 'truename filespec)))
+        (let ((entry (file-entry filespec)))
+          (if entry
+              (pathname entry)
+              (error (make-condition 'simple-file-error
+                                     :pathname filespec
+                                     :format-control "~A: File ~S does not exist. "
+                                     :format-arguments (list 'truename filespec))))))))
+
+
+(defun probe-file (pathspec)
+  "
+RETURN:      the truename of the file or NIL.
+URL:         http://www.lispworks.com/documentation/HyperSpec/Body/f_probe_.htm
+COMMON-LISP: probe-file tests whether a file exists.
+
+             probe-file returns false if there is no file named
+             pathspec, and otherwise returns the truename of
+             pathspec.
+
+             If the pathspec designator is an open stream, then
+             probe-file produces the truename of its associated
+             file. If pathspec is a stream, whether open or closed, it
+             is coerced to a pathname as if by the  function pathname.
+"
+  (values (ignore-errors (truename pathspec))))
+
+
+
+(defun file-author       (path) (author       (file-entry (truename path))))
+(defun file-write-date   (path) (write-date   (file-entry (truename path))))
+(defun file-element-type (path) (element-type (file-entry (truename path))))
+
+(defmethod rename-entry ((self fs-file) newpath)
+  ;; rename the whole file
+  (when (ignore-errors (probe-file newpath))
+    (delete-file newpath))
+  (delete-entry self)
+  (setf (name self) (pathname-name newpath)
+        (type self) (pathname-type newpath))
+  (add-entry newpath self)
+  self)
+
+(defmethod rename-entry ((self file-contents) newpath)
+  ;; rename the version
+  (let ((file (if (ignore-errors (probe-file newpath))
+                  (file-at-path newpath)
+                  (create-file-at-path newpath :create-version-p nil))))
+    (remove-version (file self) (version self))
+    (setf (version self) (if (newest file)
+                             (max (version self) (1+ (version (newest file))))
+                             (version self))
+          (file self)   file
+          (gethash (version self) (versions file)) self)
+    self))
+
+(defmethod delete-entry ((self fs-file))
+  ;; delete the whole file
+  (remove-entry-named (parent self) (pathname-entry-name self)))
+
+(defmethod remove-version ((self fs-file) version)
+  (remhash version (versions self))
+  (when (= version (version (newest self)))
+    (let ((maxk -1) (maxv))
+      (maphash (lambda (k v) (when (< maxk k) (setf maxk k maxv v))) (versions self))
+      (if maxv
+          (setf (newest self) maxv)
+          ;; otherwise, we've deleted the last version, let's delete the file:
+          (delete-entry self)))))
+
+(defmethod delete-entry ((self file-contents))
+  ;; delete the version ( careful with (newest (file self)) ).
+  (remove-version (file self) (version self)))
+
+(defun rename-file (filespec new-name)
+  (let* ((defaulted (merge-pathnames new-name filespec))
+         (old-truename (truename filespec))
+         (new-truename (resolve-pathspec defaulted)))
+    (print (list defaulted old-truename new-truename))
+    (when (wild-pathname-p defaulted)
+      (error (make-condition
+              'simple-file-error
+              :pathname defaulted
+              :format-control "~A: source path ~A contains wildcards"
+              :format-arguments (list 'rename-file defaulted))))
+    (when (wild-pathname-p new-truename)
+      (error (make-condition
+              'simple-file-error
+              :pathname new-truename
+              :format-control "~A: target path ~A contains wildcards"
+              :format-arguments (list 'rename-file new-truename))))
+    (let* ((newpath (make-pathname :version nil :defaults new-truename))
+           (newdir  (directory-entry newpath)))
+      (unless newdir
+        (error (make-condition
+                'simple-file-error
+                :pathname newpath
+                :format-control "~A: target directory ~A doesn't exist"
+                :format-arguments (list 'rename-file newpath))))
+      (rename-entry (file (file-entry old-truename)) newpath))
+    (values defaulted old-truename new-truename)))
+
+(defun delete-file (filespec)
+  (delete-entry (file (file-entry (truename filespec))))
+  t)
+
+(defun delete-directory (pathspec)
+  (let ((dir (directory-entry pathspec)))
+    (when dir
+      (when (plusp (hash-table-count (entries dir)))
+        (error (make-condition
+                'simple-file-error
+                :pathname pathspec
+                :format-control "~A: directory ~A is not empty"
+                :format-arguments (list 'delete-directory pathspec))))
+      (delete-entry dir)))
+  t)
+
+;;;; THE END ;;;;
diff --git a/general.lisp b/general.lisp
new file mode 100644
index 0000000..f3d6b99
--- /dev/null
+++ b/general.lisp
@@ -0,0 +1,135 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               general.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This file defines the general file and stream  functions and macro.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-14 <PJB> Extracted from 'virtual-fs.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+
+(defun y-or-n-p (&optional format-string &rest args)
+  (when format-string
+    (fresh-line *query-io*)
+    (apply (function format) *query-io* format-string args)
+    (write-string " (y/n) " *query-io*))
+  (loop
+     (let ((line (string-left-trim " " (read-line *query-io*))))
+       (when (plusp (length line))
+         (let ((first-char (char-upcase (char line 0))))
+           (when (char-equal first-char #\n) (return nil))
+           (when (char-equal first-char #\y) (return t))))
+       (write-string "Please answer with 'y' or 'n': " *query-io*))))
+
+
+(defun yes-or-no-p (&optional format-string &rest args)
+  (when format-string
+    (fresh-line *query-io*)
+    (apply (function format) *query-io* format-string args)
+    (write-string " (yes/no) " *query-io*))
+  (loop
+     (clear-input *query-io*)
+     (let ((line (string-trim " " (read-line *query-io*))))
+       (when (string-equal line "NO")  (return nil))
+       (when (string-equal line "YES") (return t)))
+     (write-string "Please answer with 'yes' or 'no': " *query-io*)))
+
+
+
+
+
+;; Macros are taken from clisp sources, and adapted.
+(eval-when (:execute :compile-toplevel :load-toplevel)
+ (defun parse-body (body)
+   (values (extract-body body)
+           (let ((decls '()))
+             (maphash
+              (lambda (k v)
+                (setf decls (nconc (mapcar (lambda (d) (cons k v)) v) decls)))
+              (declarations-hash-table (extract-declarations body)))
+             decls))))
+
+
+(defmacro with-open-file ((stream &rest options) &body body)
+  (multiple-value-bind (body-rest declarations)  (parse-body body)
+    `(let ((,stream (open ,@options)))
+       (declare (read-only ,stream) ,@declarations)
+       (unwind-protect
+            (multiple-value-prog1 (progn ,@body-rest)
+              (when ,stream (close ,stream)))
+         (when ,stream (close ,stream :abort t))))))
+
+
+(defmacro with-open-stream ((var stream) &body body)
+  (multiple-value-bind (body-rest declarations) (parse-body body)
+    `(let ((,var ,stream))
+       (declare (read-only ,var) ,@declarations)
+       (unwind-protect
+            (multiple-value-prog1 (progn ,@body-rest) (close ,var))
+         (close ,var :abort t)))))
+
+
+(defmacro with-input-from-string ((var string  &key (index nil sindex)
+                                       (start '0 sstart) (end 'nil send))
+                                  &body body)
+  (multiple-value-bind (body-rest declarations) (parse-body body)
+    `(let ((,var (make-string-input-stream
+                  ,string
+                  ,@(if (or sstart send)
+                        `(,start ,@(if send `(,end) '()))
+                        '()))))
+       (declare (read-only ,var) ,@declarations)
+       (unwind-protect
+            (progn ,@body-rest)
+         ,@(when sindex `((setf ,index (%string-stream-index ,var))))
+         (close ,var)))))
+
+
+(defmacro with-output-to-string ((var &optional (string nil)
+                                      &key (element-type ''character))
+                                 &body body)
+  (multiple-value-bind (body-rest declarations) (parse-body body)
+    (if string
+        (let ((ignored-var (gensym)))
+          `(let ((,var (make-instance 'string-output-stream :string ,string))
+                 (,ignored-var ,element-type))
+             (declare (read-only ,var) (ignore ,ignored-var) ,@declarations)
+             (unwind-protect
+                  (progn ,@body-rest)
+               (close ,var))))
+        `(let ((,var (make-string-output-stream :element-type ,element-type)))
+           (declare (read-only ,var) ,@declarations)
+           (unwind-protect
+                (progn ,@body-rest (get-output-stream-string ,var))
+             (close ,var))))))
+
+;;;; THE END ;;;;
diff --git a/initialize.lisp b/initialize.lisp
new file mode 100644
index 0000000..77dd7b7
--- /dev/null
+++ b/initialize.lisp
@@ -0,0 +1,57 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               initialize.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This file initializes the vfs.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-15 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+
+
+
+(defparameter *debug-io*        cl:*debug-io*)
+(defparameter *error-output*    cl:*error-output*)
+(defparameter *trace-output*    cl:*trace-output*)
+(defparameter *standard-output* cl:*standard-output*)
+(defparameter *standard-input*  cl:*standard-input*)
+(defparameter *terminal-io*     cl:*terminal-io*)
+
+
+(defparameter *author*
+  (first (last (cl:pathname-directory (cl:user-homedir-pathname))))
+  "The name or identification of the user.")
+
+
+
+;;;; THE END ;;;;
diff --git a/standard-streams.lisp b/standard-streams.lisp
new file mode 100644
index 0000000..a07b2e5
--- /dev/null
+++ b/standard-streams.lisp
@@ -0,0 +1,49 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               standard-streams.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Defines the standard streams.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-14 <PJB> Extracted from 'virtual-fs.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+(defvar *standard-input*  (make-string-input-stream ""))
+(defvar *standard-output* (make-string-output-stream))
+(defvar *error-output*    (make-string-output-stream))
+
+(defvar *trace-output*    *standard-output*)
+(defvar *terminal-io*     (make-two-way-stream *standard-input*
+                                               *standard-output*))
+(defvar *debug-io*        *terminal-io*)
+(defvar *query-io*        *terminal-io*)
+
+;;;; THE END ;;;;
diff --git a/streams.lisp b/streams.lisp
new file mode 100644
index 0000000..7602d98
--- /dev/null
+++ b/streams.lisp
@@ -0,0 +1,502 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               streams.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This file exports streams.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-15 <PJB> Extracted from 'virtual-fs.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 21. Streams
+;;; http://www.lispworks.com/documentation/HyperSpec/Body/21_.htm
+
+(define-condition simple-stream-error (stream-error simple-error)
+  ()
+  (:report (lambda (condition stream)
+             (format stream "~?"
+                     (simple-condition-format-control condition)
+                     (simple-condition-format-arguments condition)))))
+
+;;;---------------------------------------------------------------------
+;;; STREAM
+;;;---------------------------------------------------------------------
+
+(defclass stream ()
+  ((open-p          :accessor %open-stream-p
+                    :initarg  :open-p
+                    :initform nil)
+   (element-type    :accessor %stream-element-type
+                    :initarg  :element-type
+                    :initform 'character)
+   (external-format :accessor %stream-external-format
+                    :initarg  :external-format
+                    :initform :default)
+   (input-p         :accessor %input-stream-p
+                    :initarg  :input-p
+                    :initform nil)
+   (output-p        :accessor %output-stream-p
+                    :initarg  :output-p
+                    :initform nil)))
+
+(defmethod print-object-fields ((self stream) stream)
+  (format stream " ~:[CLOSED~;OPEN~] ~[PROBE~;INPUT~;OUTPUT~;I/O~] :ELEMENT-TYPE ~S :EXTERNAL-FORMAT ~S"
+          (%open-stream-p self)
+          (if (%input-stream-p self)
+              (if (%output-stream-p self)
+                  3
+                  1)
+              (if (%output-stream-p self)
+                  2
+                  0))
+          (%stream-element-type self)
+          (%stream-external-format self)))
+
+
+(defmethod print-object ((self stream) stream)
+  (print-unreadable-object (self stream :identity t :type t)
+    (print-object-fields self stream))
+  self)
+
+
+(defclass string-stream (stream)
+  ())
+
+
+
+
+
+;; (define-forward name arguments
+;;   [ documentation-string ]
+;;   { declarations }
+;;   { forward-method-description })
+;;
+;; (declare (stream-arguments stream)
+;;          (stream-designnator (istream :input)) ; default
+;;          (stream-designator  (ostream :output))
+;;          (check-stream-type file-stream)
+;;          (cl-forward t))
+;;
+;; (declare (stream-arguments stream))
+;;
+;; (declare (check-stream-type file-stream))
+;;
+;; method-description ::= (:method class [[declaration* | documentation]] form*)
+
+(eval-when (:execute :compile-toplevel :load-toplevel)
+  (defun make-method-lambda-list (lambda-list self-name self-type)
+    (let* ((got-it nil)
+           (mand (mapcar (lambda (par)
+                           (let ((name (parameter-name par)))
+                             (if (eq name self-name)
+                                 (progn (setf got-it t)
+                                        (list name self-type))
+                                 (list name 't))))
+                         (lambda-list-mandatory-parameters lambda-list)))
+           (opti (let ((optionals  (lambda-list-optional-parameters lambda-list)))
+                   (cond
+                     ((null optionals) nil)
+                     (got-it (cons '&optional
+                                   (mapcar (function parameter-specifier)
+                                           optionals)))
+                     (t (let ((pos  (position self-name optionals
+                                              :key (function parameter-name))))
+                          (if pos
+                              (append
+                               (mapcar (lambda (par) (list (parameter-name par) 't))
+                                       (subseq optionals 0 pos))
+                               (list
+                                (list (parameter-name (nth pos optionals))
+                                      self-type))
+                               (when (< (1+ pos) (length optionals))
+                                 (cons '&optional
+                                       (mapcar (function parameter-specifier)
+                                               (subseq optionals (1+ pos))))))
+                              (cons '&optional
+                                    (mapcar (function parameter-specifier)
+                                            optionals))))))))
+           (keys (mapcar (function parameter-specifier)
+                         (lambda-list-keyword-parameters lambda-list)))
+           (rest (and (lambda-list-rest-p lambda-list)
+                      (mapcar (function parameter-specifier)
+                              (lambda-list-rest-parameter lambda-list)))))
+      (append mand opti
+              (when keys (cons '&key keys))
+              (when rest (list '&rest rest))))))
+
+
+(defun stream-designator (stream direction)
+  "DIRECTION is either *standard-input* or *standard-output*"
+  (case stream
+    ((t)       *terminal-io*)
+    ((nil)     direction)
+    (otherwise stream)))
+
+(defun raise-type-error (object type)
+  (error (make-condition 'type-error :datum object :expected-type type)))
+
+
+
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defparameter *stream-methods* (make-hash-table)
+    "Keep the information about methods defined with DEFINE-FORWARD,
+for use by DEFINE-STREAM-METHODS"))
+
+
+(defun check-open (method stream)
+  (unless (%open-stream-p stream)
+    (error (make-condition 'simple-stream-error
+                           :stream stream
+                           :format-control "~S on ~S is illegal: the stream must be open. "
+                           :format-arguments (list method stream)))))
+
+
+(defclass cl-stream (stream) ()) ; forward declaration for define-forward...
+
+(defmacro define-forward (name arguments &body body)
+  "
+DO:     Specifies the name and parameter list of methods.
+        The BODY contains declarations and method clauses.
+
+        Specific pseudo-declarations are:
+
+        (stream-argument   stream-parameter)
+        (stream-designator (stream-parameter [:input|:output]))
+
+            Specify the stream parameter.  In the case of
+            stream-designator, the stream can be *standard-input* or
+            *standard-output* by default, as indicated by the keyword.
+
+        (check-stream-type stream-parameter)
+
+            When given, the stream type is checked in the default method.
+            (overriding methods should (call-next-method)).
+
+        (check-open-p      stream-parameter)
+
+            When given, the methods generated by DEFINE-STREAM-METHODS
+            will test for an open stream.
+
+        (cl-forward        booolean)
+
+             When the boolean is true, a method is defined for CL-STREAM
+             that forwards the call to the corresponding CL function.
+
+        The method clauses in the body are of the form:
+
+        (:method class . body)
+
+             For each of these clause, method is defined for the given
+             stream class.
+
+"
+  (let* ((documentation     (extract-documentation body))
+         (declarations      (declarations-hash-table (extract-declarations  body)))
+         (body              (extract-body          body))
+         (stream-argument   (caar  (gethash 'stream-argument   declarations)))
+         (stream-designator (caar  (gethash 'stream-designator declarations)))
+         (stream-name       (or stream-argument
+                                (if (consp stream-designator)
+                                    (first stream-designator)
+                                    stream-designator)))
+         (check-stream-type (caar  (gethash 'check-stream-type declarations)))
+         (cl-forward        (caar  (gethash 'cl-forward        declarations)))
+         (check-open-p      (caar  (gethash 'check-open-p      declarations)))
+         (lambda-list       (parse-lambda-list arguments :ordinary))
+         (m-name            (intern (format nil "%~A" name)))
+         (cl-name           (intern (string name) "COMMON-LISP")))
+    `(progn
+       (eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (gethash ',name *stream-methods*)
+               (list ',m-name (parse-lambda-list ',arguments :ordinary)
+                     ',stream-name ',check-open-p)))
+       (defun ,name ,arguments
+         ,@(when documentation (list documentation))
+         ,@(when stream-designator
+                 `((setf ,stream-name (stream-designator
+                                       ,stream-name
+                                       ,(if (listp stream-designator)
+                                            (ecase (second stream-designator)
+                                              ((:input)  '*standard-input*)
+                                              ((:output) '*standard-output*))
+                                            '*standard-input*)))))
+         ,(if (lambda-list-rest-p lambda-list)
+              `(apply (function ,m-name) ,@(make-argument-list lambda-list))
+              `(,m-name         ,@(butlast (make-argument-list lambda-list)))))
+       ,@(when cl-forward
+               `((defmethod ,m-name
+                     ,(make-method-lambda-list lambda-list stream-name 'cl-stream)
+                   ,(let ((arguments (mapcar
+                                      (lambda (arg)
+                                        (if (eq arg stream-name)
+                                            `(cl-stream-stream ,stream-name)
+                                            arg))
+                                      (make-argument-list lambda-list))))
+                         (if (lambda-list-rest-p lambda-list)
+                             `(apply (function ,cl-name) ,@arguments)
+                             `(,cl-name ,@(butlast arguments)))))
+                 (defmethod ,m-name
+                     ,(make-method-lambda-list lambda-list stream-name 'cl:stream)
+                   ,(let ((arguments (make-argument-list lambda-list)))
+                         (if (lambda-list-rest-p lambda-list)
+                             `(apply (function ,cl-name) ,@arguments)
+                             `(,cl-name ,@(butlast arguments)))))))
+       ,@(when check-stream-type
+               `((defmethod ,m-name ,(make-method-lambda-list lambda-list stream-name 't)
+                   (raise-type-error ,stream-name ',check-stream-type))))
+       ,@(mapcar
+          (lambda (method)
+            (when (and (listp method) (eq :method (car method)))
+              (destructuring-bind (method class-name &body body) method
+                (declare (ignore method))
+                `(defmethod ,m-name
+                     ,(make-method-lambda-list lambda-list stream-name class-name)
+                   ,@body))))
+          body))))
+
+
+(defmacro define-stream-methods (class-name &body methods)
+  "
+DO:     Expands to a bunch of defmethod forms, with the parameter
+        defined with DEFINE-FORWARD, and the body provided in the
+        METHODS clauses.
+"
+  `(progn
+     ,@(mapcar (lambda (method)
+                 (let ((minfo (gethash (first method) *stream-methods*)))
+                   (unless minfo
+                     (error "Unknown method ~S; please use DEFINE-FORWARD first"
+                            (first method)))
+                   (destructuring-bind (name lambda-list stream-name check-open-p)
+                       minfo
+                     `(defmethod ,name
+                          ,(make-method-lambda-list lambda-list stream-name class-name)
+                        ,@(when check-open-p `((check-open ',name ,stream-name)))
+                        ,@(rest method)))))
+               methods)))
+
+
+
+(define-forward input-stream-p       (stream)
+  (declare (stream-argument stream)
+           (check-stream-type stream)
+           (cl-forward t)))
+
+(define-forward output-stream-p      (stream)
+  (declare (stream-argument stream)
+           (check-stream-type stream)
+           (cl-forward t)))
+
+(define-forward interactive-stream-p (stream)
+  (declare (stream-argument stream)
+           (check-stream-type stream)
+           (cl-forward t))
+  (:method stream nil))
+
+(define-forward open-stream-p        (stream)
+  (declare (stream-argument stream)
+           (check-stream-type stream)
+           (cl-forward t)))
+
+(define-forward stream-element-type  (stream)
+  (declare (stream-argument stream)
+           (check-stream-type stream)
+           (cl-forward t)))
+
+(defun streamp (object) (typep object 'stream))
+
+(defun eof-stream (stream eof-error-p eof-value)
+  (if eof-error-p
+      (error (make-condition 'eof-error :stream stream))
+      eof-value))
+
+
+
+(define-forward read-byte (stream &optional (eof-error-p t) (eof-value nil))
+  (declare (stream-argument stream)
+           (check-stream-type stream)
+           (cl-forward t)
+           (check-open-p t)))
+
+(define-forward write-byte (byte stream)
+  (declare (stream-argument stream)
+           (check-stream-type stream)
+           (cl-forward t)
+           (check-open-p t)))
+
+(define-forward peek-char (&optional (peek-type nil) (stream *standard-input*)
+                                     (eof-error-p t) (eof-value nil)
+                                     (recursive-p nil))
+  (declare (stream-designator (stream :input))
+           (cl-forward t)
+           (check-open-p t)))
+
+
+(define-forward read-char (&optional (input-stream *standard-input*)
+                                     (eof-error-p t) (eof-value nil)
+                                     (recursive-p nil))
+  (declare (stream-designator (input-stream :input))
+           (cl-forward t)
+           (check-open-p t)))
+
+
+(define-forward read-char-no-hang (&optional (input-stream *standard-input*)
+                                             (eof-error-p t) (eof-value nil)
+                                             (recursive-p nil))
+  (declare (stream-designator (input-stream :input))
+           (cl-forward t)
+           (check-open-p t)))
+
+
+(define-forward terpri (&optional (output-stream *standard-output*))
+  (declare (stream-designator (output-stream :output))
+           (cl-forward t)
+           (check-open-p t)))
+
+
+(define-forward fresh-line (&optional (output-stream *standard-output*))
+  (declare (stream-designator (output-stream :output))
+           (cl-forward t)
+           (check-open-p t)))
+
+
+(define-forward unread-char (character &optional (input-stream *standard-input*))
+  (declare (stream-designator (input-stream :input))
+           (cl-forward t)
+           (check-open-p t)))
+
+
+(define-forward write-char (character
+                            &optional (output-stream *standard-output*))
+  (declare (stream-designator (output-stream :output))
+           (cl-forward t)
+           (check-open-p t)))
+
+
+(define-forward read-line (&optional (input-stream *standard-input*)
+                                     (eof-error-p t) (eof-value nil)
+                                     (recursive-p nil))
+  (declare (stream-designator (input-stream :input))
+           (cl-forward t)
+           (check-open-p t)))
+
+
+(define-forward write-string (string
+                              &optional (output-stream *standard-output*)
+                              &key (start 0) (end nil))
+  (declare (stream-designator (output-stream :output))
+           (cl-forward t)
+           (check-open-p t)))
+
+
+(define-forward write-line (string
+                            &optional (output-stream *standard-output*)
+                            &key (start 0) (end nil))
+  (declare (stream-designator (output-stream :output))
+           (cl-forward t)
+           (check-open-p t)))
+
+
+(define-forward read-sequence (sequence stream &key (start 0) (end nil))
+  (declare (stream-argument stream)
+           (cl-forward t)
+           (check-open-p t)))
+
+
+(define-forward write-sequence (sequence stream &key (start 0) (end nil))
+  (declare (stream-argument stream)
+           (cl-forward t)
+           (check-open-p t)))
+
+
+(define-forward file-length (stream)
+  (declare (stream-argument stream)
+           (check-stream-type file-stream)
+           (cl-forward t))
+  (:method stream (error "not implemented yet")))
+
+
+(define-forward file-position (stream &optional (position-spec nil))
+  (declare (stream-argument stream)
+           (cl-forward t)
+           (check-open-p t)))
+
+
+(define-forward file-string-length (stream object)
+  (declare (stream-argument stream)
+           (check-stream-type file-stream)
+           (cl-forward t)
+           (check-open-p t)))
+
+
+(define-forward stream-external-format (stream)
+  (declare (stream-argument stream)
+           (check-stream-type stream)
+           (cl-forward t)))
+
+
+(define-forward close (stream &key (abort nil))
+  (declare (stream-argument stream)
+           (check-stream-type stream)
+           (cl-forward t)))
+
+
+(define-forward listen (&optional input-stream)
+  (declare (stream-designator input-stream)
+           (cl-forward t) (check-open-p t)))
+
+
+(define-forward clear-input (&optional input-stream)
+  (declare (stream-designator (input-stream :input))
+           (cl-forward t) (check-open-p t)))
+
+
+(define-forward clear-output (&optional output-stream)
+  (declare (stream-designator (output-stream :output))
+           (cl-forward t) (check-open-p t)))
+
+
+(define-forward force-output (&optional output-stream)
+  (declare (stream-designator (output-stream :output))
+           (cl-forward t) (check-open-p t)))
+
+
+(define-forward finish-output (&optional output-stream)
+  (declare (stream-designator (output-stream :output))
+           (cl-forward t) (check-open-p t)))
+
+
+;;;; THE END ;;;;
diff --git a/string-input.lisp b/string-input.lisp
new file mode 100644
index 0000000..6e46cd6
--- /dev/null
+++ b/string-input.lisp
@@ -0,0 +1,86 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               string-input.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This file defines the string input operators.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-14 <PJB> Extracted from 'virtual-fs.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+
+(defclass string-input-stream (string-stream)
+  ((string :accessor %string-stream-input-string
+           :initarg :string
+           :initform ""
+           :type     string)
+   (index  :accessor %string-stream-index
+           :initarg :index
+           :initform 0
+           :type (integer 0))
+   (start  :accessor %string-stream-start
+           :initarg :start
+           :initform 0
+           :type (integer 0))
+   (end    :accessor %string-stream-end
+           :initarg :end
+           :initform nil
+           :type (or null (integer 0)))))
+
+
+(defun make-string-input-stream (string &optional (start 0) (end nil))
+  (make-instance 'string-input-stream
+      :open-p t
+      :input-p t
+      :output-p nil
+      :element-type 'character
+      :external-format :default
+      :string string
+      :start start
+      :end end))
+
+
+(defun !string-input-read (stream)
+  (if (< (%string-stream-index stream)
+         (or (%string-stream-end stream)
+             (length (%string-stream-input-string stream))))
+      (aref (%string-stream-input-string stream)
+            (prog1 (%string-stream-index stream)
+              (incf (%string-stream-index stream))))
+      (eof-stream stream eof-error-p eof-value)))
+
+
+(define-stream-methods string-input-stream
+  (read-byte (char-code (!string-input-read stream)))
+  (read-char (!string-input-read stream)))
+
+
+;;;; THE END ;;;;
diff --git a/string-output.lisp b/string-output.lisp
new file mode 100644
index 0000000..dbbef25
--- /dev/null
+++ b/string-output.lisp
@@ -0,0 +1,81 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               string-output.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This file defines the string output operators.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-14 <PJB> Extracted from 'virtual-fs.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+(defclass string-output-stream (string-stream)
+  ((string :accessor %string-stream-output-string
+           :initarg :string
+           :initform (make-array 8
+                                 :fill-pointer 0 :adjustable t
+                                 :element-type 'character)
+           :type     string)))
+
+
+(defun make-string-output-stream (&key (element-type 'character))
+  (make-instance 'string-output-stream
+      :open-p t
+      :input-p nil
+      :output-p t
+      :element-type 'character
+      :external-format :default
+      :string (make-array 8
+                          :fill-pointer 0 :adjustable t
+                          :element-type element-type)))
+
+
+(define-stream-methods string-output-stream
+    (write-byte
+     (vector-push-extend (char-code byte)
+                         (%string-stream-output-string stream)
+                         (* 2 (length (%string-stream-output-string stream))))
+     byte)
+  (write-char
+   (vector-push-extend character
+                       (%string-stream-output-string stream)
+                       (* 2 (length (%string-stream-output-string stream))))
+   character))
+
+
+(define-forward get-output-stream-string (string-output-stream)
+  (declare (stream-argument   string-output-stream)
+           (check-stream-type string-output-stream))
+  (:method string-output-stream
+    (prog1 (copy-seq (%string-stream-output-string string-output-stream))
+      (setf (fill-pointer (%string-stream-output-string string-output-stream)) 0))))
+
+
+;;;; THE END ;;;;
diff --git a/synonym-stream.lisp b/synonym-stream.lisp
new file mode 100644
index 0000000..4cdc155
--- /dev/null
+++ b/synonym-stream.lisp
@@ -0,0 +1,66 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               synonym-stream.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This file defines the synonyms stream operators.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-14 <PJB> Extracted from 'virtual-fs.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+
+(defclass synonym-stream (stream)
+  ((symbol  :accessor %synonym-stream-symbol
+            :initarg :symbol)))
+
+
+(defun make-synonym-stream (symbol)
+  (check-type symbol symbol)
+  (make-instance 'synonym-stream :symbol symbol))
+
+
+(define-forward synonym-stream-symbol (synonym-stream)
+  (declare (stream-argument synonym-stream)
+           (check-stream-type synonym-stream)))
+
+
+(define-stream-methods synonym-stream
+    (synonym-stream-symbol (%synonym-stream-symbol synonym-stream))
+  (read-byte   (read-byte  (symbol-value (%synonym-stream-symbol stream))
+                           eof-error-p eof-value))
+  (write-byte  (write-byte (symbol-value (%synonym-stream-symbol stream))))
+
+  (read-char   (read-char  (symbol-value (%synonym-stream-symbol stream))
+                           eof-error-p eof-value))
+  (write-char  (write-char (symbol-value (%synonym-stream-symbol stream)))))
+
+
+;;;; THE END ;;;;
diff --git a/two-way-stream.lisp b/two-way-stream.lisp
new file mode 100644
index 0000000..38a2eb4
--- /dev/null
+++ b/two-way-stream.lisp
@@ -0,0 +1,105 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               two-way-stream.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This file defines the two-way stream operators.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-14 <PJB> Extracted from 'virtual-fs.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+
+(defclass two-way-stream (stream)
+  ((input-stream  :accessor %two-way-stream-input-stream
+                  :initarg :input-stream
+                  :initform nil)
+   (output-stream :accessor %two-way-stream-output-stream
+                  :initarg :output-stream
+                  :initform nil)))
+
+
+(defun make-two-way-stream (input-stream output-stream)
+  (unless (input-stream-p input-stream)
+    (error (make-condition
+            'simple-type-error
+            :datum input-stream
+            :expected-type 'stream
+            :format-control "Stream is not an input stream")))
+  (unless (output-stream-p output-stream)
+    (error (make-condition
+            'simple-type-error
+            :datum output-stream
+            :expected-type 'stream
+            :format-control "Stream is not an output stream")))
+  (unless (equal (stream-element-type input-stream)
+                 (stream-element-type output-stream))
+    (error "~S: the element types of the input stream ~S and the output stream ~S are not equal."
+           'make-two-way-stream
+           (stream-element-type input-stream)
+           (stream-element-type output-stream)))
+  (unless (equal (stream-external-format input-stream)
+                 (stream-external-format output-stream))
+    (error "~S: the external-formats of the input stream ~S and the output stream ~S are not equal."
+           'make-two-way-stream
+           (stream-external-format input-stream)
+           (stream-external-format output-stream)))
+  (make-instance 'two-way-stream
+      :open-p t
+      :input-p t
+      :output-p t
+      :element-type (stream-element-type input-stream)
+      :external-format (stream-external-format input-stream)
+      :input-stream input-stream
+      :output-stream output-stream))
+
+
+(define-forward two-way-stream-input-stream (two-way-stream)
+  (declare (stream-argument two-way-stream)
+           (check-stream-type two-way-stream)))
+
+
+(define-forward two-way-stream-output-stream (two-way-stream)
+  (declare (stream-argument two-way-stream)
+           (check-stream-type two-way-stream)))
+
+
+(define-stream-methods two-way-stream
+    (read-byte        (read-byte (%two-way-stream-input-stream stream)
+                                 eof-error-p eof-value))
+  (read-char        (read-char (%two-way-stream-input-stream stream)
+                               eof-error-p eof-value))
+  (write-byte       (write-byte (%two-way-stream-output-stream stream)))
+  (write-char       (write-char (%two-way-stream-output-stream stream)))
+  (two-way-stream-input-stream  (%two-way-stream-input-stream  two-way-stream))
+  (two-way-stream-output-stream (%two-way-stream-output-stream two-way-stream)))
+
+
+;;;; THE END ;;;;
diff --git a/utility.lisp b/utility.lisp
new file mode 100644
index 0000000..6b06173
--- /dev/null
+++ b/utility.lisp
@@ -0,0 +1,154 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               utility.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This file defines a few utilities.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-15 <PJB> Extracted from 'virtual-fs.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+
+
+(defun proper-list-p (object)
+  (labels ((proper (current slow)
+             (cond ((null current)       t)
+                   ((atom current)       nil)
+                   ((null (cdr current)) t)
+                   ((atom (cdr current)) nil)
+                   ((eq current slow)    nil)
+                   (t                    (proper (cddr current) (cdr slow))))))
+    (proper object (cons nil object))))
+
+(defun test-proper-list-p ()
+  (assert
+   (every
+    (function identity)
+    (mapcar (lambda (test) (eq (first test) (proper-list-p (second test))))
+            '((nil x)
+              (t ())
+              (t (a))
+              (t (a b))
+              (t (a b c))
+              (t (a b c d))
+              (nil (a . x))
+              (nil (a b . x))
+              (nil (a b c . x))
+              (nil (a b c d . x))
+              (nil #1=(a . #1#))
+              (nil #2=(a b . #2#))
+              (nil #3=(a b c . #3#))
+              (nil #4=(a b c d . #4#))
+              (nil (1 . #1#))
+              (nil (1 2 . #1#))
+              (nil (1 2 3 . #1#))
+              (nil (1 2 3 4 . #1#))
+              (nil (1 . #2#))
+              (nil (1 2 . #2#))
+              (nil (1 2 3 . #2#))
+              (nil (1 2 3 4 . #2#))
+              (nil (1 . #3#))
+              (nil (1 2 . #3#))
+              (nil (1 2 3 . #3#))
+              (nil (1 2 3 4 . #3#))
+              (nil (1 . #4#))
+              (nil (1 2 . #4#))
+              (nil (1 2 3 . #4#))
+              (nil (1 2 3 4 . #4#)))))))
+
+
+(defun unsplit-string (string-list &optional (separator " "))
+  "
+DO:         The inverse than split-string.
+            If no separator is provided then a simple space is used.
+SEPARATOR:  (OR NULL STRINGP CHARACTERP)
+"
+  (check-type separator (or string character symbol) "a string designator.")
+  (if string-list
+      (cl:with-output-to-string (cl:*standard-output*)
+        (cl:princ (pop string-list))
+        (dolist (item string-list)
+          (cl:princ separator) (cl:princ item)))
+      ""))
+
+
+
+(defun assert-type (datum expected-type)
+  "
+DO:     Signal a TYPE-ERROR if DATUM is not of the EXPECTED-TYPE.
+NOTICE: CHECK-TYPE signals a PROGRAM-ERROR.
+"
+  (or (typep datum expected-type)
+      (error (make-condition 'type-error
+                             :datum datum :expected-type expected-type))))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; regular expressions
+;;;
+
+(defun re-compile (re &key extended)
+  #+clisp
+  (regexp:regexp-compile   re :extended      extended)
+  #+(and (not clisp) cl-ppcre)
+  (cl-ppcre:create-scanner re :extended-mode extended)
+  #-(or clisp cl-ppcre)
+  (error "Please implement RE-COMPILE"))
+
+(defun re-exec (re string)
+  #+clisp
+  (regexp:regexp-exec re string)
+  #+(and (not clisp) cl-ppcre)
+  (multiple-value-bind (start end starts ends) (cl-ppcre:scan re string)
+    (and start end
+         (values-list  (cons (cons start end)
+                             (map 'list (lambda (s e)
+                                          (if (or s e)
+                                              (cons s e)
+                                              nil))
+                                  starts ends)))))
+  #-(or clisp cl-ppcre)
+  (error "Please implement RE-EXEC"))
+
+(defun re-match-string (string match)
+  #+clisp
+  (regexp:match-string string match)
+  #+(and (not clisp) cl-ppcre)
+  (subseq string (car match) (cdr match))
+  #-(or clisp cl-ppcre)
+  (error "Please implement RE-MATCH-STRING"))
+
+(defun re-match (regexp string)
+  (re-exec (re-compile regexp :extended t) string))
+
+
+;;;; THE END ;;;;
diff --git a/vfs-file-stream.lisp b/vfs-file-stream.lisp
new file mode 100644
index 0000000..655e81d
--- /dev/null
+++ b/vfs-file-stream.lisp
@@ -0,0 +1,411 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               vfs-file-stream.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This file defines the file stream operators
+;;;;    for the Virtual File System backend.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-01-14 <PJB> Extracted from 'virtual-fs.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM")
+
+
+(defclass file-stream (stream)
+  ((pathname   :accessor pathname
+               :initarg :pathname)
+   (file       :accessor %file-stream-file
+               :initarg :file)
+   (contents   :accessor %file-stream-contents
+               :initarg :contents)
+   (position   :accessor %file-stream-position
+               :initarg :position
+               :initform 0
+               :type    (integer 0))
+   (override-p :accessor %override-p
+               :initarg  :override-p)))
+
+
+(defclass file-input-stream (file-stream)
+  ())
+
+(defclass file-output-stream (file-stream)
+  ())
+
+(defclass file-io-stream (file-input-stream  file-output-stream)
+  ())
+
+
+(defmethod print-object-fields ((self file-stream) stream)
+  (call-next-method)
+  (format stream " :PATHNAME ~S :POSITION ~A"
+          (pathname self) (%file-stream-position self)))
+
+
+(defmethod print-object ((self file-stream) stream)
+  (print-unreadable-object (self stream :type nil :identity t)
+    (format stream "~A" 'file-stream)
+    (print-object-fields self stream))
+  self)
+
+
+(define-stream-methods file-stream
+    (stream-external-format (%stream-external-format stream))
+  (file-length   (length (contents (%file-stream-contents stream))))
+  (file-string-length
+   (etypecase object
+     (character 1)
+     (string    (length object))))
+  (close
+   (prog1 (%open-stream-p stream)
+     (when (%open-stream-p stream)
+       (setf (%open-stream-p stream) nil)
+       (when (%override-p stream)
+         (let* ((path (pathname stream))
+                (dir   (directory-entry path)))
+           (delete-file path)
+           (add-entry dir (%file-stream-file stream))))))))
+
+
+
+
+
+(defun open (filespec &key (direction :input)
+             (element-type 'character)
+             (if-exists nil)
+             (if-does-not-exist nil)
+             (external-format :default))
+
+  (check-type direction (member :input :output :io :probe))
+  (check-type if-exists (member :error :new-version :rename :rename-and-delete
+                                :overwrite :append :supersede nil))
+  (check-type if-does-not-exist (member :error :create nil))
+  (check-type external-format (member :default))
+
+  ;; (error "Not implemented yet")
+
+  (let ((path (resolve-pathspec filespec)))
+    (labels ((make-stream (file openp inputp outputp overridep position)
+               (let* ((contents (newest file)))
+                 (make-instance (if inputp
+                                    (if outputp
+                                        'file-io-stream
+                                        'file-input-stream)
+                                    (if outputp
+                                        'file-output-stream
+                                        'file-stream))
+                     :open-p openp
+                     :element-type (element-type contents)
+                     :external-format :default ; ???
+                     :input-p inputp
+                     :output-p outputp
+                     :override-p overridep
+                     :pathname (truename path)
+                     :file file
+                     :contents contents
+                     :position (ecase position
+                                 (:start 0)
+                                 (:end   (length (contents contents)))))))
+
+             (new-file (path element-type)
+               (create-file-at-path path :create-version-p t :element-type element-type))
+
+             (new-file/unlinked (path element-type)
+               (let ((entry (make-instance 'fs-file
+                                :name (pathname-name path) :type (pathname-type path))))
+                 (create-new-version entry :element-type element-type)
+                 entry))
+
+             (new-version (file element-type)
+               (create-new-version file :element-type element-type))
+
+             (copy-new-version (contents)
+               (let ((new-contents (newest (create-new-version (file contents)
+                                                               :element-type (element-type contents)))))
+                 (setf (contents new-contents) (copy-array (contents contents)
+                                                           :copy-fill-pointer t
+                                                           :copy-adjustable t))
+                 (file new-contents)))
+
+             (rename-old (file &optional (index 0))
+               (let ((old (make-pathname :type (format nil "~A-OLD-~3,'0D"
+                                                       (pathname-type file)
+                                                       (incf index))
+                                         :defaults file)))
+                 (if (file-entry old)
+                     (rename-old file index)
+                     (rename-file file old)))))
+
+      (let ((contents (file-entry path)))
+
+       ;; filespec  ¬N.T     ¬N.T.3<NEWEST ¬N.T.3>NEWEST  N.T.3=NEWEST  N.T.3<NEWEST
+       ;;   N.T     no exist     newest        newest       newest         newest
+       ;;   N.T.3   no exist     no exist      no exist     newest      old version
+       ;;                     create newest  create newest
+       (ecase direction
+
+         ((:input :probe)
+          (if contents
+              (progn
+                ;; TODO: use CERROR to ignre the requested element-type
+                (assert (equal (element-type contents) element-type)
+                        () "~A: the element-type requested ~S must be identical to the element-type ~S of the file ~S"
+                        'open element-type (element-type contents)  path)
+                (make-stream (file contents) (eql direction :input) t nil  nil :start))
+              (ecase if-does-not-exist
+                ((:error)
+                 (error (make-condition
+                         'simple-file-error
+                         :pathname path
+                         :format-control "~A: file ~S does not exist"
+                         :format-arguments (list 'open path))))
+                ((:create)
+                 (make-stream (new-file path element-type) (eql direction :input) t nil  nil :start))
+                ((nil)
+                 (return-from open nil)))))
+
+
+         ((:output :io)
+          (if contents
+              ;; file exists:
+              (ecase if-exists
+                ((:error)
+                 (error (make-condition
+                         'simple-file-error
+                         :pathname path
+                         :format-control "~A: file ~S already exists"
+                         :format-arguments (list 'open path))))
+                ((:new-version)
+                 (make-stream (new-version (file contents) element-type)
+                              t (eql direction :io) t  nil :start))
+                ((:rename)
+                 (rename-old path)
+                 (make-stream (new-file path element-type)
+                              t (eql direction :io) t  nil :start))
+                ((:rename-and-delete)
+                 (let ((old nil))
+                   (unwind-protect
+                        (progn
+                          (setf old (rename-old path))
+                          (make-stream (new-file path element-type)
+                                       t (eql direction :io) t  nil :start))
+                     (when old
+                       (delete-file old)))))
+                ((:overwrite)
+                 (make-stream (if (eql contents (newest (file contents)))
+                                  (file contents)
+                                  (copy-new-version contents))
+                              t (eql direction :io) t nil :start))
+                ((:append)
+                 (make-stream (if (eql contents (newest (file contents)))
+                                  (file contents)
+                                  (copy-new-version contents))
+                              t (eql direction :io) t nil :end))
+                ((:supersede)
+                 (make-stream (new-file/unlinked path element-type)
+                              t (eql direction :io) t  nil :start))
+                ((nil)
+                 (return-from open nil)))
+              ;; file does not exist:
+              (ecase if-does-not-exist
+                ((:error)
+                 (error (make-condition
+                         'simple-file-error
+                         :pathname path
+                         :format-control "~A: file ~S does not exist"
+                         :format-arguments (list 'open path))))
+                ((:create)
+                 (make-stream (new-file path element-type) t (eql direction :io) t  t :start))
+                ((nil)
+                 (return-from open nil))))))))))
+
+
+
+
+
+(defun  !read-element (stream eof-error-p eof-value)
+  (with-accessors ((contents %file-stream-contents)
+                   (position %file-stream-position)) stream
+    (if (< position (length (contents contents)))
+        (aref (contents contents) (prog1 position (incf position)))
+        (if eof-error-p
+            (error 'end-of-file :stream stream)
+            eof-value))))
+
+
+(defun !write-element (stream sequence start end)
+  (with-accessors ((contents %file-stream-contents)
+                   (position %file-stream-position)) stream
+    (let* ((end          (or end (length sequence)))
+           (size         (- end start))
+           (new-position (+ position size))
+           (data         (contents contents)))
+      (if (< new-position *maximum-file-size*)
+          (progn
+            (unless (< new-position (array-dimension data 0))
+              (setf data (adjust-array data
+                                       (max new-position (* 2 (array-dimension data 0)))
+                                       :element-type (array-element-type data)
+                                       :initial-element (if (subtypep (array-element-type data)
+                                                                      'character)
+                                                            #\space
+                                                            0)
+                                       :fill-pointer (fill-pointer data))
+                    (contents contents) data))
+            (when (< (fill-pointer data) new-position)
+              (setf (fill-pointer data) new-position))
+            (replace data sequence :start1 position :start2 start :end2 end)
+            (setf position new-position))
+          (error 'simple-stream-error
+                     :stream stream
+                     :format-control "data too big to be written on stream ~S (~A+~A=~A>~A)"
+                     :format-arguments (list stream
+                                             position size new-position *maximum-file-size*))))))
+
+(defun whitespacep (ch)
+  (position  ch #(#\Space #\Newline #\Tab #\Linefeed #\Page #\Return)))
+
+
+(define-stream-methods file-input-stream
+    (file-position
+     (call-next-method)
+     (with-accessors ((contents %file-stream-contents)
+                      (position %file-stream-position)) stream
+       (if position-spec
+           (if (< -1 position-spec (length (contents contents)))
+               (setf position position-spec)
+               (error 'simple-stream-error
+                      :stream stream
+                      :format-control "~A: invalid position ~A on stream ~S"
+                      :format-arguments (list 'file-position position-spec stream))))
+       position))
+
+  (read-byte         (!read-element       stream eof-error-p eof-value))
+  (read-char         (!read-element input-stream eof-error-p eof-value))
+  (read-char-no-hang (!read-element input-stream eof-error-p eof-value))
+  (peek-char
+   (flet ((eof ()
+            (if eof-error-p
+                (error 'end-of-file :stream stream)
+                eof-value)))
+     (with-accessors ((contents %file-stream-contents)
+                      (position %file-stream-position)) stream
+       (case peek-type
+         ((nil))
+         ((t)
+          (setf position (or (position-if-not (function whitespacep)
+                                              (contents contents)
+                                              :start position)
+                             (length (contents contents)))))
+         (otherwise
+          (setf position (or (position peek-type
+                                       (contents contents)
+                                       :start position)
+                             (length (contents contents))))))
+       (if (< position (length (contents contents)))
+           (aref (contents contents) position)
+           (eof)))))
+  (unread-char
+   (with-accessors ((contents %file-stream-contents)
+                    (position %file-stream-position)) input-stream
+     (when (plusp position)
+       (decf position))))
+  (read-line
+   (with-accessors ((contents %file-stream-contents)
+                    (position %file-stream-position)) input-stream
+     (let ((start position)
+           (end   (or (position #\newline (contents contents) :start position)
+                      (length (contents contents)))))
+       (prog1 (subseq (contents contents) start (if (< end (length (contents contents)))
+                                                    (1- end)
+                                                    end))
+         (setf position end)))))
+  (read-sequence
+   (with-accessors ((contents %file-stream-contents)
+                    (position %file-stream-position)) stream
+     (let ((start position)
+           (end   (or (position #\newline (contents contents) :start position)
+                      (length (contents contents)))))
+       (prog1 (subseq (contents contents) start (if (< end (length (contents contents)))
+                                                    (1- end)
+                                                    end))
+         (setf position end)))))
+  (listen
+   (with-accessors ((contents %file-stream-contents)
+                    (position %file-stream-position)) input-stream
+     (< position (length (contents contents)))))
+  (clear-input
+   #|nothing|#
+   nil))
+
+
+(defvar *newline* (string #\newline))
+
+(define-stream-methods file-output-stream
+    (file-position
+     (call-next-method)
+     (with-accessors ((contents %file-stream-contents)
+                      (position %file-stream-position)) stream
+       (if position-spec
+           (if (< -1 position-spec *maximum-file-size*)
+               (setf position position-spec)
+               (error 'simple-stream-error
+                      :stream stream
+                      :format-control "~A: invalid position ~A on stream ~S"
+                      :format-arguments (list 'file-position position-spec stream))))
+       position))
+
+  (write-byte     (!write-element stream        (vector byte)      0 1)
+                  byte)
+  (write-char     (!write-element output-stream (string character) 0 1)
+                  character)
+  (terpri         (!write-element output-stream *newline*          0 (length *newline*))
+                  nil)
+  (fresh-line     (with-accessors ((contents %file-stream-contents)
+                                   (position %file-stream-position)) stream
+                    (unless (and (plusp position)
+                                 (char= #\newline (aref (contents contents) (1- position))))
+                      (!write-element output-stream *newline*  0 (length *newline*))
+                      #\newline)))
+  (write-string   (!write-element output-stream string start end)
+                  string)
+  (write-line     (!write-element output-stream string start end)
+                  (!write-element output-stream *newline* 0 (length *newline*))
+                  string)
+  (write-sequence (!write-element stream sequence start end)
+                  sequence)
+  (clear-output   #|nothing|# nil)
+  (force-output   #|nothing|# nil)
+  (finish-output  #|nothing|# nil))
+
+
+;;;; THE END ;;;;
+
diff --git a/vfs-packages.lisp b/vfs-packages.lisp
index 8c65fd2..996adc1 100644
--- a/vfs-packages.lisp
+++ b/vfs-packages.lisp
@@ -34,6 +34,8 @@
 ;;;;    Boston, MA 02111-1307 USA
 ;;;;**************************************************************************

+(in-package "COMMON-LISP-USER")
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defparameter *redefined-symbols*
     '(
@@ -97,5 +99,4 @@
    . #.*redefined-symbols*))


-
 ;;;; THE END ;;;;
diff --git a/virtual-fs-test.lisp b/virtual-fs-test.lisp
index deef760..23501f2 100644
--- a/virtual-fs-test.lisp
+++ b/virtual-fs-test.lisp
@@ -618,7 +618,9 @@

 (let ((path #P"HOME:TEST.TEXT")
       (path #P"HOME:EXAMPLE.TEXT"))
- (defparameter *s* (open path :direction :output :if-exists :new-version
+ (defparameter *s* (open path :direction :output
+                         :if-exists :new-version
+                         :if-does-not-exist :create
                          :element-type 'base-char))
  (write-char   #\* *s*)
  (print (file-length *s*))
@@ -656,7 +658,8 @@


 (progn
-  (defparameter *s* (open "HOME:EXAMPLE.TEXT" :direction :input))
+  (defparameter *s* (open "HOME:EXAMPLE.TEXT" :direction :input
+                          :element-type 'base-char))
   (prog1 (read-line *s*)
     (close *s*)
     (vfs::dump (vfs::file-system-named "HOME"))))
@@ -676,3 +679,23 @@
 (setf (logical-pathname-translations "LISP") (list (list #P"LISP:**;*.*.*" #P"HOME:SRC;LISP;**;*.*.*")
                                                    (list #P"LISP:**;*.*"   #P"HOME:SRC;LISP;**;*.*")
                                                    (list #P"LISP:**;*"     #P"HOME:SRC;LISP;**;*")))
+
+
+(let ((path #P"LISP:TEST.LISP"))
+  (defparameter *s* (open path :direction :output
+                          :if-exists :new-version
+                          :if-does-not-exist :create))
+  (write-line ";;;; -*- mode:lisp -*-" *s*)
+  (write-string (prin1-to-string '(defun test (arg)
+                                   (princ "Hello Test!") (terpri)
+                                   (princ arg) (terpri)
+                                   (princ "Done here." (terpri)
+                                    arg)))
+                *s*)
+  (terpri *s*)
+  (print (file-length *s*))
+  (close *s*)
+  (terpri)
+  (finish-output)
+  (vfs::dump (vfs::file-system-named "HOME")))
+(vfs::dump-pathname  #P"LISP:TEST.LISP")
diff --git a/virtual-fs.lisp b/virtual-fs.lisp
index fb1b22b..e65c545 100644
--- a/virtual-fs.lisp
+++ b/virtual-fs.lisp
@@ -1,4 +1,4 @@
-;;;; -*- package: COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM -*-
+;;;; -*- mode:lisp;coding:utf-8 -*-
 ;;;;**************************************************************************
 ;;;;FILE:               virtual-fs.lisp
 ;;;;LANGUAGE:           Common-Lisp
@@ -6,7 +6,7 @@
 ;;;;USER-INTERFACE:     NONE
 ;;;;DESCRIPTION
 ;;;;
-;;;;    This package implements a RAM based virtual file system.
+;;;;    This file implements a RAM based virtual file system.
 ;;;;
 ;;;;AUTHORS
 ;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
@@ -43,706 +43,6 @@
 (defvar *maximum-file-size* (* 1024 1024)
   "Maximum virtual file size.")

-
-(defun proper-list-p (object)
-  (labels ((proper (current slow)
-             (cond ((null current)       t)
-                   ((atom current)       nil)
-                   ((null (cdr current)) t)
-                   ((atom (cdr current)) nil)
-                   ((eq current slow)    nil)
-                   (t                    (proper (cddr current) (cdr slow))))))
-    (proper object (cons nil object))))
-
-(defun test-proper-list-p ()
-  (assert
-   (every
-    (function identity)
-    (mapcar (lambda (test) (eq (first test) (proper-list-p (second test))))
-            '((nil x)
-              (t ())
-              (t (a))
-              (t (a b))
-              (t (a b c))
-              (t (a b c d))
-              (nil (a . x))
-              (nil (a b . x))
-              (nil (a b c . x))
-              (nil (a b c d . x))
-              (nil #1=(a . #1#))
-              (nil #2=(a b . #2#))
-              (nil #3=(a b c . #3#))
-              (nil #4=(a b c d . #4#))
-              (nil (1 . #1#))
-              (nil (1 2 . #1#))
-              (nil (1 2 3 . #1#))
-              (nil (1 2 3 4 . #1#))
-              (nil (1 . #2#))
-              (nil (1 2 . #2#))
-              (nil (1 2 3 . #2#))
-              (nil (1 2 3 4 . #2#))
-              (nil (1 . #3#))
-              (nil (1 2 . #3#))
-              (nil (1 2 3 . #3#))
-              (nil (1 2 3 4 . #3#))
-              (nil (1 . #4#))
-              (nil (1 2 . #4#))
-              (nil (1 2 3 . #4#))
-              (nil (1 2 3 4 . #4#)))))))
-
-
-(defun unsplit-string (string-list &optional (separator " "))
-  "
-DO:         The inverse than split-string.
-            If no separator is provided then a simple space is used.
-SEPARATOR:  (OR NULL STRINGP CHARACTERP)
-"
-  (check-type separator (or string character symbol) "a string designator.")
-  (if string-list
-      (with-output-to-string (*standard-output*)
-        (princ (pop string-list))
-        (dolist (item string-list)
-          (princ separator) (princ item)))
-      ""))
-
-
-
-(defun assert-type (datum expected-type)
-  "
-DO:     Signal a TYPE-ERROR if DATUM is not of the EXPECTED-TYPE.
-NOTICE: CHECK-TYPE signals a PROGRAM-ERROR.
-"
-  (or (typep datum expected-type)
-      (error (make-condition 'type-error
-                             :datum datum :expected-type expected-type))))
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; regular expressions
-;;;
-
-(defun re-compile (re &key extended)
-  #+clisp
-  (regexp:regexp-compile   re :extended      extended)
-  #+(and (not clisp) cl-ppcre)
-  (cl-ppcre:create-scanner re :extended-mode extended)
-  #-(or clisp cl-ppcre)
-  (error "Please implement RE-COMPILE"))
-
-(defun re-exec (re string)
-  #+clisp
-  (regexp:regexp-exec re string)
-  #+(and (not clisp) cl-ppcre)
-  (multiple-value-bind (start end starts ends) (cl-ppcre:scan re string)
-    (and start end
-         (values-list  (cons (cons start end)
-                             (map 'list (lambda (s e)
-                                          (if (or s e)
-                                              (cons s e)
-                                              nil))
-                                  starts ends)))))
-  #-(or clisp cl-ppcre)
-  (error "Please implement RE-EXEC"))
-
-(defun re-match-string (string match)
-  #+clisp
-  (regexp:match-string string match)
-  #+(and (not clisp) cl-ppcre)
-  (subseq string (car match) (cdr match))
-  #-(or clisp cl-ppcre)
-  (error "Please implement RE-MATCH-STRING"))
-
-(defun re-match (regexp string)
-  (re-exec (re-compile regexp :extended t) string))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 19. Filenames
-;;; http://www.lispworks.com/documentation/HyperSpec/Body/19_.htm
-
-(define-condition simple-file-error (file-error simple-error)
-  ()
-  (:report (lambda (condition stream)
-             (format stream "~?"
-                     (simple-condition-format-control condition)
-                     (simple-condition-format-arguments condition)))))
-
-
-
-(defparameter *logical-pathname-regexp*
-  (let ((host "(([-A-Z0-9]+):)?")
-        (dire "(;)?(([-*A-Z0-9]+;|\\*\\*;)*)")
-        (name "([-*A-Z0-9]+)?")
-        (type "(.([-*A-Z0-9]+)(.([0-9]+|newest|NEWEST|\\*))?)?"))
-    (re-compile (concatenate 'string "^" host dire name type "$")
-                :extended t)))
-
-(defun parse-logical-pathname (string)
-  (flet ((wild (item part wild-inferiors-p)
-           (cond ((string= "*"  item) :wild)
-                 ((and wild-inferiors-p (string= "**" item)) :wild-inferiors)
-                 ((search  "**" item)
-                  (error "Invalid ~A part: ~S; ~
-                                \"**\" inside a wildcard-world is forbidden."
-                         part item))
-                 ((position #\* item) (list :wild-word item))
-                 (t item))))
-    (multiple-value-bind (all
-                          dummy0 host
-                          relative directories dummy1
-                          name
-                          dummy2 type dummy3 version)
-        (re-exec *logical-pathname-regexp* string)
-      (if all
-          (list (and host        (re-match-string string host))
-                (if relative :relative :absolute)
-                (and directories
-                     (mapcar
-                      (lambda (item) (wild item "directory" t))
-                      (butlast (split-sequence #\; (re-match-string
-                                                    string directories)))))
-                (and name
-                     (let ((item (re-match-string string name)))
-                       (wild item "name" nil)))
-                (and type
-                     (let ((item (re-match-string string type)))
-                       (wild item "type" nil)))
-                (and version
-                     (let ((version (re-match-string string version)))
-                       (cond
-                         ((string= "*" version) :wild)
-                         ((string-equal "NEWEST" version) :newest)
-                         (t (parse-integer version :junk-allowed nil))))))
-          (error "Syntax error parsing pathname ~S" string)))))
-
-
-(defun match-wild-word-p (item wild)
-  (flet ((concat (type list)
-           (let* ((totlen  (reduce (lambda (length item) (+ (length item) length))
-                                   list :initial-value 0))
-                  (result  (cond
-                             ((or (eq type 'string)
-                                  (and (consp type) (eq 'string (first type))))
-                              (make-string totlen))
-                             ((or (eq type 'vector)
-                                  (and (consp type) (eq 'vector (first type)))
-                                  (eq type 'array)
-                                  (and (consp type) (eq 'array (first type))))
-                              (make-array totlen))
-                             ((eq type 'list)
-                              (make-list totlen))
-                             (t (error "Invalid sequence type: ~S" type)))))
-             (loop
-                :for item :in list
-                :and start = 0 :then (+ start (length item))
-                :do (replace result item :start1 start)
-                :finally (return result)))))
-    (re-match
-     (concat 'string
-             (cons "^"
-                   (nconc
-                    (loop
-                       :for chunks :on (split-sequence #\* wild)
-                       :collect (car chunks) :when (cdr chunks) :collect ".*")
-                    (list "$"))))
-     item)))
-
-
-;;;---------------------------------------------------------------------
-;;; PATHNAME
-;;;---------------------------------------------------------------------
-
-(defclass pathname ()
-  ((host      :accessor %pathname-host
-              :initarg :host
-              :initform nil)
-   (device    :accessor %pathname-device
-              :initarg :device
-              :initform :unspecific)
-   (directory :accessor %pathname-directory
-              :initarg :directory
-              :initform nil)
-   (name      :accessor %pathname-name
-              :initarg :name
-              :initform nil)
-   (type      :accessor %pathname-type
-              :initarg :type
-              :initform nil)
-   (version   :accessor %pathname-version
-              :initarg :version
-              :initform nil)))
-
-(defmethod print-object ((self pathname) stream)
-  (flet ((present-item (item)
-           (cond ((null item) item)
-                 ((listp item) (second item))
-                 ((eq :wild item) "*")
-                 ((eq :wild-inferiors item) "**")
-                 (t item))))
-    #+(or)
-    (dolist (s '(*print-array* *print-base* *print-case*
-                 *print-circle* *print-escape* *print-gensym* *print-length*
-                 *print-level* *print-lines* *print-miser-width*
-                 *print-pprint-dispatch* *print-pretty* *print-radix*
-                 *print-readably* *print-right-margin*))
-      (format t "~A = ~A~%" s (symbol-value s)))
-    (format stream "~:[~;#P\"~]~A:~:[~;;~]~{~A;~}~:[~;~:*~A~]~
-                    ~:[~;.~:*~A~:[~;.~:*~A~]~]~0@*~:[~;\"~]"
-            *print-escape*
-            (pathname-host self)
-            (eq :relative (first (pathname-directory self)))
-            (mapcar (function present-item) (rest (pathname-directory self)))
-            (present-item (pathname-name self))
-            (present-item (pathname-type self))
-            (present-item (pathname-version self))))
-  self)
-
-
-(defun print-pathname (pathname)
-  (with-accessors ((host pathname-host)
-                   (device pathname-device)
-                   (directory pathname-directory)
-                   (name pathname-name)
-                   (type pathname-type)
-                   (version pathname-version)) pathname
-    (format t "~A~%~{~10A: ~S~%~}"
-            (class-name (class-of pathname))
-            (list :host host
-                  :device device
-                  :directory directory
-                  :name name
-                  :type type
-                  :version version))))
-
-
-(defmacro define-pathname-attribute (name)
-  `(defun ,(intern (format nil "PATHNAME-~A" name))
-       (pathname &key (case :local))
-     (,(intern (format nil "%PATHNAME-~A" name)) (pathname pathname))))
-
-(define-pathname-attribute host)
-(define-pathname-attribute device)
-(define-pathname-attribute directory)
-(define-pathname-attribute name)
-(define-pathname-attribute type)
-(define-pathname-attribute version)
-
-#||
-
-Pathname Host Component
-
-The name of the file system on which the file resides, or the name
-of a logical host.
-
-
-Pathname Device Component
-
-Corresponds to the ``device'' or ``file structure'' concept in
-many host file systems: the name of a logical or physical device
-containing files.
-
-
-Pathname Directory Component
-
-Corresponds to the ``directory'' concept in many host file
-systems: the name of a group of related files.
-
-
-Pathname Name Component
-
-The ``name'' part of a group of files that can be thought of as
-conceptually related.
-
-
-Pathname Type Component
-
-Corresponds to the ``filetype'' or ``extension'' concept in many
-host file systems. This says what kind of file this is. This
-component is always a string, nil, :wild, or :unspecific.
-
-
-Pathname Version Component
-
-Corresponds to the ``version number'' concept in many host file systems.
-
-The version is either a positive integer or a symbol from the
-following list: nil, :wild, :unspecific, or :newest (refers to the
-largest version number that already exists in the file system when
-reading a file, or to a version number greater than any already
-existing in the file system when writing a new
-file). Implementations can define other special version symbols.
-
-||#
-
-
-(defclass logical-pathname (pathname)
-  ())
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 21. Streams
-;;; http://www.lispworks.com/documentation/HyperSpec/Body/21_.htm
-
-(define-condition simple-stream-error (stream-error simple-error)
-  ()
-  (:report (lambda (condition stream)
-             (format stream "~?"
-                     (simple-condition-format-control condition)
-                     (simple-condition-format-arguments condition)))))
-
-;;;---------------------------------------------------------------------
-;;; STREAM
-;;;---------------------------------------------------------------------
-
-(defclass stream ()
-  ((open-p          :accessor %open-stream-p
-                    :initarg  :open-p)
-   (element-type    :accessor %stream-element-type
-                    :initarg  :element-type
-                    :initform 'character)
-   (external-format :accessor %stream-external-format
-                    :initarg  :external-format
-                    :initform :default)
-   (input-p         :accessor %input-stream-p
-                    :initarg  :input-p)
-   (output-p        :accessor %output-stream-p
-                    :initarg  :output-p)))
-
-
-(defclass broadcast-stream (stream)
-  ((streams :accessor %broadcast-stream-streams
-            :initarg :streams
-            :initform nil)))
-
-(defclass concatenated-stream (stream)
-  ((streams :accessor %concatenated-stream-streams
-            :initarg :streams
-            :initform nil)))
-
-(defclass echo-stream (stream)
-  ((input-stream  :accessor %echo-stream-input-stream
-                  :initarg :input-stream
-                  :initform nil)
-   (output-stream :accessor %echo-stream-output-stream
-                  :initarg :output-stream
-                  :initform nil)))
-
-(defclass file-stream (stream)
-  ((pathname   :accessor pathname
-               :initarg :pathname)
-   (file       :accessor %file-stream-file
-               :initarg :file)
-   (contents   :accessor %file-stream-contents
-               :initarg :contents)
-   (position   :accessor %file-stream-position
-               :initarg :position
-               :initform 0
-               :type    (integer 0))
-   (override-p :accessor %override-p
-               :initarg  :override-p)))
-
-(defclass file-input-stream (file-stream)
-  ())
-
-(defclass file-output-stream (file-stream)
-  ())
-
-(defclass file-io-stream (file-input-stream  file-output-stream)
-  ())
-
-(defclass string-stream (stream)
-  ())
-
-(defclass string-input-stream (string-stream)
-  ((string :accessor %string-stream-input-string
-           :initarg :string
-           :initform ""
-           :type     string)
-   (index  :accessor %string-stream-index
-           :initarg :index
-           :initform 0
-           :type (integer 0))
-   (start  :accessor %string-stream-start
-           :initarg :start
-           :initform 0
-           :type (integer 0))
-   (end    :accessor %string-stream-end
-           :initarg :end
-           :initform nil
-           :type (or null (integer 0)))))
-
-(defclass string-output-stream (string-stream)
-  ((string :accessor %string-stream-output-string
-           :initarg :string
-           :initform (make-array 8
-                                 :fill-pointer 0 :adjustable t
-                                 :element-type 'character)
-           :type     string)))
-
-(defclass synonym-stream (stream)
-  ((symbol  :accessor %synonym-stream-symbol
-            :initarg :symbol)))
-
-(defclass two-way-stream (stream)
-  ((input-stream  :accessor %two-way-stream-input-stream
-                  :initarg :input-stream
-                  :initform nil)
-   (output-stream :accessor %two-way-stream-output-stream
-                  :initarg :output-stream
-                  :initform nil)))
-
-
-
-(defclass cl-stream (stream)
-  ((stream :accessor cl-stream-stream
-           :initarg :cl-stream)))
-
-(defun cl-stream (stream)  (make-instance 'cl-stream :cl-stream stream))
-(defparameter *debug-io*        (cl-stream cl:*debug-io*))
-(defparameter *error-output*    (cl-stream cl:*error-output*))
-(defparameter *trace-output*    (cl-stream cl:*trace-output*))
-(defparameter *standard-output* (cl-stream cl:*standard-output*))
-(defparameter *standard-input*  (cl-stream cl:*standard-input*))
-(defparameter *terminal-io*     (cl-stream cl:*terminal-io*))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 19. Filenames
-;;; http://www.lispworks.com/documentation/HyperSpec/Body/19_.htm
-
-
-(defmethod pathname ((pathspec t))
-  (assert-type pathspec '(or string file-stream pathname)))
-
-(defmethod pathname ((pathspec pathname))
-  (call-next-method)
-  pathspec)
-
-(defmethod pathname ((pathspec string))
-  (call-next-method)
-  (destructuring-bind (host relative directory name type version)
-      (parse-logical-pathname pathspec)
-    ;; (print (list host relative directory name type version))
-    (make-instance  (if (logical-pathname-translations host)
-                        'logical-pathname
-                        'pathname)
-        :host host :directory (cons relative directory)
-        :name name :type type :version version)))
-
-
-(defun install-pathname-reader-macro (&optional (readtable *readtable*))
-  (set-dispatch-macro-character #\# #\p
-                                (lambda (stream disp char)
-                                  (declare (ignore disp char))
-                                  (pathname (read stream t nil t)))
-                                readtable))
-
-
-(defun reset-readtable ()
-  (setq *readtable* (copy-readtable nil)))
-
-(defun check-host (host)
-  (cond
-    ((null host) (name *default-file-system*))
-    ((file-system-named host) host)
-    (t (error "Invalid host ~S" host))))
-
-(defun make-pathname (&key host device directory name type version (case :local)
-                      (defaults nil defaults-p))
-  (cond ((stringp directory)  (setf directory (list :absolute directory)))
-        ((eq :wild directory) (setf directory (list :absolute :wild-inferiors))))
-  (let ((host (check-host (or host (if defaults-p
-                                       (and defaults (pathname-host      defaults))
-                                       (pathname-host *default-pathname-defaults*))))))
-    (make-instance (if (logical-pathname-translations host)
-                       'logical-pathname
-                       'pathname)
-        :host        host
-        :device      (or device    (and defaults (pathname-device    defaults)))
-        :directory   (or directory (and defaults (pathname-directory defaults)))
-        :name        (or name      (and defaults (pathname-name      defaults)))
-        :type        (or type      (and defaults (pathname-type      defaults)))
-        :version     (or version   (and defaults (pathname-version   defaults))))))
-
-
-(defun pathnamep (object) (typep object 'pathname))
-
-
-
-(defparameter *logical-pathname-translations*
-  (make-hash-table :test (function equal)))
-
-(defun logical-pathname-translations (host)
-  (assert-type host 'string)
-  (gethash host *logical-pathname-translations*))
-
-(defun (setf logical-pathname-translations) (value host)
-  (assert-type host 'string)
-  (assert (and (proper-list-p value)
-               (every (lambda (item)
-                        (and (proper-list-p item)
-                             (typep (first  item) '(or string logical-pathname))
-                             (typep (second item) '(or string pathname))))
-                      value)))
-  (setf (gethash host  *logical-pathname-translations*) value))
-
-
-(defun load-logical-pathname-translations (host)
-  (assert-type host 'string)
-  (if (nth-value 1 (logical-pathname-translations host))
-      nil
-      (with-open-file (input (make-pathname :host "SYS"
-                                            :directory '(:absolute "SITE")
-                                            :name host
-                                            :type "TRANSLATIONS"
-                                            :version :newest)
-                             :if-does-not-exist nil)
-        (if input
-            (setf (logical-pathname-translations host) (read input nil nil))
-            (error "No logical pathname translation file found for host ~S"
-                   host)))))
-
-
-(defun logical-pathname (pathspec)
-  (warn "LOGICAL-PATHNAME is not implemented correctly.")
-  (pathname pathspec))
-
-
-(defun parse-namestring (thing &optional host
-                         (default-pathname *default-pathname-defaults*)
-                         &key (start 0) (end nil) (junk-allowed nil))
-  (when (typep thing 'file-stream)
-    (setf thing (pathname thing)))
-  (error "parse-namestring not implemented yet"))
-
-
-(defun wild-pathname-p (pathname &optional field-key)
-  (assert-type pathname '(or pathname string file-stream))
-  (setf pathname (pathname pathname))
-  (flet ((wild-p (item)
-           (or (eq item :wild)
-               (eq item :wild-inferiors)
-               (and (consp item)
-                    (eq (first item) :wild-word)))))
-    (if (null field-key)
-        (or (wild-pathname-p pathname :host)
-            (wild-pathname-p pathname :device)
-            (wild-pathname-p pathname :directory)
-            (wild-pathname-p pathname :name)
-            (wild-pathname-p pathname :type)
-            (wild-pathname-p pathname :version))
-        (ecase field-key
-          (:host    (wild-p (pathname-host    pathname)))
-          (:device  (wild-p (pathname-device  pathname)))
-          (:directory (some (function wild-p)
-                            (cdr (pathname-directory pathname))))
-          (:name    (wild-p (pathname-name    pathname)))
-          (:type    (wild-p (pathname-type    pathname)))
-          (:version (wild-p (pathname-version pathname)))))))
-
-
-
-
-
-
-
-
-(defun match-item-p (item wild &optional match-wild-word-p)
-  (or (eq wild :wild)
-      (and (consp wild) (eq (first wild) :wild-word)
-           match-wild-word-p (match-wild-word-p item (second wild)))
-      (eq item wild)
-      (and (stringp item) (stringp wild) (string= item wild))))
-
-(defun match-directory-items-p (item wild)
-  (or (null item wild)
-      (if (eq (first wild) :wild-inferiors)
-          (loop
-             :for rest :on item
-             :thereis (match-directory-items-p rest (rest wild)))
-          (and (match-item-p (first item) (first wild) t)
-               (match-directory-items-p (rest item) (rest wild))))))
-
-(defun pathname-match-p (pathname wildcard)
-  (assert-type pathname '(or pathname string file-stream))
-  (assert-type wildcard '(or pathname string file-stream))
-  (setf pathname (pathname pathname))
-  (setf wildcard (merge-pathnames (pathname wildcard)
-                                  (make-pathname
-                                   :host :wild
-                                   :device :wild
-                                   :directory :wild
-                                   :name :wild
-                                   :type :wild
-                                   :version :wild)))
-  (and (match-item-p (pathname-host    item) (pathname-host    wild) t)
-       (match-item-p (pathname-device  item) (pathname-device  wild) t)
-       (match-item-p (pathname-name    item) (pathname-name    wild) t)
-       (match-item-p (pathname-type    item) (pathname-type    wild) t)
-       (match-item-p (pathname-version item) (pathname-version wild) nil)
-       (or (and (eq :absolute (first (pathname-directory wild)))
-                (eq :relative (first (pathname-directory item)))
-                (eq :wild-inferiors (second  (pathname-directory wild))))
-           (and (eq (first (pathname-directory wild))
-                    (first (pathname-directory item)))
-                (match-directory-items-p (rest (pathname-directory item))
-                                         (rest (pathname-directory wild)))))))
-
-
-(defun translate-logical-pathname (pathname &key)
-  (warn "translate-logical-pathname not implemented yet")
-  (pathname pathname))
-
-
-(defun translate-pathname (source from-wildcard to-wildcard &key)
-  (error "translate-pathname not implemented yet"))
-
-
-(defun delete-back (dir)
-  (loop
-     :with changed = t
-     :while changed
-     :do (loop
-            :for cur = dir :then (cdr cur)
-            :initially (setf changed nil)
-            :do (when (and (or (stringp (cadr cur)) (eq :wild (cadr cur)))
-                           (eq :back (caddr cur)))
-                  (setf (cdr cur) (cdddr cur)
-                        changed t)))
-     :finally (return dir)))
-
-(defun merge-pathnames (pathname
-                        &optional (default-pathname *default-pathname-defaults*)
-                        (default-version :newest))
-  (setf pathname (pathname pathname))
-  (make-pathname
-   :host    (or (pathname-host pathname) (pathname-host default-pathname))
-   :device  (if (and (stringp (pathname-host pathname))
-                     (stringp (pathname-host default-pathname))
-                     (member (pathname-device pathname) '(:unspecific nil))
-                     (string= (pathname-host pathname)
-                              (pathname-host default-pathname)))
-                (pathname-device default-pathname)
-                (or (pathname-device pathname) :unspecific))
-   :directory (if (eq :relative (car (pathname-directory pathname)))
-                  (delete-back
-                   (append (pathname-directory default-pathname)
-                           (copy-list (cdr (pathname-directory pathname)))))
-                  (or (pathname-directory pathname)
-                      (pathname-directory default-pathname)))
-   :name    (or (pathname-name pathname) (pathname-name default-pathname))
-   :type    (or (pathname-type pathname) (pathname-type default-pathname))
-   :version (cond ((pathname-name pathname)
-                   (or (pathname-version pathname) default-version))
-                  ((null default-version)
-                   (pathname-version pathname))
-                  (t
-                   (or (pathname-version pathname)
-                       (pathname-version default-pathname))))))
-
-
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Internals: Memory based file systems.

@@ -752,7 +52,7 @@ file). Implementations can define other special version symbols.
 (deftype pathname-version () '(or file-version
                                (member nil :wild :unspecific :newest)))

-(defvar *dump-indent* "    |")
+(defvar *dump-indent* "    :")

 (defgeneric dump (object &OPTIONAL STREAM LEVEL)
   (:documentation "Dumps the OBJECT to *standard-output*."))
@@ -768,12 +68,10 @@ file). Implementations can define other special version symbols.
            :type (or null fs-directory)))
   (:documentation "Either a file, a directory or a whole file system."))

-(defmethod pathname ((self fs-item))
-  (error "PATHNAME not defined for the abstract class FS-ITEM"))

 (defmethod dump ((self fs-item)
                  &optional (stream *standard-output*) (level ""))
-  (format t "~A--> [ITM] ~S ### CANNOT DUMP SUCH AN ITEM~%" level self))
+  (format stream "~A--> [ITM] ~S ### CANNOT DUMP SUCH AN ITEM~%" level self))


 ;;;---------------------------------------------------------------------
@@ -804,9 +102,12 @@ file). Implementations can define other special version symbols.
              (dump v stream (concatenate 'string level *dump-indent*)))
            (entries self)))

-(defmethod select-entries ((self t) predicate)
+(defmethod select-entries ((self t) predicate)
+  (declare (ignorable self predicate))
   '())
+
 (defmethod select-entries ((self fs-directory) predicate)
+  (declare (ignorable predicate))
   (let ((result '()))
     (maphash (lambda (k v)
                (declare (ignore k))
@@ -824,6 +125,7 @@ file). Implementations can define other special version symbols.


 (defmethod entry-at-path ((self t) path)
+  (declare (ignorable path))
   (error "~S is not a directory" self))

 (defmethod entry-at-path ((self fs-directory) path)
@@ -965,17 +267,17 @@ DO: Delete only the specified version.

 (defmethod dump ((self file-contents)
                  &optional (stream *standard-output*) (level ""))
-  (format t "~A--> [VER] ~A ~((:AUTHOR ~S :WRITE-DATE ~S :ELEMENT-TYPE ~S :SIZE ~A)~)~%"
+  (format stream "~A--> [VER] ~A ~((:AUTHOR ~S :WRITE-DATE ~S :ELEMENT-TYPE ~S :SIZE ~A)~)~%"
           level (version self) (author self) (write-date self)
           (element-type self)
           (length (contents self))))


 ;;;---------------------------------------------------------------------
+;;; fs-file


-(defparameter *author*
-  (first (last (cl:pathname-directory (cl:user-homedir-pathname))))
+(defvar *author* nil
   "The name or identification of the user.")


@@ -1001,6 +303,9 @@ RETURN: The FS-FILE.
 ;;;---------------------------------------------------------------------
 ;;; FILE SYSTEM
 ;;;---------------------------------------------------------------------
+;;;
+;;; We initialize three file systems ROOT:, SYS: and HOME:.
+;;;

 (defclass file-system (fs-directory)
   ()
@@ -1009,14 +314,17 @@ RETURN: The FS-FILE.
 (defmethod pathname ((self file-system))
   (make-pathname :host (name self) :directory (list :absolute)))

+
 (defparameter *file-systems* (make-hash-table :test (function equal)))

+
 (defun file-system-register (fs)
   (setf (gethash (name fs) *file-systems*) fs))

 (defun file-system-named (name)
   (gethash name *file-systems*))

+
 (defparameter *default-file-system*
   (file-system-register (make-instance 'file-system :name "ROOT")))

@@ -1029,22 +337,6 @@ RETURN: The FS-FILE.
                  :defaults nil))


-(defun decompose-pathname (path)
-  (format t "~{~&HOST      = ~S~
-               ~&DEVICE    = ~S~
-               ~&DIRECTORY = ~S~
-               ~&NAME      = ~S~
-               ~&TYPE      = ~S~
-               ~&VERSION   = ~S~
-               ~&~}" (mapcar (lambda (f) (funcall f path))
-                             (list (function pathname-host)
-                                   (function pathname-device)
-                                   (function pathname-directory)
-                                   (function pathname-name)
-                                   (function pathname-type)
-                                   (function pathname-version)))))
-
-

 (defun resolve-pathspec (pathspec)
   (translate-logical-pathname (pathname pathspec)))
@@ -1079,7 +371,7 @@ RETURN: The FS-FILE.
   "
 RETURN: The FILE-CONTENTS specified by PATHSPEC (if no version is specified, NEWEST is returned).
 "
-  (let* ((file     (pathname pathspec))
+  (let* ((file     (resolve-pathspec pathspec))
          (dir      (directory-entry file))
          (entry    (entry-named dir (pathname-entry-name file))))
     (when entry
@@ -1094,7 +386,7 @@ RETURN: The FS-FILE created.
 NOTE:   If a FS-FILE existed at the given PATHSPEC, then it is returned,
         a new version being created if CREATE-VERSION-P is true.
 "
-  (let* ((file     (pathname pathspec))
+  (let* ((file     (resolve-pathspec pathspec))
          (dir      (directory-entry file))
          (entry    (entry-named dir (pathname-entry-name file))))
     (unless entry
@@ -1109,1441 +401,4 @@ NOTE:   If a FS-FILE existed at the given PATHSPEC, then it is returned,



-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 20. Files
-;;; http://www.lispworks.com/documentation/HyperSpec/Body/20_.htm
-
-(defun collapse-sequences-of-wild-inferiors (list)
-  (if (search '(:wild-inferiors :wild-inferiors) list)
-      (labels ((collapse (list)
-                 (cond ((null list) list)
-                       ((and (eq :wild-inferiors (first  list))
-                             (eq :wild-inferiors (second list)))
-                        (collapse (rest list)))
-                       (t (cons (first list) (collapse (rest list)))))))
-        (collapse list))
-      list))
-
-
-(defun collect (current dpath fspath)
-  (cond
-    ((null dpath)
-     (if (pathname-name fspath)
-         (let ((entries
-                (select-entries
-                 current
-                 (lambda (item)
-                   (and (typep item 'fs-file)
-                        (match-item-p (name item) (pathname-name fspath) t)
-                        (match-item-p (type item) (pathname-type fspath) t))))))
-           (if  (pathname-version fspath)
-                (mapcan (lambda (item)
-                          (select-versions
-                           item
-                           (lambda (version)
-                             (match-item-p (version version)
-                                           (pathname-version fspath) nil))))
-                        entries)
-                entries))
-         (list current)))
-    ((eq :wild-inferiors (car dpath))
-     (nconc (mapcan (lambda (item) (collect item dpath fspath))
-                    (select-entries current (constantly t)))
-            (mapcan (lambda (item) (collect item (rest dpath) fspath))
-                    (select-entries current (constantly t)))))
-    (t
-     (mapcan
-      (lambda (item) (collect item (rest dpath) fspath))
-      (select-entries
-       current
-       (lambda (item) (and (typep item 'fs-directory)
-                           (match-item-p (name item) (car dpath) t))))))))
-
-
-(defun directory (pathspec &key)
-  (let* ((fspath (resolve-pathspec pathspec))
-         (fs  (if (pathname-host fspath)
-                  (file-system-named (pathname-host fspath))
-                  *default-file-system*)))
-    (if fs
-        (let ((d (cdr (pathname-directory fspath))))
-          (mapcar (function pathname)
-                  (collect fs (collapse-sequences-of-wild-inferiors d) fspath)))
-        (error "Invalid host ~S"  (pathname-host fspath)))))
-
-
-(defun ensure-directories-exist (pathspec &key verbose)
-  (let* ((fspath (resolve-pathspec pathspec))
-         (fs  (if (pathname-host fspath)
-                  (file-system-named (pathname-host fspath))
-                  *default-file-system*))
-         (dir (if (pathname-name fspath)
-                  (pathname-directory fspath)
-                  (butlast (pathname-directory fspath)))))
-    (if fs
-        (values pathspec (create-directories-at-path fs (cdr dir)))
-        (error "There's no file system named ~S" (pathname-host fspath)))))
-
-
-(defun truename (filespec)
-  "
-RETURN:      The truename of the filespec.
-URL:         http://www.lispworks.com/documentation/HyperSpec/Body/f_tn.htm
-COMMON-LISP: truename tries to find the file indicated by filespec and
-             returns its truename.  If the filespec designator is an
-             open stream, its associated file is used.  If filespec is
-             a stream, truename can be used whether the stream is open
-             or closed.  It is permissible for truename to return more
-             specific information after the stream is closed than when
-             the stream was open.  If filespec is a pathname it
-             represents the name used to open the file.  This may be,
-             but is not required to be, the actual name of the file.
-"
-  (let ((filespec (pathname filespec)))
-    (if (wild-pathname-p filespec)
-        (error (make-condition 'simple-file-error
-                               :pathname filespec
-                               :format-control "~A: Filespec ~S is a wild pathname. "
-                               :format-arguments (list 'truename filespec)))
-        (let ((entry (file-entry filespec)))
-          (if entry
-              (pathname entry)
-              (error (make-condition 'simple-file-error
-                                     :pathname filespec
-                                     :format-control "~A: File ~S does not exist. "
-                                     :format-arguments (list 'truename filespec))))))))
-
-
-(defun probe-file (pathspec)
-  "
-RETURN:      the truename of the file or NIL.
-URL:         http://www.lispworks.com/documentation/HyperSpec/Body/f_probe_.htm
-COMMON-LISP: probe-file tests whether a file exists.
-
-             probe-file returns false if there is no file named
-             pathspec, and otherwise returns the truename of
-             pathspec.
-
-             If the pathspec designator is an open stream, then
-             probe-file produces the truename of its associated
-             file. If pathspec is a stream, whether open or closed, it
-             is coerced to a pathname as if by the  function pathname.
-"
-  (values (ignore-errors (truename pathspec))))
-
-
-
-(defun file-author       (path) (author       (file-entry (truename path))))
-(defun file-write-date   (path) (write-date   (file-entry (truename path))))
-(defun file-element-type (path) (element-type (file-entry (truename path))))
-
-(defmethod rename-entry ((self fs-file) newpath)
-  ;; rename the whole file
-  (when (ignore-errors (probe-file newpath))
-    (delete-file newpath))
-  (delete-entry self)
-  (setf (name self) (pathname-name newpath)
-        (type self) (pathname-type newpath))
-  (add-entry newdir self)
-  self)
-
-(defmethod rename-entry ((self file-contents) newpath)
-  ;; rename the version
-  (let ((file (if (ignore-errors (probe-file newpath))
-                  (file-at-path newpath)
-                  (create-file-at-path newpath nil))))
-    (remove-version (file self) (version self))
-    (setf (version self) (if (newest file)
-                             (max (version self) (1+ (version (newest file))))
-                             (version self))
-          (file self)   file
-          (gethash (version self) (versions file)) self)
-    self))
-
-(defmethod delete-entry ((self fs-file))
-  ;; delete the whole file
-  (remove-entry-named (parent self) (pathname-entry-name self)))
-
-(defmethod remove-version ((self fs-file) version)
-  (remhash version (versions self))
-  (when (= version (version (newest self)))
-    (let ((maxk -1) (maxv))
-      (maphash (lambda (k v) (when (< maxk k) (setf maxk k maxv v))) (versions self))
-      (if maxv
-          (setf (newest self) maxv)
-          ;; otherwise, we've deleted the last version, let's delete the file:
-          (delete-entry self)))))
-
-(defmethod delete-entry ((self file-contents))
-  ;; delete the version ( careful with (newest (file self)) ).
-  (remove-version (file self) (version self)))
-
-(defun rename-file (filespec new-name)
-  (let* ((defaulted (merge-pathnames new-name filespec))
-         (old-truename (truename filespec))
-         (new-truename (resolve-pathspec defaulted)))
-    (print (list defaulted old-truename new-truename))
-    (when (wild-pathname-p defaulted)
-      (error (make-condition
-              'simple-file-error
-              :pathname defaulted
-              :format-control "~A: source path ~A contains wildcards"
-              :format-arguments (list 'rename-file defaulted))))
-    (when (wild-pathname-p new-truename)
-      (error (make-condition
-              'simple-file-error
-              :pathname new-truename
-              :format-control "~A: target path ~A contains wildcards"
-              :format-arguments (list 'rename-file new-truename))))
-    (let* ((newpath (make-pathname :version nil :defaults new-truename))
-           (newdir  (directory-entry newpath)))
-      (unless newdir
-        (error (make-condition
-                'simple-file-error
-                :pathname newpath
-                :format-control "~A: target directory ~A doesn't exist"
-                :format-arguments (list 'rename-file newpath))))
-      (rename-entry (file (file-entry old-truename)) newpath))
-    (values defaulted old-truename new-truename)))
-
-(defun delete-file (filespec)
-  (delete-entry (file (file-entry (truename filespec))))
-  t)
-
-(defun delete-directory (pathspec)
-  (let ((dir (directory-entry pathspec)))
-    (when dir
-      (when (plusp (hash-table-count (entries dir)))
-        (error (make-condition
-                'simple-file-error
-                :pathname newpath
-                :format-control "~A: directory ~A is not empty"
-                :format-arguments (list 'delete-directory pathspec))))
-      (delete-entry dir)))
-  t)
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 21. Streams
-;;; http://www.lispworks.com/documentation/HyperSpec/Body/21_.htm
-
-
-
-
-;; (defun forward-call (function arguments)
-;;   "&optional &key"
-;;   (let ((opt  (position '&optional arguments))
-;;         (rest (position '&rest     arguments))
-;;         (key  (position '&key      arguments)))
-;;     (if rest
-;;         `(apply (function ,function)
-;;                 ,@(subseq arguments 0 (or opt rest))
-;;                 ,@(when opt
-;;                         (mapcar (lambda (x) (if (listp x) (first x) x))
-;;                                 (subseq arguments (1+ opt) rest)))
-;;                 ,(nth (1+ rest) arguments))
-;;         `(,function
-;;           ,@(subseq arguments 0 (or opt rest))
-;;           ,@(when opt
-;;                   (mapcar (lambda (x) (if (listp x) (first x) x))
-;;                           (subseq arguments (1+ opt) rest)))
-;;           ,@(when key
-;;                   (mapcan (lambda (x)
-;;                             (if (listp x)
-;;                                 (list (if (listp (first x))
-;;                                           (first (first x))
-;;                                           (intern (string (first x)) "KEYWORD"))
-;;                                       (if (listp (first x))
-;;                                           (second (first x))
-;;                                           (first x)))
-;;                                 (list (intern (string x) "KEYWORD")
-;;                                       x)))
-;;                           (subseq arguments (1+ key) rest)))))))
-
-
-
-
-
-;; (define-forward name arguments
-;;   [ documentation-string ]
-;;   { declarations }
-;;   { forward-method-description })
-;;
-;; (declare (stream-arguments stream)
-;;          (stream-designnator (istream :input)) ; default
-;;          (stream-designator  (ostream :output))
-;;          (check-stream-type file-stream)
-;;          (cl-forward t))
-;;
-;; (declare (stream-arguments stream))
-;;
-;; (declare (check-stream-type file-stream))
-;;
-;; method-description ::= (:method class [[declaration* | documentation]] form*)
-
-(eval-when (:execute :compile-toplevel :load-toplevel)
-  (defun make-method-lambda-list (lambda-list self-name self-type)
-    (let* ((got-it nil)
-           (mand (mapcar (lambda (par)
-                           (let ((name (parameter-name par)))
-                             (if (eq name self-name)
-                                 (progn (setf got-it t)
-                                        (list name self-type))
-                                 (list name 't))))
-                         (lambda-list-mandatory-parameters lambda-list)))
-           (opti (let ((optionals  (lambda-list-optional-parameters lambda-list)))
-                   (cond
-                     ((null optionals) nil)
-                     (got-it (cons '&optional
-                                   (mapcar (function parameter-specifier)
-                                           optionals)))
-                     (t (let ((pos  (position self-name optionals
-                                              :key (function parameter-name))))
-                          (if pos
-                              (append
-                               (mapcar (lambda (par) (list (parameter-name par) 't))
-                                       (subseq optionals 0 pos))
-                               (list
-                                (list (parameter-name (nth pos optionals))
-                                      self-type))
-                               (when (< (1+ pos) (length optionals))
-                                 (cons '&optional
-                                       (mapcar (function parameter-specifier)
-                                               (subseq optionals (1+ pos))))))
-                              (cons '&optional
-                                    (mapcar (function parameter-specifier)
-                                            optionals))))))))
-           (keys (mapcar (function parameter-specifier)
-                         (lambda-list-keyword-parameters lambda-list)))
-           (rest (and (lambda-list-rest-p lambda-list)
-                      (mapcar (function parameter-specifier)
-                              (lambda-list-rest-parameter lambda-list)))))
-      (append mand opti
-              (when keys (cons '&key keys))
-              (when rest (list '&rest rest))))))
-
-
-(defun stream-designator (stream direction)
-  "DIRECTION is either *standard-input* or *standard-output*"
-  (case stream
-    ((t)       *terminal-io*)
-    ((nil)     direction)
-    (otherwise stream)))
-
-(defun raise-type-error (object type)
-  (error (make-condition 'type-error :datum object :expected-type type)))
-
-
-
-
-
-(eval-when (:compile-toplevel
-            #| Not necessary?: |# :load-toplevel
-                                  :execute)
-  (defparameter *stream-methods* (make-hash-table)
-    "Keep the information about methods defined with DEFINE-FORWARD,
-for use by DEFINE-STREAM-METHODS"))
-
-
-(defun check-open (method stream)
-  (unless (%open-stream-p stream)
-    (error (make-condition simple-stream-error
-                           :stream stream
-                           :format-control "~S on ~S is illegal"
-                           :format-arguments (list method stream)))))
-
-(defmacro define-stream-methods (class-name &body methods)
-  "
-DO:     Expands to a bunch of defmethod forms, with the parameter
-        defined with DEFINE-FORWARD, and the body provided in the
-        METHODS clauses.
-"
-  `(progn
-     ,@(mapcar (lambda (method)
-                 (let ((minfo (gethash (first method) *stream-methods*)))
-                   (unless minfo
-                     (error "Unknown method ~S; please use DEFINE-FORWARD first"
-                            (first method)))
-                   (destructuring-bind (name lambda-list stream-name check-open-p)
-                       minfo
-                     `(defmethod ,name
-                          ,(make-method-lambda-list lambda-list stream-name class-name)
-                        (check-open ',name ,stream-name)
-                        ,@(rest method)))))
-               methods)))
-
-
-(defmacro define-forward (name arguments &body body)
-  "
-DO:     Specifies the name and parameter list of methods.
-        The BODY contains declarations and method clauses.
-
-        Specific pseudo-declarations are:
-
-        (stream-argument   stream-parameter)
-        (stream-designator (stream-parameter [:input|:output]))
-
-            Specify the stream parameter.  In the case of
-            stream-designator, the stream can be *standard-input* or
-            *standard-output* by default, as indicated by the keyword.
-
-        (check-stream-type stream-parameter)
-
-            When given, the stream type is checked in the default method.
-            (overriding methods should (call-next-method)).
-
-        (check-open-p      stream-parameter)
-
-            When given, the methods generated by DEFINE-STREAM-METHODS
-            will test for an open stream.
-
-        (cl-forward        booolean)
-
-             When the boolean is true, a method is defined for CL-STREAM
-             that forwards the call to the corresponding CL function.
-
-        The method clauses in the body are of the form:
-
-        (:method class . body)
-
-             For each of these clause, method is defined for the given
-             stream class.
-
-"
-  (let* ((documentation     (extract-documentation body))
-         (declarations      (declarations-hash-table (extract-declarations  body)))
-         (body              (extract-body          body))
-         (stream-argument   (caar  (gethash 'stream-argument   declarations)))
-         (stream-designator (caar  (gethash 'stream-designator declarations)))
-         (stream-name       (or stream-argument
-                                (if (consp stream-designator)
-                                    (first stream-designator)
-                                    stream-designator)))
-         (check-stream-type (caar  (gethash 'check-stream-type declarations)))
-         (cl-forward        (caar  (gethash 'cl-forward        declarations)))
-         (check-open-p      (caar  (gethash 'check-open-p      declarations)))
-         (lambda-list       (parse-lambda-list arguments :ordinary))
-         (m-name            (intern (format nil "%~A" name)))
-         (cl-name           (intern (string name) "COMMON-LISP")))
-    (setf (gethash name *stream-methods*)
-          (list m-name lambda-list stream-name check-open-p))
-    `(progn
-       (defun ,name ,arguments
-         ,@ (when documentation (list documentation))
-            ,@ (when stream-designator
-                 `((setf ,stream-name (stream-designator
-                                       ,stream-name
-                                       ,(if (listp stream-designator)
-                                            (ecase (second stream-designator)
-                                              ((:input)  '*standard-input*)
-                                              ((:output) '*standard-output*))
-                                            '*standard-input*)))))
-               ,(if (lambda-list-rest-p lambda-list)
-                    `(apply (function ,m-name) ,@(make-argument-list lambda-list))
-                    `(,m-name         ,@(butlast (make-argument-list lambda-list)))))
-       ,@ (when cl-forward
-            `((defmethod ,m-name
-                  ,(make-method-lambda-list lambda-list stream-name 'cl-stream)
-                ,(let ((arguments (mapcar
-                                   (lambda (arg)
-                                     (if (eq arg stream-name)
-                                         `(cl-stream-stream ,stream-name)
-                                         arg))
-                                   (make-argument-list lambda-list))))
-                      (if (lambda-list-rest-p lambda-list)
-                          `(apply (function ,cl-name) ,@arguments)
-                          `(,cl-name ,@(butlast arguments)))))))
-          ,@ (when check-stream-type
-               `((defmethod ,m-name ,(make-method-lambda-list lambda-list stream-name 't)
-                   (raise-type-error ,stream-name ',check-stream-type))))
-             ,@ (mapcar
-                 (lambda (method)
-                   (when (and (listp method) (eq :method (car method)))
-                     (destructuring-bind (method class-name &body body) method
-                       (declare (ignore method))
-                       `(defmethod ,m-name
-                            ,(make-method-lambda-list lambda-list stream-name class-name)
-                          ,@body))))
-                 body))))
-
-
-
-(define-forward input-stream-p       (stream)
-  (declare (stream-argument stream)
-           (check-stream-type stream)
-           (cl-forward t)))
-
-(define-forward output-stream-p      (stream)
-  (declare (stream-argument stream)
-           (check-stream-type stream)
-           (cl-forward t)))
-
-(define-forward interactive-stream-p (stream)
-  (declare (stream-argument stream)
-           (check-stream-type stream)
-           (cl-forward t))
-  (:method stream nil))
-
-(define-forward open-stream-p        (stream)
-  (declare (stream-argument stream)
-           (check-stream-type stream)
-           (cl-forward t)))
-
-(define-forward stream-element-type  (stream)
-  (declare (stream-argument stream)
-           (check-stream-type stream)
-           (cl-forward t)))
-
-(defun streamp (object) (typep object 'stream))
-
-(defun eof-stream (stream eof-error-p eof-value)
-  (if eof-error-p (error (make-condition 'eof-error :stream stream)) eof-value))
-
-
-
-(define-forward read-byte (stream &optional (eof-error-p t) (eof-value nil))
-  (declare (stream-argument stream)
-           (check-stream-type stream)
-           (cl-forward t) (check-open-p t))
-  (:method echo-stream
-    (let ((byte (read-byte (%echo-stream-input-stream stream) nil stream)))
-      (if (eq byte stream)
-          (eof-error stream eof-error-p eof-value)
-          (progn
-            (write-byte byte  (%echo-stream-output-stream stream))
-            byte))))
-  (:method string-input-stream
-    (if (< (%string-stream-index stream)
-           (or (%string-stream-end stream)
-               (length (%string-stream-input-string stream))))
-        (char-code (aref (%string-stream-input-string stream)
-                         (prog1 (%string-stream-index stream)
-                           (incf (%string-stream-index stream)))))
-        (eof-error stream eof-error-p eof-value)))
-  (:method synonym-stream
-    (read-byte (symbol-value (%synonym-stream-symbol stream))
-               eof-error-p eof-value))
-  (:method two-way-stream
-    (read-byte (%two-way-stream-input-stream stream)
-               eof-error-p eof-value)))
-
-(define-forward write-byte (byte stream)
-  (declare (stream-argument stream)
-           (check-stream-type stream)
-           (cl-forward t) (check-open-p t))
-  (:method broadcast-stream
-    (broadcast-stream-operation (ostream stream) (write-byte byte ostream))
-    byte)
-  (:method echo-stream
-    (write-byte byte  (%echo-stream-output-stream stream)))
-  (:method string-output-stream
-    (vector-push-extend (char-code byte) (%string-stream-output-string stream))
-    byte)
-  (:method synonym-stream
-    (write-byte (symbol-value (%synonym-stream-symbol stream))))
-  (:method two-way-stream
-    (write-byte (%two-way-stream-output-stream stream))))
-
-(define-forward peek-char (&optional (peek-type nil) (stream *standard-input*)
-                                     (eof-error-p t) (eof-value nil)
-                                     (recursive-p nil))
-  (declare (stream-designator (stream :input))
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward read-char (&optional (input-stream *standard-input*)
-                                     (eof-error-p t) (eof-value nil)
-                                     (recursive-p nil))
-  (declare (stream-designator (input-stream :input))
-           (cl-forward t) (check-open-p t))
-  (:method echo-stream
-    (let ((char (read-char (%echo-stream-input-stream stream) nil stream)))
-      (if (eq char stream)
-          (eof-error stream eof-error-p eof-value)
-          (progn
-            (write-char char (%echo-stream-output-stream stream))
-            char))))
-  (:method string-input-stream
-    (if (< (%string-stream-index stream)
-           (or (%string-stream-end stream)
-               (length (%string-stream-input-string stream))))
-        (aref (%string-stream-input-string stream)
-              (prog1 (%string-stream-index stream)
-                (incf (%string-stream-index stream))))
-        (eof-error stream eof-error-p eof-value)))
-  (:method synonym-stream
-    (read-char (symbol-value (%synonym-stream-symbol stream))
-               eof-error-p eof-value))
-  (:method two-way-stream
-    (read-char (%two-way-stream-input-stream stream)
-               eof-error-p eof-value)))
-
-
-(define-forward read-char-no-hang (&optional (input-stream *standard-input*)
-                                             (eof-error-p t) (eof-value nil)
-                                             (recursive-p nil))
-  (declare (stream-designator (input-stream :input))
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward terpri (&optional (output-stream *standard-output*))
-  (declare (stream-designator (output-stream :output))
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward fresh-line (&optional (output-stream *standard-output*))
-  (declare (stream-designator (output-stream :output))
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward unread-char (character &optional (input-stream *standard-input*))
-  (declare (stream-designator (input-stream :input))
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward write-char (character
-                            &optional (output-stream *standard-output*))
-  (declare (stream-designator (output-stream :output))
-           (cl-forward t) (check-open-p t))
-  (:method echo-stream
-    (write-char character (%echo-stream-output-stream stream)))
-  (:method string-output-stream
-    (vector-push-extend character (%string-stream-output-string stream))
-    character)
-  (:method synonym-stream
-    (write-char (symbol-value (%synonym-stream-symbol stream))))
-  (:method two-way-stream
-    (write-char (%two-way-stream-output-stream stream))))
-
-
-(define-forward read-line (&optional (input-stream *standard-input*)
-                                     (eof-error-p t) (eof-value nil)
-                                     (recursive-p nil))
-  (declare (stream-designator (input-stream :input))
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward write-string (string
-                              &optional (output-stream *standard-output*)
-                              &key (start 0) (end nil))
-  (declare (stream-designator (output-stream :output))
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward write-line (string
-                            &optional (output-stream *standard-output*)
-                            &key (start 0) (end nil))
-  (declare (stream-designator (output-stream :output))
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward read-sequence (sequence stream &key (start 0) (end nil))
-  (declare (stream-argument stream)
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward write-sequence (sequence stream &key (start 0) (end nil))
-  (declare (stream-argument stream)
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward file-length (stream)
-  (declare (stream-argument stream)
-           (check-stream-type file-stream)
-           (cl-forward t))
-  (:method stream (error "not implemented yet")))
-
-
-(define-forward file-position (stream
-                               &optional (position-spec nil position-spec-p))
-  (declare (stream-argument stream)
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward file-string-length (stream object)
-  (declare (stream-argument stream)
-           (check-stream-type file-stream)
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward stream-external-format (stream)
-  (declare (stream-argument stream)
-           (check-stream-type stream)
-           (cl-forward t)))
-
-
-(define-forward close (stream &key (abort nil))
-  (declare (stream-argument stream)
-           (check-stream-type stream)
-           (cl-forward t)))
-
-
-(define-forward listen (&optional input-stream)
-  (declare (stream-designator input-stream)
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward clear-input (&optional input-stream)
-  (declare (stream-designator (input-stream :input))
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward clear-output (&optional output-stream)
-  (declare (stream-designator (output-stream :output))
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward force-output (&optional output-stream)
-  (declare (stream-designator (output-stream :output))
-           (cl-forward t) (check-open-p t)))
-
-
-(define-forward finish-output (&optional output-stream)
-  (declare (stream-designator (output-stream :output))
-           (cl-forward t) (check-open-p t)))
-
-
-
-
-
-
-
-
-(defun open (filespec &key (direction :input)
-             (element-type 'character)
-             (if-exists nil)
-             (if-does-not-exist nil)
-             (external-format :default))
-
-  (check-type direction (member :input :output :io :probe))
-  (check-type if-exists (member :error :new-version :rename :rename-and-delete
-                                :overwrite :append :supersede nil))
-  (check-type if-does-not-exist (member :error :create nil))
-  (check-type external-format (member :default))
-
-  ;; (error "Not implemented yet")
-
-  (let ((path (pathname filespec)))
-    (labels ((make-stream (file openp inputp outputp overridep position)
-               (let* ((contents (newest file)))
-                 (make-instance (if inputp
-                                    (if outputp
-                                        'file-io-stream
-                                        'file-input-stream)
-                                    (if outputp
-                                        'file-output-stream
-                                        'file-stream))
-                     :open-p openp
-                     :element-type (element-type contents)
-                     :external-format :default ; ???
-                     :input-p inputp
-                     :output-p outputp
-                     :override-p overridep
-                     :pathname (truename path)
-                     :file file
-                     :contents contents
-                     :position (ecase position
-                                 (:start 0)
-                                 (:end   (length (contents contents)))))))
-
-             (new-file (path element-type)
-               (create-file-at-path path :create-version-p t :element-type element-type))
-
-             (new-file/unlinked (path element-type)
-               (let ((entry (make-instance 'fs-file
-                                :name (pathname-name path) :type (pathname-type path))))
-                 (create-new-version entry :element-type element-type)
-                 entry))
-
-             (new-version (file element-type)
-               (create-new-version file :element-type element-type))
-
-             (copy-new-version (contents)
-               (let ((new-contents (newest (create-new-version (file contents)
-                                                               :element-type (element-type contents)))))
-                 (setf (contents new-contents) (copy-array (contents contents)
-                                                           :copy-fill-pointer t
-                                                           :copy-adjustable t))
-                 (file new-contents)))
-
-             (rename-old (file &optional (index 0))
-               (let ((old (make-pathname :type (format nil "~A-OLD-~3,'0D"
-                                                       (pathname-type file)
-                                                       (incf index))
-                                         :defaults file)))
-                 (if (file-entry old)
-                     (rename-old file index)
-                     (rename-file file old)))))
-
-      (let ((contents (file-entry path)))
-
-       ;; filespec  N.T     N.T.3<NEWEST N.T.3>NEWEST  N.T.3=NEWEST  N.T.3<NEWEST
-       ;;   N.T     no exist     newest        newest       newest         newest
-       ;;   N.T.3   no exist     no exist      no exist     newest      old version
-       ;;                     create newest  create newest
-       (ecase direction
-
-         ((:input :probe)
-          (if contents
-              (progn
-                ;; TODO: use CERROR to ignre the requested element-type
-                (assert (equal (element-type contents) element-type)
-                        () "~A: the element-type requested ~S must be identical to the element-type ~S of the file ~S"
-                        'open element-type (element-type contents)  path)
-                (make-stream (file contents) (eql direction :input) t nil  nil :start))
-              (ecase if-does-not-exist
-                ((:error)
-                 (error (make-condition
-                         'simple-file-error
-                         :pathname path
-                         :format-control "~A: file ~S does not exist"
-                         :format-arguments (list 'open path))))
-                ((:create)
-                 (make-stream (new-file path element-type) (eql direction :input) t nil  nil :start))
-                ((nil)
-                 (return-from open nil)))))
-
-
-         ((:output :io)
-          (if contents
-              ;; file exists:
-              (ecase if-exists
-                ((:error)
-                 (error (make-condition
-                         'simple-file-error
-                         :pathname path
-                         :format-control "~A: file ~S already exists"
-                         :format-arguments (list 'open path))))
-                ((:new-version)
-                 (make-stream (new-version (file contents) element-type)
-                              t (eql direction :io) t  nil :start))
-                ((:rename)
-                 (rename-old path)
-                 (make-stream (new-file path element-type)
-                              t (eql direction :io) t  nil :start))
-                ((:rename-and-delete)
-                 (let ((old nil))
-                   (unwind-protect
-                        (progn
-                          (setf old (rename-old path))
-                          (make-stream (new-file path element-type)
-                                       t (eql direction :io) t  nil :start))
-                     (when old
-                       (delete-file old)))))
-                ((:overwrite)
-                 (make-stream (if (eql contents (newest (file contents)))
-                                  (file contents)
-                                  (copy-new-version contents))
-                              t (eql direction :io) t nil :start))
-                ((:append)
-                 (make-stream (if (eql contents (newest (file contents)))
-                                  (file contents)
-                                  (copy-new-version contents))
-                              t (eql direction :io) t nil :end))
-                ((:supersede)
-                 (make-stream (new-file/unlinked path element-type)
-                              t (eql direction :io) t  nil :start))
-                ((nil)
-                 (return-from open nil)))
-              ;; file does not exist:
-              (ecase if-does-not-exist
-                ((:error)
-                 (error (make-condition
-                         'simple-file-error
-                         :pathname path
-                         :format-control "~A: file ~S does not exist"
-                         :format-arguments (list 'open path))))
-                ((:create)
-                 (make-stream (new-file path element-type) t (eql direction :io) t  t :start))
-                ((nil)
-                 (return-from open nil))))))))))
-
-
-(define-stream-methods file-stream
-    (stream-external-format (%stream-external-format stream))
-  (file-length   (length (contents (%file-stream-contents stream))))
-  (file-string-length
-   (etypecase object
-     (character 1)
-     (string    (length object))))
-  (close
-   (prog1 (%open-stream-p stream)
-     (when (%open-stream-p stream)
-       (setf (%open-stream-p stream) nil)
-       (when (%override-p stream)
-         (let* ((path (pathname stream))
-                (dir   (directory-entry path)))
-           (delete-file path)
-           (add-entry dir (%file-stream-file stream))))))))
-
-
-
-(defun  !read-element (stream eof-error-p eof-value)
-  (with-accessors ((contents %file-stream-contents)
-                   (position %file-stream-position)) stream
-    (if (< position (length (contents contents)))
-        (aref (contents contents) (prog1 position (incf position)))
-        (if eof-error-p
-            (error 'end-of-file :stream stream)
-            eof-value))))
-
-
-(defun !write-element (stream sequence start end)
-  (with-accessors ((contents %file-stream-contents)
-                   (position %file-stream-position)) stream
-    (let* ((end          (or end (length sequence)))
-           (size         (- end start))
-           (new-position (+ position size))
-           (data         (contents contents)))
-      (if (< new-position *maximum-file-size*)
-          (progn
-            (unless (< new-position (array-dimension data 0))
-              (setf data (adjust-array data
-                                       (max new-position (* 2 (array-dimension data 0)))
-                                       :element-type (array-element-type data)
-                                       :initial-element (if (subtypep (array-element-type data)
-                                                                      'character)
-                                                            #\space
-                                                            0)
-                                       :fill-pointer (fill-pointer data))
-                    (contents contents) data))
-            (when (< (fill-pointer data) new-position)
-              (setf (fill-pointer data) new-position))
-            (replace data sequence :start1 position :start2 start :end2 end)
-            (setf position new-position))
-          (error 'simple-stream-error
-                     :stream stream
-                     :format-control "data too big to be written on stream ~S (~A+~A=~A>~A)"
-                     :format-arguments (list stream
-                                             position size new-position *maximum-file-size*))))))
-
-(defun whitespacep (ch)
-  (position  ch #(#\Space #\Newline #\Tab #\Linefeed #\Page #\Return)))
-
-
-(define-stream-methods file-input-stream
-    (file-position
-     (call-next-method)
-     (with-accessors ((contents %file-stream-contents)
-                      (position %file-stream-position)) stream
-       (if position-spec
-           (if (< -1 position-spec (length (contents contents)))
-               (setf position position-spec)
-               (error 'simple-stream-error
-                      :stream stream
-                      :format-control "~A: invalid position ~A on stream ~S"
-                      :format-arguments (list 'file-position position-spec stream))))
-       position))
-
-  (read-byte         (!read-element       stream eof-error-p eof-value))
-  (read-char         (!read-element input-stream eof-error-p eof-value))
-  (read-char-no-hang (!read-element input-stream eof-error-p eof-value))
-  (peek-char
-   (flet ((eof ()
-            (if eof-error-p
-                (error 'end-of-file :stream stream)
-                eof-value)))
-     (with-accessors ((contents %file-stream-contents)
-                      (position %file-stream-position)) stream
-       (case peek-type
-         ((nil))
-         ((t)
-          (setf position (or (position-if-not (function whitespacep)
-                                              (contents contents)
-                                              :start position)
-                             (length (contents contents)))))
-         (otherwise
-          (setf position (or (position peek-type
-                                       (contents contents)
-                                       :start position)
-                             (length (contents contents))))))
-       (if (< position (length (contents contents)))
-           (aref (contents contents) position)
-           (eof)))))
-  (unread-char
-   (with-accessors ((contents %file-stream-contents)
-                    (position %file-stream-position)) input-stream
-     (when (plusp position)
-       (decf position))))
-  (read-line
-   (with-accessors ((contents %file-stream-contents)
-                    (position %file-stream-position)) input-stream
-     (let ((start position)
-           (end   (or (position #\newline (contents contents) :start position)
-                      (length (contents contents)))))
-       (prog1 (subseq (contents contents) start (if (< end (length (contents contents)))
-                                                    (1- end)
-                                                    end))
-         (setf position end)))))
-  (read-sequence
-   (with-accessors ((contents %file-stream-contents)
-                    (position %file-stream-position)) stream
-     (let ((start position)
-           (end   (or (position #\newline (contents contents) :start position)
-                      (length (contents contents)))))
-       (prog1 (subseq (contents contents) start (if (< end (length (contents contents)))
-                                                    (1- end)
-                                                    end))
-         (setf position end)))))
-  (listen
-   (with-accessors ((contents %file-stream-contents)
-                    (position %file-stream-position)) input-stream
-     (< position (length (contents contents)))))
-  (clear-input
-   #|nothing|#
-   nil))
-
-
-(defvar *newline* (string #\newline))
-
-(define-stream-methods file-output-stream
-    (file-position
-     (call-next-method)
-     (with-accessors ((contents %file-stream-contents)
-                      (position %file-stream-position)) stream
-       (if position-spec
-           (if (< -1 position-spec *maximum-file-size*)
-               (setf position position-spec)
-               (error 'simple-stream-error
-                      :stream stream
-                      :format-control "~A: invalid position ~A on stream ~S"
-                      :format-arguments (list 'file-position position-spec stream))))
-       position))
-
-  (write-byte     (!write-element stream        (vector byte)      0 1)
-                  byte)
-  (write-char     (!write-element output-stream (string character) 0 1)
-                  character)
-  (terpri         (!write-element output-stream *newline*          0 (length *newline*))
-                  nil)
-  (fresh-line     (with-accessors ((contents %file-stream-contents)
-                                   (position %file-stream-position)) stream
-                    (unless (and (plusp position)
-                                 (char= #\newline (aref (contents contents) (1- position))))
-                      (!write-element output-stream *newline*  0 (length *newline*))
-                      #\newline)))
-  (write-string   (!write-element output-stream string start end)
-                  string)
-  (write-line     (!write-element output-stream string start end)
-                  (!write-element output-stream *newline* 0 (length *newline*))
-                  string)
-  (write-sequence (!write-element stream sequence start end)
-                  sequence)
-  (clear-output   #|nothing|# nil)
-  (force-output   #|nothing|# nil)
-  (finish-output  #|nothing|# nil))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;;
-;;;
-
-
-(defun make-synonym-stream (symbol)
-  (check-type symbol symbol)
-  (make-instance 'synonym-stream :symbol symbol))
-
-(define-forward synonym-stream-symbol (synonym-stream)
-  (declare (stream-argument synonym-stream)
-           (check-stream-type synonym-stream)))
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;;
-;;;
-
-
-(defun make-broadcast-stream (&rest streams)
-  (dolist (stream streams)
-    (unless (output-stream-p stream)
-      (error (make-condition
-              'simple-type-error
-              :datum stream
-              :expected-type 'stream
-              :format-control "Stream is not an output stream"))))
-  (make-instance 'broadcast-stream :streams streams))
-
-(define-forward broadcast-stream-streams (broadcast-stream)
-  (declare (stream-argument broadcast-stream)
-           (check-stream-type broadcast-stream)))
-
-(defmacro broadcast-stream-operation ((output-stream broadcast-stream)
-                                      &body body)
-  `(let ((results '()))
-     (dolist (,output-stream (%broadcast-stream-streams ,broadcast-stream)
-              (values-list results))
-       (setf results (multiple-value-list (progn ,@body))))))
-
-
-
-(define-stream-methods broadcast-stream
-    (write-byte              (do-broadcast (ostream stream)
-                               (write-char byte ostream))
-                             byte)
-  (write-char              (do-broadcast (ostream stream)
-                             (write-char character ostream))
-                           character)
-  (terpri                  (do-broadcast (ostream stream)
-                             (terpri ostream))
-                           nil)
-  (fresh-line              (do-broadcast (ostream stream)
-                             (fresh-line ostream)))
-  (write-string            (do-broadcast (ostream stream)
-                             (write-string string ostream :start start :end end))
-                           string)
-  (write-line              (do-broadcast (ostream stream)
-                             (write-line string ostream :start start :end end))
-                           string)
-  (write-sequence          (do-broadcast (ostream stream)
-                             (write-sequence sequence ostream :start start :end end))
-                           sequence)
-  (clear-output            (do-broadcast (ostream stream)
-                             (clear-output ostream)))
-  (force-output            (do-broadcast (ostream stream)
-                             (force-output ostream)))
-  (finish-output           (do-broadcast (ostream stream)
-                             (finish-output ostream)))
-  (file-length             (if (%broadcast-stream-streams stream)
-                               (file-length
-                                (first (last (%broadcast-stream-streams stream))))
-                               0))
-  (file-position           (if (%broadcast-stream-streams stream)
-                               (file-position
-                                (first (last (%broadcast-stream-streams stream))))
-                               0))
-  (file-string-length      (if (%broadcast-stream-streams stream)
-                               (file-string-length
-                                (first (last (%broadcast-stream-streams stream))))
-                               1))
-  (stream-external-format  (if (%broadcast-stream-streams stream)
-                               (stream-external-format
-                                (car (last (%broadcast-stream-streams stream))))
-                               't))
-  (close                   (prog1 (%open-stream-p stream)
-                             (setf (%open-stream-p stream) nil
-                                   (%broadcast-stream-streams stream) nil))))
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;;
-;;;
-
-
-
-(defun make-two-way-stream (input-stream output-stream)
-  (unless (input-stream-p stream)
-    (error (make-condition
-            'simple-type-error
-            :datum input-stream
-            :expected-type 'stream
-            :format-control "Stream is not an input stream")))
-  (unless (output-stream-p stream)
-    (error (make-condition
-            'simple-type-error
-            :datum output-stream
-            :expected-type 'stream
-            :format-control "Stream is not an output stream")))
-  (make-instance 'two-way-stream
-    :input-stream input-stream
-    :output-stream output-stream))
-
-(define-forward two-way-stream-input-stream (two-way-stream)
-  (declare (stream-argument two-way-stream)
-           (check-stream-type two-way-stream)))
-
-(define-forward two-way-stream-output-stream (two-way-stream)
-  (declare (stream-argument two-way-stream)
-           (check-stream-type two-way-stream)))
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;;
-;;;
-
-
-(defun make-echo-stream (input-stream output-stream)
-  (unless (input-stream-p stream)
-    (error (make-condition
-            'simple-type-error
-            :datum input-stream
-            :expected-type 'stream
-            :format-control "Stream is not an input stream")))
-  (unless (output-stream-p stream)
-    (error (make-condition
-            'simple-type-error
-            :datum output-stream
-            :expected-type 'stream
-            :format-control "Stream is not an output stream")))
-  (make-instance 'echo-stream
-    :input-stream input-stream
-    :output-stream output-stream))
-
-(define-forward echo-stream-input-stream (echo-stream)
-  (declare (stream-argument echo-stream)
-           (check-stream-type echo-stream)))
-
-(define-forward echo-stream-output-stream (echo-stream)
-  (declare (stream-argument echo-stream)
-           (check-stream-type echo-stream)))
-
-(define-stream-methods echo-stream
-  (read-byte)
-  (read-char)
-  (read-char-no-hang)
-  (peek-char)
-  (unread-char)
-  (read-line)
-  (read-sequence)
-  (terpri)
-  (fresh-line)
-  (write-byte)
-  (write-char)
-  (write-string)
-  (write-line)
-  (write-sequence)
-  (listen)
-  (clear-input)
-  (clear-output)
-  (force-output)
-  (finish-output)
-
-  (file-length)
-  (file-position)
-  (file-string-length)
-  (stream-external-format)
-  (close))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;;
-;;;
-
-
-(defun make-concatenated-stream (&rest input-streams)
-  (dolist (stream streams)
-    (unless (input-stream-p stream)
-      (error (make-condition
-              'simple-type-error
-              :datum stream
-              :expected-type 'stream
-              :format-control "Stream is not an input stream"))))
-  (make-instance 'concatenated-stream :streams input-streams))
-
-(define-forward concatenated-stream-streams (concatenated-stream)
-  (declare (stream-argument concatenated-stream)
-           (check-stream-type concatenated-stream)))
-
-(defun !concatenated-read-element (read-element
-                                   stream eof-error-p eof-value recursive-p)
-  (let ((current (first (%concatenated-stream-streams stream))))
-    (if (null current)
-        (eof-error stream eof-error-p eof-value)
-        (let ((element (multiple-value-list
-                        (funcall read-element current nil stream recursive-p))))
-          (cond
-            ((eq (car element) stream)
-             (pop (%concatenated-stream-streams stream))
-             (!concatenated-read-element
-              read-element stream eof-error-p eof-value recursive-p))
-            ((second element)
-             (pop (%concatenated-stream-streams stream))
-             (multiple-value-bind (line missing-newline-p)
-                 (!concatenated-read-element
-                  read-element stream eof-error-p eof-value recursive-p)
-               (values (concatenate 'string (first element) line)
-                       missing-newline-p)))
-            (t (values-list element)))))))
-
-
-(define-stream-methods concatenated-stream
-    (read-byte         (!concatenated-read-element
-                        (lambda (s e v r) (declare (ignore r)) (read-byte s e v))
-                        stream eof-error-p eof-value nil))
-  (read-char         (!concatenated-read-element
-                      (function read-char)
-                      stream eof-error-p eof-value recursive-p))
-  (read-char-no-hang (!concatenated-read-element
-                      (function read-char-no-hang)
-                      stream eof-error-p eof-value recursive-p))
-  (peek-char         (!concatenated-read-element
-                      (lambda (s e v r) (peek-char peek-type s e v r))
-                      stream eof-error-p eof-value recursive-p))
-  (unread-char
-   (let ((current (first (%concatenated-stream-streams stream))))
-     (if (null current)
-         (push (make-string-input-stream (string character))
-               (%concatenated-stream-streams stream))
-         (unread-char character current))))
-  (read-line         (!concatenated-read-element
-                      (lambda (s e v r) (declare (ignore r)) (read-line s e v))
-                      stream eof-error-p eof-value recursive-p))
-  (read-sequence
-   (let ((current (first (%concatenated-stream-streams stream))))
-     (if (null current)
-         (eof-error stream eof-error-p eof-value)
-         (let* ((end      (or end (length sequence)))
-                (position (read-stream sequence current start end)))
-           (if (< position end)
-               (progn
-                 (pop (%concatenated-stream-streams stream))
-                 (setf current (first (%concatenated-stream-streams stream)))
-                 (if (null current)
-                     position
-                     (read-sequence sequence stream :start position :end end)))
-               position)))))
-  (listen
-   (let ((current (first (%concatenated-stream-streams stream))))
-     (warn "LISTEN may return NIL in the middle of a concatenated-stream when we're at the end of one of the substreams")
-     (listen current)))
-  (clear-input
-   (let ((current (first (%concatenated-stream-streams stream))))
-     (and current (clear-input current))))
-  (stream-external-format ;; or use the attribute?
-   (let ((current (first (%concatenated-stream-streams stream))))
-     (if current
-         (stream-external-format current)
-         :default)))
-  (close
-   (prog1 (%open-stream-p stream)
-     (setf (%open-stream-p stream) nil
-           (%concatenated-stream-streams stream) nil))))
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;;
-;;;
-
-
-(defun make-string-input-stream (string &optional (start 0) (end nil))
-  (make-instance 'string-input-stream
-    :string string
-    :start start
-    :end end))
-
-(defun make-string-output-stream (&key (element-type 'character element-type-p))
-  (make-instance 'string-output-stream
-    :string (make-array 8 :fill-pointer 0 :adjustable t
-                        :element-type element-type)))
-
-(define-forward get-output-stream-string (string-output-stream)
-  (declare (stream-argument   string-output-stream)
-           (check-stream-type string-output-stream))
-  (:method string-output-stream
-    (%string-stream-output-string string-output-stream)))
-
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;;
-;;;
-
-(defun y-or-n-p (&optional format-string &rest args)
-  (when format-string
-    (fresh-line *query-io*)
-    (apply (function format) *query-io* format-string args)
-    (write-string " (y/n) " *query-io*))
-  (loop
-     (let ((line (string-left-trim " " (read-line *query-io*))))
-       (when (plusp (length line))
-         (let ((first-char (char-upcase (char line 0))))
-           (when (char-equal first-char #\n) (return nil))
-           (when (char-equal first-char #\y) (return t))))
-       (write-string "Please answer with y or n : " *query-io*))))
-
-
-(defun yes-or-no-p (&optional format-string &rest args)
-  (when format-string
-    (fresh-line *query-io*)
-    (apply (function format) *query-io* format-string args)
-    (write-string " (yes/no) " *query-io*))
-  (loop
-     (clear-input *query-io*)
-     (let ((line (string-trim " " (read-line *query-io*))))
-       (when (string-equal line "NO")  (return nil))
-       (when (string-equal line "YES") (return t)))
-     (write-string "Please answer with yes or no : " *query-io*)))
-
-
-
-
-
-;; Macros are taken from clisp sources, and adapted.
-(eval-when (:execute :compile-toplevel :load-toplevel)
- (defun parse-body (body)
-   (values (extract-body body)
-           (let ((decls '()))
-             (maphash
-              (lambda (k v)
-                (setf decls (nconc (mapcar (lambda (d) (cons k v)) v) decls)))
-              (declarations-hash-table (extract-declarations body)))
-             decls))))
-
-
-(defmacro with-open-file ((stream &rest options) &body body)
-  (multiple-value-bind (body-rest declarations)  (parse-body body)
-    `(let ((,stream (open ,@options)))
-       (declare (read-only ,stream) ,@declarations)
-       (unwind-protect
-            (multiple-value-prog1 (progn ,@body-rest)
-              (when ,stream (close ,stream)))
-         (when ,stream (close ,stream :abort t))))))
-
-
-(defmacro with-open-stream ((var stream) &body body)
-  (multiple-value-bind (body-rest declarations) (parse-body body)
-    `(let ((,var ,stream))
-       (declare (read-only ,var) ,@declarations)
-       (unwind-protect
-            (multiple-value-prog1 (progn ,@body-rest) (close ,var))
-         (close ,var :abort t)))))
-
-
-(defmacro with-input-from-string ((var string  &key (index nil sindex)
-                                       (start '0 sstart) (end 'nil send))
-                                  &body body)
-  (multiple-value-bind (body-rest declarations) (parse-body body)
-    `(let ((,var (make-string-input-stream
-                  ,string
-                  ,@(if (or sstart send)
-                        `(,start ,@(if send `(,end) '()))
-                        '()))))
-       (declare (read-only ,var) ,@declarations)
-       (unwind-protect
-            (progn ,@body-rest)
-         ,@(when sindex `((setf ,index (%string-stream-index ,var))))
-         (close ,var)))))
-
-
-(defmacro with-output-to-string ((var &optional (string nil)
-                                      &key (element-type ''character))
-                                 &body body)
-  (multiple-value-bind (body-rest declarations) (parse-body body)
-    (if string
-        (let ((ignored-var (gensym)))
-          `(let ((,var (make-instance 'string-output-stream :string ,string))
-                 (,ignored-var ,element-type))
-             (declare (read-only ,var) (ignore ,ignored-var) ,@declarations)
-             (unwind-protect
-                  (progn ,@body-rest)
-               (close ,var))))
-        `(let ((,var (make-string-output-stream :element-type ,element-type)))
-           (declare (read-only ,var) ,@declarations)
-           (unwind-protect
-                (progn ,@body-rest (get-output-stream-string ,var))
-             (close ,var))))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
 ;;;; the END ;;;;
ViewGit