Description: <short summary of the patch>
 TODO: Put a short summary on the line above and replace this paragraph
 with a longer explanation of this change. Complete the meta-information
 with other relevant fields (see below for details). To make it easier, the
 information below has been extracted from the changelog. Adjust it or drop
 it.
 .
 gcl (2.6.12-38) unstable; urgency=medium
 .
   * Version_2_6_13pre50
Author: Camm Maguire <camm@debian.org>

---
The information above should follow the Patch Tagging Guidelines, please
checkout http://dep.debian.net/deps/dep3/ to learn about the format. Here
are templates for supplementary fields that you might want to add:

Origin: <vendor|upstream|other>, <url of original patch>
Bug: <url in upstream bugtracker>
Bug-Debian: https://bugs.debian.org/<bugnumber>
Bug-Ubuntu: https://launchpad.net/bugs/<bugnumber>
Forwarded: <no|not-needed|url proving that it has been forwarded>
Reviewed-By: <name and email of someone who approved the patch>
Last-Update: 2016-10-11

--- gcl-2.6.12.orig/ansi-tests/ansi-aux.lsp
+++ gcl-2.6.12/ansi-tests/ansi-aux.lsp
@@ -80,6 +80,10 @@ Results: ~A~%" expected-number form n re
   "Like EQUALP, but guaranteed to return T for true."
   (apply #'values (mapcar #'notnot (multiple-value-list (equalp x y)))))
 
+(defun equalpt-or-report (x y)
+  "Like EQUALPT, but return either T or a list of the arguments."
+  (or (equalpt x y) (list x y)))
+
 (defun =t (x &rest args)
   "Like =, but guaranteed to return T for true."
   (apply #'values (mapcar #'notnot (multiple-value-list (apply #'=  x args)))))
@@ -223,6 +227,13 @@ Results: ~A~%" expected-number form n re
 			P x p1 x TYPE p2)
 		t)))))
 
+(defun check-predicate (predicate &optional guard (universe *universe*))
+  "Return all elements of UNIVERSE for which the guard (if present) is false
+   and for which PREDICATE is false."
+  (remove-if #'(lambda (e) (or (and guard (funcall guard e))
+			       (funcall predicate e)))
+	     universe))
+
 (declaim (special *catch-error-type*))
 
 (defun catch-continue-debugger-hook (condition dbh)
@@ -296,7 +307,167 @@ the condition to go uncaught if it canno
 (defmacro classify-error (form)
   `(classify-error** ',form))
 
+(defun sequencep (x) (typep x 'sequence))
+
 ;;;
+(defun typef (type) #'(lambda (x) (typep x type)))
+
+(defmacro signals-error (form error-name &key (safety 3) (name nil name-p) (inline nil))
+  `(handler-bind
+    ((warning #'(lambda (c) (declare (ignore c))
+			      (muffle-warning))))
+    (proclaim '(optimize (safety 3)))
+    (handler-case
+     (apply #'values
+	    nil
+	    (multiple-value-list
+	     ,(cond
+	       (inline form)
+	       (regression-test::*compile-tests*
+		`(funcall (compile nil '(lambda ()
+					  (declare (optimize (safety ,safety)))
+					  ,form))))
+	       (t `(eval ',form)))))
+     (,error-name (c)
+		  (cond
+		   ,@(case error-name
+		       (type-error
+			`(((typep (type-error-datum c)
+				  (type-error-expected-type c))
+			   (values
+			    nil
+			    (list (list 'typep (list 'quote
+						     (type-error-datum c))
+					(list 'quote
+					      (type-error-expected-type c)))
+				  "==> true")))))
+		       ((undefined-function unbound-variable)
+			(and name-p
+			     `(((not (eq (cell-error-name c) ',name))
+				(values
+				 nil
+				 (list 'cell-error-name "==>"
+				       (cell-error-name c)))))))
+		       ((stream-error end-of-file reader-error)
+			`(((not (streamp (stream-error-stream c)))
+			   (values
+			    nil
+			    (list 'stream-error-stream "==>"
+				  (stream-error-stream c))))))
+		       (file-error
+			`(((not (pathnamep (pathname (file-error-pathname c))))
+			   (values
+			    nil
+			    (list 'file-error-pathname "==>"
+				  (file-error-pathname c))))))
+		       (t nil))
+		   (t (printable-p c)))))))
+
+(defmacro signals-error-always (form error-name)
+  `(values
+    (signals-error ,form ,error-name)
+    (signals-error ,form ,error-name :safety 0)))
+
+(defmacro signals-type-error (var datum-form form &key (safety 3) (inline nil))
+  (let ((lambda-form
+	 `(lambda (,var)
+	    (declare (optimize (safety ,safety)))
+	    ,form)))
+    `(let ((,var ,datum-form))
+       (declare (optimize safety))
+       (handler-bind
+	((warning #'(lambda (c) (declare (ignore c))
+		      (muffle-warning))))
+					; (proclaim '(optimize (safety 3)))
+	(handler-case
+	 (apply #'values
+		nil
+		(multiple-value-list
+		 (funcall
+		 ,(cond
+		   (inline `(function ,lambda-form))
+		   (regression-test::*compile-tests*
+		     `(compile nil ',lambda-form))
+		   (t `(eval ',lambda-form)))
+		  ,var)))
+	 (type-error
+	  (c)
+	  (let ((datum (type-error-datum c))
+		(expected-type (type-error-expected-type c)))
+	    (cond
+	     ((not (eql ,var datum))
+	      (list :datum-mismatch ,var datum))
+	     ((typep datum expected-type)
+	      (list :is-typep datum expected-type))
+	     (t (printable-p c))))))))))
+
+(declaim (special *mini-universe*))
+
+(defun check-type-error* (pred-fn guard-fn &optional (universe *mini-universe*))
+  "Check that for all elements in some set, either guard-fn is true or
+   pred-fn signals a type error."
+  (let (val)
+    (loop for e in universe
+	  unless (or (funcall guard-fn e)
+		     (equal
+		      (setf val (multiple-value-list
+				 (signals-type-error x e (funcall pred-fn x) :inline t)))
+		      '(t)))
+	collect (list e val))))
+
+(defmacro check-type-error (&body args)
+  `(locally (declare (optimize safety)) (check-type-error* ,@args)))
+
+(defun printable-p (obj)
+  "Returns T iff obj can be printed to a string."
+  (with-standard-io-syntax
+   (let ((*print-readably* nil)
+	 (*print-escape* nil))
+     (declare (optimize safety))
+     (handler-case (and (stringp (write-to-string obj)) t)
+		   (condition (c) (declare (ignore c)) nil)))))
+
+(defun make-special-string (string &key fill adjust displace base)
+  (let* ((len (length string))
+	 (len2 (if fill (+ len 4) len))
+	 (etype (if base 'base-char 'character)))
+    (if displace
+	(let ((s0 (make-array (+ len2 5)
+			      :initial-contents
+			      (concatenate 'string
+					   (make-string 2 :initial-element #\X)
+					   string
+					   (make-string (if fill 7 3)
+							:initial-element #\Y))
+			      :element-type etype)))
+	  (make-array len2 :element-type etype
+		      :adjustable adjust
+		      :fill-pointer (if fill len nil)
+		      :displaced-to s0
+		      :displaced-index-offset 2))
+      (make-array len2 :element-type etype
+		  :initial-contents
+		  (if fill (concatenate 'string string "ZZZZ") string)
+		  :fill-pointer (if fill len nil)
+		  :adjustable adjust))))
+
+(defmacro do-special-strings ((var string-form &optional ret-form) &body forms)
+  (let ((string (gensym))
+	(fill (gensym "FILL"))
+	(adjust (gensym "ADJUST"))
+	(base (gensym "BASE"))
+	(displace (gensym "DISPLACE")))
+    `(let ((,string ,string-form))
+       (dolist (,fill '(nil t) ,ret-form)
+	 (dolist (,adjust '(nil t))
+	   (dolist (,base '(nil t))
+	     (dolist (,displace '(nil t))
+	       (let ((,var (make-special-string
+			    ,string
+			    :fill ,fill :adjust ,adjust
+			    :base ,base :displace ,displace)))
+		 ,@forms))))))))
+
 ;;; A scaffold is a structure that is used to remember the object
 ;;; identities of the cons cells in a (noncircular) data structure.
 ;;; This lets us check if the data structure has been changed by
@@ -1307,6 +1478,13 @@ the condition to go uncaught if it canno
 	  (unuse-package package using-package)))
       (delete-package package))))
 
+(defun delete-all-versions (pathspec)
+  "Replace the versions field of the pathname specified by pathspec with
+   :wild, and delete all the files this refers to."
+  (let* ((wild-pathname (make-pathname :version :wild :defaults (pathname pathspec)))
+	 (truenames (directory wild-pathname)))
+    (mapc #'delete-file truenames)))
+
 (defconstant +fail-count-limit+ 20)
 
 (defmacro test-with-package-iterator (package-list-expr &rest symbol-types)
@@ -1455,3 +1633,5 @@ the condition to go uncaught if it canno
 		    (list n1)
 		    (random-partition n3 (- p 1 r))))))))))
 
+(defmacro expand-in-current-env (macro-form &environment env)
+  (macroexpand macro-form env))
--- /dev/null
+++ gcl-2.6.12/ansi-tests/broadcast-stream-streams.lsp
@@ -0,0 +1,30 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Thu Jan 29 22:06:28 2004
+;;;; Contains: Tests of BROADCAST-STREAM-STREAMS
+
+(in-package :cl-test)
+
+(deftest broadcast-stream-streams.1
+  (broadcast-stream-streams (make-broadcast-stream))
+  nil)
+
+(deftest broadcast-stream-streams.2
+  (equalt
+   (broadcast-stream-streams (make-broadcast-stream *standard-output*))
+   (list *standard-output*))
+  t)
+
+(deftest broadcast-stream-streams.error.1
+  (signals-error (broadcast-stream-streams) program-error)
+  t)
+
+(deftest broadcast-stream-streams.error.2
+  (signals-error (broadcast-stream-streams (make-broadcast-stream) nil)
+		 program-error)
+  t)
+
+
+
+
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/clear-input.lsp
@@ -0,0 +1,64 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Wed Jan 28 06:12:39 2004
+;;;; Contains: Tests of CLEAR-INPUT
+
+(in-package :cl-test)
+
+;;; These tests are limited, since whether an input stream can be
+;;; cleared is not well specified.
+
+(deftest clear-input.1
+  (loop for s in (list *debug-io* *query-io*
+		       *standard-input* *terminal-io*)
+	always (eq (clear-input s) nil))
+  t)
+
+(deftest clear-input.2
+  (clear-input)
+  nil)
+
+(deftest clear-input.3
+  (clear-input nil)
+  nil)
+
+(deftest clear-input.4
+  (clear-input t)
+  nil)
+
+(deftest clear-input.5
+  (with-input-from-string
+   (is "!?*")
+   (let ((*terminal-io* (make-two-way-stream is (make-broadcast-stream))))
+     (clear-input t)))
+  nil)
+
+(deftest clear-input.6
+  (with-input-from-string
+   (*standard-input* "345")
+   (clear-input nil))
+  nil)
+
+;;; Error cases
+
+(deftest clear-input.error.1
+  :notes (:assume-no-simple-streams)
+  (signals-error (clear-input t nil) program-error)
+  t)
+
+(deftest clear-input.error.2
+  :notes (:assume-no-simple-streams)
+  (signals-error (clear-input nil nil) program-error)
+  t)
+
+(deftest clear-input.error.3
+  (signals-error (clear-input t nil nil) program-error)
+  t)
+
+(deftest clear-input.error.4
+  (signals-error (clear-input nil nil nil) program-error)
+  t)
+
+(deftest clear-input.error.5
+  (check-type-error #'clear-input #'(lambda (x) (typep x '(or stream (member nil t)))))
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/clear-output.lsp
@@ -0,0 +1,53 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Wed Jan 28 06:43:17 2004
+;;;; Contains: Tests of CLEAR-OUTPUT
+
+(in-package :cl-test)
+
+(deftest clear-output.1
+  (progn (finish-output) (clear-output))
+  nil)
+
+(deftest clear-output.2
+  (progn (finish-output) (clear-output t))
+  nil)
+
+(deftest clear-output.3
+  (progn (finish-output) (clear-output nil))
+  nil)
+
+(deftest clear-output.4
+  (loop for s in (list *debug-io* *error-output* *query-io*
+		       *standard-output* *trace-output* *terminal-io*)
+	for dummy = (finish-output s)
+	for results = (multiple-value-list (clear-output s))
+	unless (equal results '(nil))
+	collect s)
+  nil)
+
+(deftest clear-output.5
+  (let ((os (make-string-output-stream)))
+    (let ((*terminal-io* (make-two-way-stream (make-string-input-stream "")
+					      os)))
+      (clear-output t)))
+  nil)
+
+(deftest clear-output.6
+  (let ((*standard-output* (make-string-output-stream)))
+    (clear-output nil))
+  nil)
+
+;;; Error tests
+
+(deftest clear-output.error.1
+  (signals-error (clear-output nil nil) program-error)
+  t)
+
+(deftest clear-output.error.2
+  (signals-error (clear-output t nil) program-error)
+  t)
+
+(deftest clear-output.error.3
+  (check-type-error #'clear-output #'(lambda (x) (typep x '(or stream (member nil t)))))
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/compile-file-test-file.lsp
@@ -0,0 +1,3 @@
+(in-package "CL-TEST")
+
+(defun compile-file-test-fun.1 () nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/concatenated-stream-streams.lsp
@@ -0,0 +1,67 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Feb 14 08:43:45 2004
+;;;; Contains: Tests of CONCATENATED-STREAM-STREAMS
+
+(in-package :cl-test)
+
+(deftest concatenated-stream-streams.1
+  (concatenated-stream-streams (make-concatenated-stream))
+  nil)
+
+(deftest concatenated-stream-streams.2
+  (equalt (list (list *standard-input*))
+	  (multiple-value-list
+	   (concatenated-stream-streams
+	    (make-concatenated-stream *standard-input*))))
+  t)
+
+(deftest concatenated-stream-streams.3
+  (with-input-from-string
+   (s1 "abc")
+   (with-input-from-string
+    (s2 "def")
+    (let ((s (make-concatenated-stream s1 s2)))
+      (equalt (list (list s1 s2))
+	      (multiple-value-list
+	       (concatenated-stream-streams s))))))
+  t)
+
+(deftest concatenated-stream-streams.4
+  (with-input-from-string
+   (s1 "")
+   (with-input-from-string
+    (s2 "def")
+    (let ((s (make-concatenated-stream s1 s2)))
+      (equalt (list (list s1 s2))
+	      (multiple-value-list
+	       (concatenated-stream-streams s))))))
+  t)
+
+(deftest concatenated-stream-streams.5
+  (with-input-from-string
+   (s1 "")
+   (with-input-from-string
+    (s2 "def")
+    (let ((s (make-concatenated-stream s1 s2)))
+      (values
+       (read-char s)
+       (equalt (list (list s2))
+	       (multiple-value-list
+		(concatenated-stream-streams s)))))))
+  #\d t)
+
+;;; Error cases
+
+(deftest concatenated-stream-streams.error.1
+  (signals-error (concatenated-stream-streams) program-error)
+  t)
+
+(deftest concatenated-stream-streams.error.2
+  (signals-error (concatenated-stream-streams
+		  (make-concatenated-stream)
+		  nil)
+		 program-error)
+  t)
+
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/delete-file.lsp
@@ -0,0 +1,95 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Jan 13 18:42:29 2004
+;;;; Contains: Tests for DELETE-FILE
+
+(in-package :cl-test)
+
+(deftest delete-file.1
+  (let ((pn "scratchfile.txt"))
+    (unless (probe-file pn)
+      (with-open-file (s pn :direction :output)
+		      (format s "Contents~%")))
+    (values
+     (notnot (probe-file pn))
+     (multiple-value-list (delete-file pn))
+     (probe-file pn)))
+  t (t) nil)
+
+(deftest delete-file.2
+  (let ((pn #p"scratchfile.txt"))
+    (unless (probe-file pn)
+      (with-open-file (s pn :direction :output)
+		      (format s "Contents~%")))
+    (values
+     (notnot (probe-file pn))
+     (multiple-value-list (delete-file pn))
+     (probe-file pn)))
+  t (t) nil)
+
+(deftest delete-file.3
+  (let ((pn "CLTEST:SCRATCHFILE.TXT"))
+    (assert (typep (pathname pn) 'logical-pathname))
+    (unless (probe-file pn)
+      (with-open-file (s pn :direction :output)
+		      (format s "Contents~%")))
+    (values
+     (notnot (probe-file pn))
+     (multiple-value-list (delete-file pn))
+     (probe-file pn)))
+  t (t) nil)
+
+(deftest delete-file.4
+  (let ((pn "CLTEST:SCRATCHFILE.TXT"))
+    (assert (typep (pathname pn) 'logical-pathname))
+    (unless (probe-file pn)
+      (with-open-file (s pn :direction :output)
+		      (format s "Contents~%")))
+    (let ((s (open pn :direction :input)))
+      (close s)
+      (values
+       (notnot (probe-file pn))
+       (multiple-value-list (delete-file s))
+       (probe-file pn))))
+  t (t) nil)
+
+;;; Specialized string tests
+
+(deftest delete-file.5
+  (do-special-strings
+   (pn "scratchfile.txt" nil)
+   (unless (probe-file pn)
+     (with-open-file (s pn :direction :output)
+		     (format s "Contents~%")))
+   (assert (probe-file pn))
+   (assert (equal (multiple-value-list (delete-file pn)) '(t)))
+   (assert (not (probe-file pn))))
+  nil)
+
+;;; Error tests
+
+(deftest delete-file.error.1
+  (signals-error (delete-file) program-error)
+  t)
+
+(deftest delete-file.error.2
+  (let ((pn "scratch.txt"))
+    (unless (probe-file pn)
+      (with-open-file (s pn :direction :output)
+		      (format s "Contents~%")))
+    (values
+     (notnot (probe-file pn))
+     (signals-error (delete-file "scratch.txt" nil) program-error)
+     (notnot (probe-file pn))
+     (delete-file pn)
+     (probe-file pn)))
+  t t t t nil)
+
+#|
+(deftest delete-file.error.3
+  (let ((pn "nonexistent.txt"))
+    (when (probe-file pn) (delete-file pn))
+    (signals-error (delete-file "nonexistent.txt") file-error))
+  t)
+|#
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/directory-namestring.lsp
@@ -0,0 +1,50 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Sep 12 06:21:42 2004
+;;;; Contains: Tests for DIRECTORY-NAMESTRING
+
+(in-package :cl-test)
+
+(deftest directory-namestring.1
+  (let* ((vals (multiple-value-list
+		(directory-namestring "directory-namestring.lsp")))
+	 (s (first vals)))
+    (if (and (null (cdr vals))
+	     (stringp s)
+	     (equal (directory-namestring s) s))
+	:good
+      vals))
+  :good)
+
+(deftest directory-namestring.2
+  (do-special-strings
+   (s "directory-namestring.lsp" nil)
+   (let ((ns (directory-namestring s)))
+     (assert (stringp ns))
+     (assert (string= (directory-namestring ns) ns))))
+  nil)
+
+;;; Lispworks makes another assumption about filename normalization
+;;; when using file streams as pathname designators, so this test
+;;; doesn't work there.
+;;; (This is another example of the difficulty of testing a feature
+;;;  in which so much is left up to the implementation.)
+#-lispworks
+(deftest directory-namestring.3
+  (let* ((name "directory-namestring.lsp")
+	 (pn (merge-pathnames (pathname name)))
+	 (name2 (with-open-file (s pn :direction :input)
+				(directory-namestring s)))
+	 (name3 (directory-namestring pn)))
+    (or (equalt name2 name3) (list name2 name3)))
+  t)
+
+;;; Error tests
+
+(deftest directory-namestring.error.1
+  (signals-error (directory-namestring) program-error)
+  t)
+
+(deftest directory-namestring.error.2
+  (signals-error (directory-namestring "directory-namestring.lsp" nil) program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/directory.lsp
@@ -0,0 +1,71 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Thu Jan  1 12:00:18 2004
+;;;; Contains: Tests of DIRECTORY
+
+(in-package :cl-test)
+
+(deftest directory.1
+  (directory "nonexistent")
+  nil)
+
+(deftest directory.2
+  (directory #p"nonexistent")
+  nil)
+
+(deftest directory.3
+  (directory "nonexistent" :allow-other-keys nil)
+  nil)
+
+(deftest directory.4
+  (directory "nonexistent" :allow-other-keys t :foo 'bar)
+  nil)
+
+(deftest directory.5
+  (directory "nonexistent" :foo 0 :allow-other-keys t)
+  nil)
+
+(deftest directory.6
+  (let* ((pattern-pathname (make-pathname :name :wild :type :wild
+					  :defaults *default-pathname-defaults*))
+	 (pathnames (directory pattern-pathname)))
+    (values
+     (remove-if #'pathnamep pathnames)
+     (loop for pn in pathnames
+	   unless (equal pn (truename pn))
+	   collect pn)
+;;     (loop for pn in pathnames
+;;	   unless (pathname-match-p pn pattern-pathname)
+;;	   collect pn))
+     ))
+  nil nil ;; nil
+  )
+
+(deftest directory.7
+  (let* ((pattern-pathname (make-pathname :name :wild :type :wild
+					  :defaults *default-pathname-defaults*))
+	 (pathnames (directory pattern-pathname)))
+    (loop for pn in pathnames
+	  unless (equal pn (probe-file pn))
+	  collect pn))
+  nil)
+
+(deftest directory.8
+  (let* ((pathname-pattern "CLTEST:*.*")
+	 (len (length (directory pathname-pattern))))
+    (if (< len 300) len nil))
+  nil)
+
+;;; Specialized string tests
+
+(deftest directory.9
+  (do-special-strings
+   (s "nonexistent" nil)
+   (assert (null (directory s))))
+  nil)
+
+;;; Error tests
+
+(deftest directory.error.1
+  (signals-error (directory) program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/echo-stream-input-stream.lsp
@@ -0,0 +1,27 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Thu Feb 12 04:30:40 2004
+;;;; Contains: Tests of ECHO-STREAM-INPUT-STREAM
+
+(in-package :cl-test)
+
+(deftest echo-stream-input-stream.1
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (equalt (multiple-value-list (echo-stream-input-stream s))
+	    (list is)))
+  t)
+
+(deftest echo-stream-input-stream.error.1
+  (signals-error (echo-stream-input-stream) program-error)
+  t)
+
+(deftest echo-stream-input-stream.error.2
+  (signals-error (let* ((is (make-string-input-stream "foo"))
+			(os (make-string-output-stream))
+			(s (make-echo-stream is os)))
+		   (echo-stream-input-stream s nil))
+		 program-error)
+  t)
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/echo-stream-output-stream.lsp
@@ -0,0 +1,26 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Thu Feb 12 04:32:33 2004
+;;;; Contains: Tests off ECHO-STREAM-OUTPUT-STREAM
+
+(in-package :cl-test)
+
+(deftest echo-stream-output-stream.1
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (equalt (multiple-value-list (echo-stream-output-stream s))
+	    (list os)))
+  t)
+
+(deftest echo-stream-output-stream.error.1
+  (signals-error (echo-stream-output-stream) program-error)
+  t)
+
+(deftest echo-stream-output-stream.error.2
+  (signals-error (let* ((is (make-string-input-stream "foo"))
+			(os (make-string-output-stream))
+			(s (make-echo-stream is os)))
+		   (echo-stream-output-stream s nil))
+		 program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/enough-namestring.lsp
@@ -0,0 +1,84 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Sep 12 06:23:50 2004
+;;;; Contains: Tests of ENOUGH-NAMESTRING
+
+(in-package :cl-test)
+
+(deftest enough-namestring.1
+  (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp")))
+	 (s (first vals)))
+    (if (and (null (cdr vals))
+	     (stringp s)
+	     (equal (enough-namestring s) s))
+	:good
+      vals))
+  :good)
+
+(deftest enough-namestring.2
+  (do-special-strings
+   (s "enough-namestring.lsp" nil)
+   (let ((ns (enough-namestring s)))
+     (assert (stringp ns))
+     (assert (string= (enough-namestring ns) ns))))
+  nil)
+
+(deftest enough-namestring.3
+  (let* ((name "enough-namestring.lsp")
+	 (pn (merge-pathnames (pathname name)))
+	 (name2 (enough-namestring pn))
+	 (name3 (enough-namestring name)))
+    (or (equalt name2 name3) (list name2 name3)))
+  t)
+
+(deftest enough-namestring.4
+  (let* ((name "enough-namestring.lsp")
+	 (pn (merge-pathnames (pathname name)))
+	 (name2 (with-open-file (s pn :direction :input) (enough-namestring s)))
+	 (name3 (enough-namestring name)))
+    (or (equalt name2 name3) (list name2 name3)))
+  t)
+
+(deftest enough-namestring.5
+  (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp"
+						       *default-pathname-defaults*)))
+	 (s (first vals)))
+    (if (and (null (cdr vals))
+	     (stringp s)
+	     (equal (enough-namestring s) s))
+	:good
+      vals))
+  :good)
+
+(deftest enough-namestring.6
+  (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp"
+						       (namestring *default-pathname-defaults*))))
+	 (s (first vals)))
+    (if (and (null (cdr vals))
+	     (stringp s)
+	     (equal (enough-namestring s) s))
+	:good
+      vals))
+  :good)
+
+(deftest enough-namestring.7
+  (do-special-strings
+   (s (namestring *default-pathname-defaults*) nil)
+   (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp" s)))
+	 (s2 (first vals)))
+     (assert (null (cdr vals)))
+     (assert (stringp s2))
+     (assert (equal (enough-namestring s2) s2))))
+  nil)
+
+;;; Error tests
+
+(deftest enough-namestring.error.1
+  (signals-error (enough-namestring) program-error)
+  t)
+
+(deftest enough-namestring.error.2
+  (signals-error
+   (enough-namestring "enough-namestring.lsp" *default-pathname-defaults* nil)
+   program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/ensure-directories-exist.lsp
@@ -0,0 +1,166 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Mon Jan  5 20:53:03 2004
+;;;; Contains: Tests of ENSURE-DIRECTORIES-EXIST
+
+(in-package :cl-test)
+
+(deftest ensure-directories-exist.1
+  (let* ((pn (make-pathname :name "ensure-directories-exist.lsp"
+			    :defaults *default-pathname-defaults*))
+	 (results nil)
+	 (verbosity
+	  (with-output-to-string
+	    (*standard-output*)
+	    (setq results (multiple-value-list (ensure-directories-exist pn))))))
+    (values
+     (length results)
+     (equalt (truename pn) (truename (first results)))
+     (second results)
+     verbosity))
+  2 t nil "")
+
+(deftest ensure-directories-exist.2
+  (with-open-file
+   (s "ensure-directories-exist.lsp" :direction :input)
+   (let* ((results (multiple-value-list (ensure-directories-exist s))))
+     (values
+      (length results)
+      (equalt (truename (first results)) (truename s))
+      (second results))))
+   2 t nil)
+
+(deftest ensure-directories-exist.3
+  (let ((s (open "ensure-directories-exist.lsp" :direction :input)))
+    (close s)
+    (let* ((results (multiple-value-list (ensure-directories-exist s))))
+      (values
+       (length results)
+       (equalt (truename (first results)) (truename s))
+       (second results))))
+   2 t nil)
+
+(deftest ensure-directories-exist.4
+  (let* ((pn (make-pathname :name "ensure-directories-exist.lsp"
+			    :defaults *default-pathname-defaults*))
+	 (results nil)
+	 (verbosity
+	  (with-output-to-string
+	    (*standard-output*)
+	    (setq results (multiple-value-list
+			   (ensure-directories-exist pn :verbose nil))))))
+    (values
+     (length results)
+     (equalt (truename pn) (truename (first results)))
+     (second results)
+     verbosity))
+  2 t nil "")
+
+(deftest ensure-directories-exist.5
+  (let* ((pn (make-pathname :name "ensure-directories-exist.lsp"
+			    :defaults *default-pathname-defaults*))
+	 (results nil)
+	 (verbosity
+	  (with-output-to-string
+	    (*standard-output*)
+	    (setq results (multiple-value-list
+			   (ensure-directories-exist pn :verbose t))))))
+    (values
+     (length results)
+     (equalt (truename pn) (truename (first results)))
+     (second results)
+     verbosity))
+  2 t nil "")
+
+(deftest ensure-directories-exist.6
+  (let* ((pn (make-pathname :name "ensure-directories-exist.lsp"
+			    :defaults *default-pathname-defaults*))
+	 (results nil)
+	 (verbosity
+	  (with-output-to-string
+	    (*standard-output*)
+	    (setq results (multiple-value-list
+			   (ensure-directories-exist
+			    pn :allow-other-keys nil))))))
+    (values
+     (length results)
+     (equalt (truename pn) (truename (first results)))
+     (second results)
+     verbosity))
+  2 t nil "")
+
+(deftest ensure-directories-exist.7
+  (let* ((pn (make-pathname :name "ensure-directories-exist.lsp"
+			    :defaults *default-pathname-defaults*))
+	 (results nil)
+	 (verbosity
+	  (with-output-to-string
+	    (*standard-output*)
+	    (setq results (multiple-value-list
+			   (ensure-directories-exist
+			    pn :allow-other-keys t :nonsense t))))))
+    (values
+     (length results)
+     (equalt (truename pn) (truename (first results)))
+     (second results)
+     verbosity))
+  2 t nil "")
+
+;;; Case where directory shouldn't exist
+
+;; The directort ansi-tests/scratch must not exist before this
+;; test is run
+(deftest ensure-directories-exist.8
+  (let* ((subdir (make-pathname :directory '(:relative "scratch")
+				:defaults *default-pathname-defaults*))
+	 (pn (make-pathname :name "foo" :type "txt"
+			    :defaults subdir)))
+    (ignore-errors (delete-file pn) (delete-file subdir))
+    (assert (not (probe-file pn)) ()
+	    "Delete subdirectory scratch and its contents!")
+    (let* ((results nil)
+	   (verbosity
+	    (with-output-to-string
+	      (*standard-output*)
+	      (setq results (multiple-value-list (ensure-directories-exist pn)))))
+	   (result-pn (first results))
+	   (created (second results)))
+      ;; Create the file and write to it
+      (with-open-file (*standard-output*
+		       pn :direction :output :if-exists :error
+		       :if-does-not-exist :create)
+		      (print nil))		      
+      (values
+       (length results)
+       (notnot created)
+       (equalt pn result-pn)
+       (notnot (probe-file pn))
+       verbosity
+       )))
+  2 t t t "")
+
+;;; Specialized string tests
+
+(deftest ensure-directories-exist.9
+  (do-special-strings
+   (str "ensure-directories-exist.lsp" nil)
+   (let* ((results (multiple-value-list (ensure-directories-exist str))))
+     (assert (eql (length results) 2))
+     (assert (equalt (truename (first results)) (truename str)))
+     (assert (null (second results)))))
+  nil)
+
+;; FIXME
+;; Need to add a LPN test
+
+(deftest ensure-directories-exist.error.1
+  (signals-error-always
+   (ensure-directories-exist
+    (make-pathname :directory '(:relative :wild)
+		   :defaults *default-pathname-defaults*))
+   file-error)
+  t t)
+
+(deftest ensure-directories-exist.error.2
+  (signals-error (ensure-directories-exist) program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/file-author.lsp
@@ -0,0 +1,88 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Jan  6 05:41:06 2004
+;;;; Contains: Tests of FILE-AUTHOR
+
+(in-package :cl-test)
+
+(deftest file-author.1
+  (loop for pn in
+	(directory (make-pathname :name :wild :type :wild
+				  :defaults *default-pathname-defaults*))
+	for author = (file-author pn)
+	unless (or (null author) (stringp author))
+	collect (list pn author))
+  nil)
+
+(deftest file-author.2
+  (let ((author (file-author "file-author.lsp")))
+    (if (or (null author) (stringp author))
+	nil
+      author))
+  nil)
+
+(deftest file-author.3
+  (let ((author (file-author #p"file-author.lsp")))
+    (if (or (null author) (stringp author))
+	nil
+      author))
+  nil)
+
+(deftest file-author.4
+  (let ((author (file-author (truename "file-author.lsp"))))
+    (if (or (null author) (stringp author))
+	nil
+      author))
+  nil)
+
+(deftest file-author.5
+  (let ((author (with-open-file (s "file-author.lsp" :direction :input)
+				(file-author s))))
+    (if (or (null author) (stringp author))
+	nil
+      author))
+  nil)
+
+(deftest file-author.6
+  (let ((author (let ((s (open "file-author.lsp" :direction :input)))
+		  (close s)
+		  (file-author s))))
+    (if (or (null author) (stringp author))
+	nil
+      author))
+  nil)
+
+;;; Specialized string tests
+
+(deftest file-author.7
+  (do-special-strings
+   (s "file-author.lsp" nil)
+   (assert (equal (file-author s) (file-author "file-author.lsp"))))
+  nil)
+
+;;; FIXME
+;;; Add LPN test
+
+;;; Error tests
+
+(deftest file-author.error.1
+  (signals-error (file-author) program-error)
+  t)
+
+(deftest file-author.error.2
+  (signals-error (file-author "file-author.lsp" nil) program-error)
+  t)
+
+(deftest file-author.error.3
+  (signals-error-always
+   (file-author (make-pathname :name :wild :type "lsp"
+			       :defaults *default-pathname-defaults*))
+   file-error)
+  t t)
+
+(deftest file-author.error.4
+  (signals-error-always
+   (file-author (make-pathname :name "file-author" :type :wild
+			       :defaults *default-pathname-defaults*))
+   file-error)
+  t t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/file-error.lsp
@@ -0,0 +1,89 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Jan 13 19:10:02 2004
+;;;; Contains: Tests of the FILE-ERROR condition, and associated accessor function
+
+(in-package :cl-test)
+
+(deftest file-error.1
+  (let ((pn (make-pathname :name :wild
+			   :type "txt"
+			   :version :newest
+			   :defaults *default-pathname-defaults*)))
+    (handler-case
+     (probe-file pn)
+     (error (c)
+	    (values
+	     (notnot (typep c 'file-error))
+	     (if (equalp (file-error-pathname c) pn)
+		 t
+	       (list (file-error-pathname c) pn))))))
+  t t)
+
+(deftest file-error-pathname.1
+  (let ((c (make-condition 'file-error :pathname "foo.txt")))
+    (values
+     (notnot (typep c 'file-error))
+     (eqlt (class-of c) (find-class 'file-error))
+     (file-error-pathname c)))
+  t t "foo.txt")
+
+(deftest file-error-pathname.2
+  (let ((c (make-condition 'file-error :pathname #p"foo.txt")))
+    (values
+     (notnot (typep c 'file-error))
+     (eqlt (class-of c) (find-class 'file-error))
+     (equalt #p"foo.txt" (file-error-pathname c))))
+  t t t)
+
+(deftest file-error-pathname.3
+  (let ((c (make-condition 'file-error :pathname "CLTEST:FOO.TXT")))
+    (values
+     (notnot (typep c 'file-error))
+     (eqlt (class-of c) (find-class 'file-error))
+     (equalpt "CLTEST:FOO.TXT"
+	      (file-error-pathname c))))
+  t t t)
+
+(deftest file-error-pathname.4
+  (let ((c (make-condition 'file-error :pathname (logical-pathname "CLTEST:FOO.TXT"))))
+    (values
+     (notnot (typep c 'file-error))
+     (eqlt (class-of c) (find-class 'file-error))
+     (equalpt (logical-pathname "CLTEST:FOO.TXT")
+	      (file-error-pathname c))))
+  t t t)
+
+(deftest file-error-pathname.5
+  (with-open-file (s "file-error.lsp" :direction :input)
+		  (let ((c (make-condition 'file-error :pathname s)))
+		    (values
+		     (notnot (typep c 'file-error))
+		     (eqlt (class-of c) (find-class 'file-error))
+		     (equalpt s (file-error-pathname c)))))
+  t t t)
+
+(deftest file-error-pathname.6
+  (let ((s (open "file-error.lsp" :direction :input)))
+    (close s)
+    (let ((c (make-condition 'file-error :pathname s)))
+      (values
+       (notnot (typep c 'file-error))
+       (eqlt (class-of c) (find-class 'file-error))
+       (equalpt s (file-error-pathname c)))))
+  t t t)
+
+(deftest file-error-pathname.error.1
+  (signals-error (file-error-pathname) program-error)
+  t)
+
+(deftest file-error-pathname.error.2
+  (signals-error
+   (file-error-pathname (make-condition 'file-error :pathname "foo.txt") nil)
+   program-error)
+  t)
+
+
+
+
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/file-length.lsp
@@ -0,0 +1,176 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Wed Jan 21 06:21:11 2004
+;;;; Contains: Tests of FILE-LENGTH
+
+(in-package :cl-test)
+
+(deftest file-length.error.1
+  (signals-error (file-length) program-error)
+  t)
+
+(deftest file-length.error.2
+  (signals-error
+   (with-open-file (is "file-length.lsp" :direction :input)
+		   (file-length is nil))
+   program-error)
+  t)
+
+(deftest file-length.error.3
+  (loop for x in *mini-universe*
+	unless (or (typep x 'file-stream)
+		   (typep x 'broadcast-stream)
+		   (handler-case (progn (file-length x) nil)
+				 (type-error (c)
+					     (assert (not (typep x (type-error-expected-type c))))
+					     t)
+				 (condition () nil)))
+	collect x)
+  nil)
+
+(deftest file-length.error.4
+  :notes (:assume-no-simple-streams :assume-no-gray-streams)
+  (signals-error (with-input-from-string (s "abc") (file-length s))
+		 type-error)
+  t)
+
+(deftest file-length.error.5
+  (signals-error
+   (with-open-file
+    (is "file-length.lsp" :direction :input)
+    (with-open-file
+     (os "tmp.txt" :direction :output :if-exists :supersede)
+     (let ((s (make-two-way-stream is os)))
+       (unwind-protect (file-length s) (close s)))))
+   type-error)
+  t)
+
+(deftest file-length.error.6
+  (signals-error
+   (with-open-file
+    (is "file-length.lsp" :direction :input)
+    (with-open-file
+     (os "tmp.txt" :direction :output :if-exists :supersede)
+     (let ((s (make-echo-stream is os)))
+       (unwind-protect (file-length s) (close s)))))
+   type-error)
+  t)
+
+(deftest file-length.error.8
+  (with-open-file
+   (os "tmp.txt" :direction :output :if-exists :supersede)
+   (let ((s (make-broadcast-stream os)))
+     (eqlt (file-length s) (file-length os))))
+  t)
+
+(deftest file-length.error.9
+  (signals-type-error s (make-concatenated-stream)
+		      (unwind-protect (file-length s) (close s)))
+  t)
+
+(deftest file-length.error.10
+  (signals-error
+   (with-open-file
+    (is "file-length.lsp" :direction :input)
+    (let ((s (make-concatenated-stream is)))
+      (unwind-protect (file-length s) (close s))))
+   type-error)
+  t)
+
+(deftest file-length.error.11
+  :notes (:assume-no-simple-streams :assume-no-gray-streams)
+  (signals-type-error s (make-string-input-stream "abcde")
+		      (unwind-protect (file-length s) (close s)))
+  t)
+
+(deftest file-length.error.12
+  :notes (:assume-no-simple-streams :assume-no-gray-streams)
+  (signals-type-error s (make-string-output-stream)
+		      (unwind-protect (file-length s) (close s)))
+  t)
+
+;;; Non-error tests
+
+(deftest file-length.1
+  (let ((results (multiple-value-list
+		  (with-open-file
+		   (is "file-length.lsp" :direction :input)
+		   (file-length is)))))
+    (and (= (length results) 1)
+	 (typep (car results) '(integer 1))
+	 t))
+  t)
+
+(deftest file-length.2
+  (loop for i from 1 to 32
+	for etype = `(unsigned-byte ,i)
+	for e = (max 0 (- (ash 1 i) 5))
+	for os = (open "tmp.dat" :direction :output
+			       :if-exists :supersede
+			       :element-type etype)
+	do (loop repeat 17 do (write-byte e os))
+	do (finish-output os)
+	unless (= (file-length os) 17)
+	collect (list i (file-length os))
+	do (close os))
+  nil)
+
+(deftest file-length.3
+  (loop for i from 1 to 32
+	for etype = `(unsigned-byte ,i)
+	for e = (max 0 (- (ash 1 i) 5))
+	for os = (open "tmp.dat" :direction :output
+			       :if-exists :supersede
+			       :element-type etype)
+	for len = 0
+	do (loop repeat 17 do (write-byte e os))
+	do (close os)
+	unless (let ((is (open "tmp.dat" :direction :input
+			       :element-type etype)))
+		 (prog1
+		     (= (file-length is) 17)
+		   (close is)))
+	collect i)
+  nil)
+
+(deftest file-length.4
+  (loop for i from 33 to 100
+	for etype = `(unsigned-byte ,i)
+	for e = (max 0 (- (ash 1 i) 5))
+	for os = (open "tmp.dat" :direction :output
+			       :if-exists :supersede
+			       :element-type etype)
+	do (loop repeat 17 do (write-byte e os))
+	do (finish-output os)
+	unless (= (file-length os) 17)
+	collect (list i (file-length os))
+	do (close os))
+  nil)
+
+(deftest file-length.5
+  (loop for i from 33 to 100
+	for etype = `(unsigned-byte ,i)
+	for e = (max 0 (- (ash 1 i) 5))
+	for os = (open "tmp.dat" :direction :output
+			       :if-exists :supersede
+			       :element-type etype)
+	for len = 0
+	do (loop repeat 17 do (write-byte e os))
+	do (close os)
+	unless (let ((is (open "tmp.dat" :direction :input
+			       :element-type etype)))
+		 (prog1
+		     (= (file-length is) 17)
+		   (close is)))
+	collect i)
+  nil)		 
+
+(deftest file-length.6
+  (with-open-file
+   (*foo* "file-length.lsp" :direction :input)
+   (declare (special *foo*))
+   (let ((s (make-synonym-stream '*foo*)))
+     (unwind-protect
+	 (typep* (file-length s) '(integer 1))
+	(close s))))
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/file-namestring.lsp
@@ -0,0 +1,44 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Sep 11 07:40:47 2004
+;;;; Contains: Tests for FILE-NAMESTRING
+
+(in-package :cl-test)
+
+(deftest file-namestring.1
+  (let* ((vals (multiple-value-list
+		(file-namestring "file-namestring.lsp")))
+	 (s (first vals)))
+    (if (and (null (cdr vals))
+	     (stringp s)
+	     (equal (file-namestring s) s))
+	:good
+      vals))
+  :good)
+
+(deftest file-namestring.2
+  (do-special-strings
+   (s "file-namestring.lsp" nil)
+   (let ((ns (file-namestring s)))
+     (assert (stringp ns))
+     (assert (string= (file-namestring ns) ns))))
+  nil)
+
+(deftest file-namestring.3
+  (let* ((name "file-namestring.lsp")
+	 (pn (merge-pathnames (pathname name)))
+	 (name2 (with-open-file (s pn :direction :input)
+				(file-namestring s)))
+	 (name3 (file-namestring pn)))
+    (or (equalt name2 name3) (list name2 name3)))
+  t)
+
+;;; Error tests
+
+(deftest file-namestring.error.1
+  (signals-error (file-namestring) program-error)
+  t)
+
+(deftest file-namestring.error.2
+  (signals-error (file-namestring "file-namestring.lsp" nil) program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/file-position.lsp
@@ -0,0 +1,170 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Thu Jan 22 03:02:31 2004
+;;;; Contains: Tests of FILE-POSITION
+
+(in-package :cl-test)
+
+(deftest file-position.1
+  (with-open-file (is "file-position.lsp":direction :input)
+		  (file-position is))
+  0)
+
+(deftest file-position.2
+  (with-open-file (is "file-position.lsp":direction :input)
+		  (values
+		   (multiple-value-list
+		    (notnot-mv (file-position is :start)))
+		   (file-position is)))
+			      
+  (t) 0)
+
+(deftest file-position.3
+  (with-open-file (is "file-position.lsp":direction :input)
+		  (values
+		   (multiple-value-list
+		    (notnot-mv (file-position is :end)))
+		   (notnot (> (file-position is) 0))))
+  (t) t)
+
+(deftest file-position.4
+  (with-open-file
+   (is "file-position.lsp":direction :input)
+   (values
+    (file-position is)
+    (read-char is)
+    (notnot (> (file-position is) 0))))
+  0 #\; t)
+
+(deftest file-position.5
+  (with-open-file
+   (os "tmp.dat":direction :output
+       :if-exists :supersede)
+   (values
+    (file-position os)
+    (write-char #\x os)
+    (notnot (> (file-position os) 0))))
+  0 #\x t)
+
+(deftest file-position.6
+  (with-open-file
+   (os "tmp.dat":direction :output
+       :if-exists :supersede)
+   (let ((p1 (file-position os))
+	 (delta (file-string-length os #\x)))
+     (write-char #\x os)
+     (let ((p2 (file-position os)))
+       (or (null p1) (null p2) (null delta)
+	   (=t (+ p1 delta) p2)))))
+  t)
+
+;;; Byte streams
+
+(deftest file-position.7
+  (loop for len from 1 to 32
+	for n = (ash 1 len)
+	do (with-open-file
+	    (os "tmp.dat" :direction :output
+		:if-exists :supersede
+		:element-type `(unsigned-byte ,len))
+	    (loop for i from 0 below 100
+		  for r = (logand (1- n) i)
+		  for pos = (file-position os)
+		  do (assert (or (not pos) (eql pos i)))
+		  do (write-byte r os)))
+	do (with-open-file
+	    (is "tmp.dat" :direction :input
+		:element-type `(unsigned-byte ,len))
+	    (loop for i from 0 below 100
+		  for pos = (file-position is)
+		  do (assert (or (not pos) (eql pos i)))
+		  do (let ((byte (read-byte is)))
+		       (assert (eql byte (logand (1- n) i)))))))
+  nil)
+
+(deftest file-position.8
+  (loop for len from 33 to 100
+	for n = (ash 1 len)
+	do (with-open-file
+	    (os "tmp.dat" :direction :output
+		:if-exists :supersede
+		:element-type `(unsigned-byte ,len))
+	    (loop for i from 0 below 100
+		  for r = (logand (1- n) i)
+		  for pos = (file-position os)
+		  do (assert (or (not pos) (eql pos i)))
+		  do (write-byte r os)))
+	do (with-open-file
+	    (is "tmp.dat" :direction :input
+		:element-type `(unsigned-byte ,len))
+	    (loop for i from 0 below 100
+		  for pos = (file-position is)
+		  do (assert (or (not pos) (eql pos i)))
+		  do (let ((byte (read-byte is)))
+		       (assert (eql byte (logand (1- n) i)))))))
+  nil)
+
+(deftest file-position.9
+  (with-input-from-string
+   (s "abcdefghijklmnopqrstuvwxyz")
+   (loop repeat 26
+	 for p = (file-position s)
+	 unless (or (not p)
+		    (progn
+		      (file-position s p)
+		      (eql (file-position s) p)))
+	 collect p
+	 do (read-char s)))
+  nil)
+
+(deftest file-position.10
+  (with-output-to-string
+   (s)
+   (loop repeat 26
+	 for p = (file-position s)
+	 unless (or (not p)
+		    (progn
+		      (file-position s p)
+		      (eql (file-position s) p)))
+	 collect p
+	 do (write-char #\x s)))
+  "xxxxxxxxxxxxxxxxxxxxxxxxxx")
+
+;;; Error tests
+
+(deftest file-position.error.1
+  (signals-error (file-position) program-error)
+  t)
+
+(deftest file-position.error.2
+  (signals-error
+   (file-position (make-string-input-stream "abc") :start nil)
+   program-error)
+  t)
+
+;;; It's not clear what 'too large' means -- can we set the
+;;; file position to a point where the file may later be extended
+;;; by some other writer?
+#|
+(deftest file-position.error.3
+  (signals-error
+   (with-open-file
+    (is "file-position.lsp" :direction :input)
+    (flet ((%fail () (error 'type-error)))
+      (unless (file-position is :end) (%fail))
+      (let ((fp (file-position is)))
+	(unless fp (%fail))
+	(file-position is (+ 1000000 fp)))))
+   error)
+  t)
+
+(deftest file-position.error.4
+  (signals-error
+   (with-open-file
+    (is "file-position.lsp" :direction :input)
+    (file-position is 1000000000000000000000))
+   error)
+  t)
+|#
+
+  
\ No newline at end of file
--- /dev/null
+++ gcl-2.6.12/ansi-tests/file-string-length.lsp
@@ -0,0 +1,73 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Thu Jan 22 21:34:04 2004
+;;;; Contains: Tests of FILE-STRING-LENGTH
+
+(in-package :cl-test)
+
+(deftest file-string-length.1
+  (with-open-file 
+    (s "tmp.dat" :direction :output
+       :if-exists :supersede)
+    (loop for x across +standard-chars+
+	  for len = (file-string-length s x)
+	  do (assert (typep len '(or null (integer 0))))
+	  do (let ((pos1 (file-position s)))
+	       (write-char x s)
+	       (let ((pos2 (file-position s)))
+		 (when (and pos1 pos2 len)
+		   (assert (= (+ pos1 len) pos2)))))))
+  nil)
+
+(deftest file-string-length.2
+  (with-open-file 
+    (s "tmp.dat" :direction :output
+       :if-exists :supersede)
+    (loop for x across +standard-chars+
+	  for len = (file-string-length s (string x))
+	  do (assert (typep len '(or null (integer 0))))
+	  do (let ((pos1 (file-position s)))
+	       (write-sequence (string x) s)
+	       (let ((pos2 (file-position s)))
+		 (when (and pos1 pos2 len)
+		   (assert (= (+ pos1 len) pos2)))))))
+  nil)
+
+(deftest file-string-length.3
+  (with-open-file
+   (stream "tmp.dat" :direction :output
+	   :if-exists :supersede)
+   (let* ((s1 "abcde")
+	  (n (file-string-length stream s1)))
+     (do-special-strings
+      (s2 s1 nil)
+      (assert (= (file-string-length stream s2) n)))))
+  nil)
+
+;;; Error tests
+
+(deftest file-string-length.error.1
+  (signals-error (file-string-length) program-error)
+  t)
+
+(deftest file-string-length.error.2
+  (signals-error
+   (with-open-file 
+    (s "tmp.dat" :direction :output
+       :if-exists :supersede)
+    (file-string-length s))
+   program-error)
+  t)
+
+(deftest file-string-length.error.3
+  (signals-error
+   (with-open-file 
+    (s "tmp.dat" :direction :output
+       :if-exists :supersede)
+    (file-string-length s #\x nil))
+   program-error)
+  t)
+
+
+  
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/file-write-date.lsp
@@ -0,0 +1,89 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Jan  6 06:01:35 2004
+;;;; Contains: Tests for FILE-WRITE-DATE
+
+(in-package :cl-test)
+
+(deftest file-write-date.1
+  (let* ((pn "file-write-date.lsp")
+	 (date (file-write-date pn))
+	 (time (get-universal-time)))
+    (or (null date)
+	(and (integerp date)
+	     (<= 0 date time)
+	     t)))
+  t)
+
+(deftest file-write-date.2
+  (let* ((pn #p"file-write-date.lsp")
+	 (date (file-write-date pn))
+	 (time (get-universal-time)))
+    (or (null date)
+	(and (integerp date)
+	     (<= 0 date time)
+	     t)))
+  t)
+	     
+(deftest file-write-date.3
+  (let* ((pn (truename "file-write-date.lsp"))
+	 (date (file-write-date pn))
+	 (time (get-universal-time)))
+    (or (null date)
+	(and (integerp date)
+	     (<= 0 date time)
+	     t)))
+  t)
+
+(deftest file-write-date.4
+  (loop for pn in (directory
+		   (make-pathname :name :wild :type :wild
+				  :defaults *default-pathname-defaults*))
+	for date = (file-write-date pn)
+	for time = (get-universal-time)
+	unless (or (null date)
+		   (<= 0 date time))
+	collect (list pn date time))
+  nil)
+
+(deftest file-write-date.5
+  (length (multiple-value-list (file-write-date "file-write-date.lsp")))
+  1)
+
+;;; Specialized string tests
+
+(deftest file-write-date.6
+  (let* ((str "file-write-date.lsp")
+	 (date (file-write-date str)))
+    (do-special-strings
+     (s str nil)
+     (assert (equal (file-write-date s) date))))
+  nil)
+
+;;; FIXME
+;;; Add LPN test
+
+;;; Error tests
+
+(deftest file-write-date.error.1
+  (signals-error (file-write-date) program-error)
+  t)
+
+(deftest file-write-date.error.2
+  (signals-error (file-write-date "file-write-date.lsp" nil)
+		 program-error)
+  t)
+
+(deftest file-write-date.error.3
+  (signals-error-always
+   (file-write-date (make-pathname :name :wild :type "lsp"
+				   :defaults *default-pathname-defaults*))
+   file-error)
+  t t)
+
+(deftest file-write-date.error.4
+  (signals-error-always
+   (file-write-date (make-pathname :name "file-write-date" :type :wild
+				   :defaults *default-pathname-defaults*))
+   file-error)
+  t t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/finish-output.lsp
@@ -0,0 +1,54 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Wed Jan 28 06:38:20 2004
+;;;; Contains: Tests of FINISH-OUTPUT
+
+(in-package :cl-test)
+
+(deftest finish-output.1
+  (finish-output)
+  nil)
+
+(deftest finish-output.2
+  (finish-output t)
+  nil)
+
+(deftest finish-output.3
+  (finish-output nil)
+  nil)
+
+(deftest finish-output.4
+  (loop for s in (list *debug-io* *error-output* *query-io*
+		       *standard-output* *trace-output* *terminal-io*)
+	for results = (multiple-value-list (finish-output s))
+	unless (equal results '(nil))
+	collect s)
+  nil)
+
+(deftest finish-output.5
+  (let ((os (make-string-output-stream)))
+    (let ((*terminal-io* (make-two-way-stream (make-string-input-stream "")
+					      os)))
+      (finish-output t)))
+  nil)
+
+(deftest finish-output.6
+  (let ((*standard-output* (make-string-output-stream)))
+    (finish-output nil))
+  nil)
+
+;;; Error tests
+
+(deftest finish-output.error.1
+  (signals-error (finish-output nil nil) program-error)
+  t)
+
+(deftest finish-output.error.2
+  (signals-error (finish-output t nil) program-error)
+  t)
+
+(deftest finish-output.error.3
+  (check-type-error #'finish-output
+		    #'(lambda (x) (typep x '(or stream (member nil t)))))
+  nil)
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/force-output.lsp
@@ -0,0 +1,56 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Wed Jan 28 06:41:46 2004
+;;;; Contains: Tests of FORCE-OUTPUT
+
+(in-package :cl-test)
+
+(deftest force-output.1
+  (force-output)
+  nil)
+
+(deftest force-output.2
+  (force-output t)
+  nil)
+
+(deftest force-output.3
+  (force-output nil)
+  nil)
+
+(deftest force-output.4
+  (loop for s in (list *debug-io* *error-output* *query-io*
+		       *standard-output* *trace-output* *terminal-io*)
+	for results = (multiple-value-list (force-output s))
+	unless (equal results '(nil))
+	collect s)
+  nil)
+
+(deftest force-output.5
+  (let ((os (make-string-output-stream)))
+    (let ((*terminal-io* (make-two-way-stream (make-string-input-stream "")
+					      os)))
+      (force-output t)))
+  nil)
+
+(deftest force-output.6
+  (let ((*standard-output* (make-string-output-stream)))
+    (force-output nil))
+  nil)
+
+
+;;; Error tests
+
+(deftest force-output.error.1
+  (signals-error (force-output nil nil) program-error)
+  t)
+
+(deftest force-output.error.2
+  (signals-error (force-output t nil) program-error)
+  t)
+
+(deftest force-output.error.3
+  (check-type-error #'force-output
+		    #'(lambda (x) (typep x '(or stream (member nil t)))))
+  nil)
+
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/fresh-line.lsp
@@ -0,0 +1,87 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Jan 18 20:41:18 2004
+;;;; Contains: Tests of FRESH-LINE
+
+(in-package :cl-test)
+
+(deftest fresh-line.1
+  (let (result)
+    (values
+     (with-output-to-string
+       (*standard-output*)
+       (write-char #\a)
+       (setq result (notnot (fresh-line))))
+     result))
+  #.(concatenate 'string "a" (string #\Newline))
+  t)
+
+(deftest fresh-line.2
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (write-char #\a s)
+       (setq result (notnot (fresh-line s))))
+     result))
+  #.(concatenate 'string "a" (string #\Newline))
+  t)
+
+(deftest fresh-line.3
+  (with-output-to-string
+    (s)
+    (write-char #\x s)
+    (fresh-line s)
+    (fresh-line s)
+    (write-char #\y s))
+  #.(concatenate 'string "x" (string #\Newline) "y"))
+
+(deftest fresh-line.4
+  (let (result)
+    (values
+     (with-output-to-string
+       (*standard-output*)
+       (setq result (multiple-value-list (fresh-line))))
+     result))
+  "" (nil))
+
+(deftest fresh-line.5
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (write-char #\Space s)
+       (setq result
+	     (list
+	      (multiple-value-list (notnot-mv (fresh-line s)))
+	      (multiple-value-list (fresh-line s))
+	      (multiple-value-list (fresh-line s)))))
+     result))
+  " 
+" ((t) (nil) (nil)))
+
+(deftest fresh-line.6
+  (with-output-to-string
+    (os)
+    (let ((*terminal-io* (make-two-way-stream *standard-input* os)))
+      (write-char #\a t)
+      (fresh-line t)
+      (finish-output t)))
+  #.(concatenate 'string (string #\a) (string #\Newline)))
+
+(deftest fresh-line.7
+  (with-output-to-string
+    (*standard-output*)
+    (write-char #\a nil)
+    (terpri nil))
+  #.(concatenate 'string (string #\a) (string #\Newline)))
+
+;;; Error tests
+
+(deftest fresh-line.error.1
+  (signals-error
+   (with-output-to-string
+     (s)
+     (fresh-line s nil))
+   program-error)
+  t)
--- gcl-2.6.12.orig/ansi-tests/gclload2.lsp
+++ gcl-2.6.12/ansi-tests/gclload2.lsp
@@ -46,6 +46,15 @@
 ;;; Tests of strings
 (load "load-strings.lsp")
 
+;;; Tests of pathnames
+(load "load-pathnames.lsp")
+
+;;; Tests of file operations
+(load "load-files.lsp")
+
+;;; Tests of streams
+(load "load-streams.lsp")
+
 ;;; Tests for character functions
 (compile-and-load "char-aux.lsp")
 (load "character.lsp")
--- /dev/null
+++ gcl-2.6.12/ansi-tests/get-output-stream-string.lsp
@@ -0,0 +1,32 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Feb 14 09:48:46 2004
+;;;; Contains: Tests of GET-OUTPUT-STREAM-STRING
+
+(in-package :cl-test)
+
+;; this function is used extensively elsewhere in the test suite
+
+(deftest get-output-stream-string.1
+  (let ((s (make-string-output-stream)))
+    (values
+     (get-output-stream-string s)
+     (write-string "abc" s)
+     (write-string "def" s)
+     (get-output-stream-string s)
+     (get-output-stream-string s)))
+  "" "abc" "def" "abcdef" "")
+
+;;; Error cases
+
+(deftest get-output-stream-string.error.1
+  (signals-error (get-output-stream-string) t)
+  t)
+
+(deftest get-output-stream-string.error.2
+  (signals-error (get-output-stream-string (make-string-output-stream) nil) t)
+  t)
+
+
+
+     
--- /dev/null
+++ gcl-2.6.12/ansi-tests/host-namestring.lsp
@@ -0,0 +1,49 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Sep 12 06:22:40 2004
+;;;; Contains: Tests of HOST-NAMESTRING
+
+(in-package :cl-test)
+
+(deftest host-namestring.1
+  (let* ((vals (multiple-value-list
+		(host-namestring "host-namestring.lsp")))
+	 (s (first vals)))
+    (if (and (null (cdr vals))
+	     (or (null s)
+		 (stringp s)
+		 ;; (equal (host-namestring s) s)
+		 ))
+	:good
+      vals))
+  :good)
+
+(deftest host-namestring.2
+  (do-special-strings
+   (s "host-namestring.lsp" nil)
+   (let ((ns (host-namestring s)))
+     (when ns
+       (assert (stringp ns))
+       ;; (assert (string= (host-namestring ns) ns))
+       )))
+  nil)
+
+(deftest host-namestring.3
+  (let* ((name "host-namestring.lsp")
+	 (pn (merge-pathnames (pathname name)))
+	 (name2 (with-open-file (s pn :direction :input)
+				(host-namestring s)))
+	 (name3 (host-namestring pn)))
+    (or (equalt name2 name3) (list name2 name3)))
+  t)
+
+;;; Error tests
+
+(deftest host-namestring.error.1
+  (signals-error (host-namestring) program-error)
+  t)
+
+(deftest host-namestring.error.2
+  (signals-error (host-namestring "host-namestring.lsp" nil) program-error)
+  t)
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/input-stream-p.lsp
@@ -0,0 +1,40 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Jan 13 19:39:27 2004
+;;;; Contains: Tests for INPUT-STREAM-P
+
+(in-package :cl-test)
+
+(deftest input-stream-p.1
+  (notnot-mv (input-stream-p *standard-input*))
+  t)
+
+(deftest input-stream-p.2
+  (notnot-mv (input-stream-p *terminal-io*))
+  t)
+
+(deftest input-stream-p.3
+  (with-open-file (s "input-stream-p.lsp" :direction :input)
+		  (notnot-mv (input-stream-p s)))
+  t)
+
+(deftest input-stream-p.4
+  (with-open-file (s "foo.txt" :direction :output
+		     :if-exists :supersede)
+		  (input-stream-p s))
+  nil)
+
+;;; Error tests
+
+(deftest input-stream-p.error.1
+  (signals-error (input-stream-p) program-error)
+  t)
+
+(deftest input-stream-p.error.2
+  (signals-error (input-stream-p *standard-input* nil)
+		 program-error)
+  t)
+
+(deftest input-stream-p.error.3
+  (check-type-error #'input-stream-p #'streamp)
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/interactive-stream-p.lsp
@@ -0,0 +1,28 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Jan 13 19:47:59 2004
+;;;; Contains: Tests of INTERACTIVE-STREAM-P
+
+(in-package :cl-test)
+
+(deftest interactive-stream-p.1
+  (let ((streams (list *debug-io* *error-output* *query-io*
+		       *standard-input* *standard-output*
+		       *trace-output* *terminal-io*)))
+    (mapc #'interactive-stream-p streams)
+    ;; no error should occur
+    nil)
+  nil)
+
+(deftest interactive-stream-p.error.1
+  (check-type-error #'interactive-stream-p #'streamp)
+  nil)
+
+(deftest interactive-stream-p.error.2
+  (signals-error (interactive-stream-p) program-error)
+  t)
+
+(deftest interactive-stream-p.error.3
+  (signals-error (interactive-stream-p *terminal-io* nil)
+		 program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/ldtest.lsp
@@ -0,0 +1 @@
+(in-package :cl-test) (defun LOAD-TEST-FUN-3 () :foo)
\ No newline at end of file
--- /dev/null
+++ gcl-2.6.12/ansi-tests/listen.lsp
@@ -0,0 +1,73 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Jan 27 21:16:39 2004
+;;;; Contains: Tests of LISTEN
+
+(in-package :cl-test)
+
+(deftest listen.1
+  (with-input-from-string (s "") (listen s))
+  nil)
+
+(deftest listen.2
+  (with-input-from-string (s "x") (notnot-mv (listen s)))
+  t)
+
+(deftest listen.3
+  (with-input-from-string (*standard-input* "") (listen))
+  nil)
+
+(deftest listen.4
+  (with-input-from-string (*standard-input* "A") (notnot-mv (listen)))
+  t)
+
+;;; (deftest listen.5
+;;;  (when (interactive-stream-p *standard-input*)
+;;;    (clear-input) (listen))
+;;;  nil)
+
+(deftest listen.6
+  (with-input-from-string
+   (s "x")
+   (values
+    (read-char s)
+    (listen s)
+    (unread-char #\x s)
+    (notnot (listen s))
+    (read-char s)))
+  #\x nil nil t #\x)
+
+(deftest listen.7
+  (with-open-file
+   (s "listen.lsp")
+   (values
+    (notnot (listen s))
+    (handler-case
+     (locally (declare (optimize safety))
+	      (loop (read-char s)))
+     (end-of-file () (listen s)))))
+  t nil)
+
+(deftest listen.8
+  (with-input-from-string
+   (is "abc")
+   (let ((*terminal-io* (make-two-way-stream is (make-broadcast-stream))))
+     (notnot-mv (listen t))))
+  t)
+
+(deftest listen.9
+  (with-input-from-string
+   (*standard-input* "345")
+   (notnot-mv (listen nil)))
+  t)
+
+;;; Error tests
+
+(deftest listen.error.1
+  :notes (:assume-no-simple-streams)
+  (signals-error (listen *standard-input* nil) program-error)
+  t)
+
+(deftest listen.error.2
+  (signals-error (listen *standard-input* nil nil) program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/load-files.lsp
@@ -0,0 +1,16 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Thu Jan  1 11:59:35 2004
+;;;; Contains: Load tests of section 20, 'Files'
+
+(in-package :cl-test)
+
+(load "directory.lsp")
+(load "probe-file.lsp")
+(load "ensure-directories-exist.lsp")
+(load "truename.lsp")
+(load "file-author.lsp")
+(load "file-write-date.lsp")
+(load "rename-file.lsp")
+(load "delete-file.lsp")
+(load "file-error.lsp")
--- /dev/null
+++ gcl-2.6.12/ansi-tests/load-logical-pathname-translations.lsp
@@ -0,0 +1,34 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Wed Dec 31 09:31:33 2003
+;;;; Contains: Tests (such as they are) for LOAD-LOGICAL-PATHNAME-TRANSLATIONS
+
+(in-package :cl-test)
+
+;;; The function LOAD-LOGICAL-PATHNAME-TRANSLATIONS is almost entirely
+;;; untestable, since the basic behavior is implementation defined.
+
+(deftest load-logical-pathname-translations.1
+  (load-logical-pathname-translations "CLTESTROOT")
+  nil)
+
+;;; Error cases
+
+(deftest load-logical-pathname-translations.error.1
+  (handler-case
+   (progn (load-logical-pathname-translations
+	   "THEREHADBETTERNOTBEAHOSTCALLEDTHIS")
+	 nil)
+   (error () :good))
+  :good)
+
+(deftest load-logical-pathname-translations.error.2
+  (signals-error (load-logical-pathname-translations)
+		 program-error)
+  t)
+
+(deftest load-logical-pathname-translations.error.3
+  (signals-error (load-logical-pathname-translations "CLTESTROOT" nil)
+		 program-error)
+  t)
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/load-pathnames.lsp
@@ -0,0 +1,36 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Nov 29 04:33:05 2003
+;;;; Contains: Load tests for pathnames and logical pathnames
+
+(in-package :cl-test)
+
+(compile-and-load "pathnames-aux.lsp")
+
+(load "pathnames.lsp")
+(load "pathname.lsp")
+(load "pathnamep.lsp")
+(load "make-pathname.lsp")
+(load "pathname-host.lsp")
+(load "pathname-device.lsp")
+(load "pathname-directory.lsp")
+(load "pathname-name.lsp")
+(load "pathname-type.lsp")
+(load "pathname-version.lsp")
+
+(load "load-logical-pathname-translations.lsp")
+(load "logical-pathname.lsp")
+(load "logical-pathname-translations.lsp")
+(load "translate-logical-pathname.lsp")
+
+(load "namestring.lsp")
+(load "file-namestring.lsp")
+(load "directory-namestring.lsp")
+(load "host-namestring.lsp")
+(load "enough-namestring.lsp")
+
+(load "wild-pathname-p.lsp")
+(load "merge-pathnames.lsp")
+(load "pathname-match-p.lsp")
+
+(load "parse-namestring.lsp")
\ No newline at end of file
--- /dev/null
+++ gcl-2.6.12/ansi-tests/load-streams.lsp
@@ -0,0 +1,57 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Jan 13 19:38:10 2004
+;;;; Contains: Load files containing tests for section 21 (streams)
+
+(in-package :cl-test)
+
+(load "input-stream-p.lsp")
+(load "output-stream-p.lsp")
+(load "interactive-stream-p.lsp")
+(load "open-stream-p.lsp")
+(load "stream-element-type.lsp")
+(load "streamp.lsp")
+(load "read-byte.lsp")
+(load "peek-char.lsp")
+(load "read-char.lsp")
+(load "read-char-no-hang.lsp")
+(load "terpri.lsp")
+(load "fresh-line.lsp")
+(load "unread-char.lsp")
+(load "write-char.lsp")
+(load "read-line.lsp")
+(load "write-string.lsp")
+(load "write-line.lsp")
+(load "read-sequence.lsp")
+(load "write-sequence.lsp")
+(load "file-length.lsp")
+(load "file-position.lsp")
+(load "file-string-length.lsp")
+(load "open.lsp")
+(load "stream-external-format.lsp")
+(load "with-open-file.lsp")
+(load "with-open-stream.lsp")
+(load "listen.lsp")
+(load "clear-input.lsp")
+(load "finish-output.lsp")
+(load "force-output.lsp")
+(load "clear-output.lsp")
+(load "make-synonym-stream.lsp")
+(load "synonym-stream-symbol.lsp")
+(load "make-broadcast-stream.lsp")
+(load "broadcast-stream-streams.lsp")
+(load "make-two-way-stream.lsp")
+(load "two-way-stream-input-stream.lsp")
+(load "two-way-stream-output-stream.lsp")
+(load "echo-stream-input-stream.lsp")
+(load "echo-stream-output-stream.lsp")
+(load "make-echo-stream.lsp")
+(load "concatenated-stream-streams.lsp")
+(load "make-concatenated-stream.lsp")
+(load "get-output-stream-string.lsp")
+(load "make-string-input-stream.lsp")
+(load "make-string-output-stream.lsp")
+(load "with-input-from-string.lsp")
+(load "with-output-to-string.lsp")
+(load "stream-error-stream.lsp")
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/load-system-construction.lsp
@@ -0,0 +1,12 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Dec 12 19:44:29 2004
+;;;; Contains: Load tests for system construction (section 24)
+
+(in-package :cl-test)
+
+(load "compile-file.lsp")
+(load "load.lsp")
+(load "with-compilation-unit.lsp")
+(load "features.lsp")
+(load "modules.lsp")
--- /dev/null
+++ gcl-2.6.12/ansi-tests/load-test-file-2.lsp
@@ -0,0 +1,7 @@
+(in-package :cl-test)
+
+(declaim (special *load-test-var.1* *load-test-var.2*))
+(eval-when (:load-toplevel)
+  (setq *load-test-var.1* *load-pathname*)
+  (setq *load-test-var.2* *load-truename*))
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/load-test-file.lsp
@@ -0,0 +1,9 @@
+(in-package :cl-test)
+
+(defun load-file-test-fun.1 ()
+  '#.*load-pathname*)
+
+(defun load-file-test-fun.2 ()
+  '#.*load-truename*)
+
+
--- gcl-2.6.12.orig/ansi-tests/load.lsp
+++ gcl-2.6.12/ansi-tests/load.lsp
@@ -1,15 +1,227 @@
-;; Get the MK package
-;; I've hardwired a path here; fix for your system
-;; I assume the package is already compiled.
-(unless (find-package "MK")
-  (load #.(concatenate 'string "../defsys30/defsystem."
-		     #+cmu (C::BACKEND-FASL-FILE-TYPE C::*TARGET-BACKEND*)
-		     #+allegro "fasl"
-		     #+(or akcl gcl) "o")))
-
-(load "rt/rt.system")
-(mk::load-system "rt")
-(mk::compile-system "cltest")
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Apr 12 21:51:49 2005
+;;;; Contains: Tests of LOAD
+
 (in-package :cl-test)
 
+(defun load-file-test (file funname &rest args &key
+			    if-does-not-exist
+			    (print nil print-p)
+			    (verbose nil verbose-p)
+			    (*load-print* nil)
+			    (*load-verbose* nil)
+			    external-format)
+  (declare (ignorable external-format if-does-not-exist
+		      print print-p verbose verbose-p))
+  (fmakunbound funname)
+  (let* ((str (make-array '(0) :element-type 'character :adjustable t
+			  :fill-pointer 0))
+	 (vals (multiple-value-list
+		(with-output-to-string
+		  (*standard-output* str)
+		  (apply #'load file :allow-other-keys t args))))
+	 (print? (if print-p print *load-print*))
+	 (verbose? (if verbose-p verbose *load-verbose*)))
+      (values
+       (let ((v1 (car vals))
+	     (v2 (or (and verbose-p (not verbose))
+		     (and (not verbose-p) (not *load-verbose*))
+		     (position #\; str)))
+	     (v3 (or (and print-p (not print))
+		     (and (not print-p) (not *load-print*))
+		     (> (length str) 0)))
+	     (v4 (if (or print? verbose?)
+		     (> (length str) 0)
+		   t)))
+	 (if (and (= (length vals) 1) v1 v2 v3 v4) t (list vals v2 v3 v4 str)))
+       (funcall funname))))
+
+(deftest load.1
+  (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1)
+  t nil)
+
+(deftest load.2
+  (load-file-test #p"compile-file-test-file.lsp" 'compile-file-test-fun.1)
+  t nil)
+
+(deftest load.3
+  (with-input-from-string
+   (s "(in-package :cl-test) (defun load-file-test-fun.2 () 'good)")
+   (load-file-test s 'load-file-test-fun.2))
+  t good)
+
+(deftest load.4
+  (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
+		  :external-format :default)
+  t nil)
+
+(deftest load.5
+  (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
+		  :verbose t)
+  t nil)
+
+(deftest load.6
+  (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
+		  :*load-verbose* t)
+  t nil)
+
+(deftest load.7
+  (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
+		  :*load-verbose* t :verbose nil)
+  t nil)
+
+(deftest load.8
+  (with-input-from-string
+   (s "(in-package :cl-test) (defun load-file-test-fun.2 () 'good)")
+   (load-file-test s 'load-file-test-fun.2 :verbose t))
+  t good)
+
+(deftest load.9
+  (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
+		  :print t)
+  t nil)
+
+(deftest load.10
+  (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
+		  :*load-print* t)
+  t nil)
+
+(deftest load.11
+  (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
+		  :*load-print* t :print nil)
+  t nil)
+
+(deftest load.12
+  (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
+		  :*load-print* nil :print t)
+  t nil)
+
+(deftest load.13
+  (with-input-from-string
+   (s "(in-package :cl-test) (defun load-file-test-fun.2 () 'good)")
+   (load-file-test s 'load-file-test-fun.2 :print t))
+  t good)
+
+(deftest load.14
+  (load "nonexistent-file.lsp" :if-does-not-exist nil)
+  nil)
+
+(defpackage LOAD-TEST-PACKAGE (:use "COMMON-LISP"))
+
+(deftest load.15
+  (let ((*package* (find-package "LOAD-TEST-PACKAGE")))
+    (with-input-from-string
+     (s "(defun f () 'good)")
+     (load-file-test s 'load-test-package::f)))
+  t load-test-package::good)
+
+(deftest load.15a
+  (let ((*package* (find-package "CL-TEST")))
+    (values
+     (with-input-from-string
+      (s "(eval-when (:load-toplevel :execute) (setq *package* (find-package \"LOAD-TEST-PACKAGE\")))
+          (defun f () 'good)")
+      (multiple-value-list (load-file-test s 'load-test-package::f)))
+     (read-from-string "GOOD")))
+  (t load-test-package::good) good)
+
+(deftest load.16
+  (let ((*readtable* (copy-readtable nil)))
+    (set-macro-character #\! (get-macro-character #\'))
+    (with-input-from-string
+     (s "(in-package :cl-test) (defun load-file-test-fun.3 () !good)")
+     (load-file-test s 'load-file-test-fun.3)))
+  t good)
+
+(deftest load.16a
+  (let ((*readtable* *readtable*)
+	(*package* (find-package "CL-TEST")))
+    (values
+     (with-input-from-string
+      (s "(in-package :cl-test)
+         (eval-when (:load-toplevel :execute)
+            (setq *readtable* (copy-readtable nil))
+            (set-macro-character #\\! (get-macro-character #\\')))
+         (defun load-file-test-fun.3 () !good)")
+      (multiple-value-list
+       (load-file-test s 'load-file-test-fun.3)))
+     (read-from-string "!FOO")))
+  (t good) !FOO)
+
+(deftest load.17
+  (let ((file #p"load-test-file.lsp"))
+    (fmakunbound 'load-file-test-fun.1)
+    (fmakunbound 'load-file-test-fun.2)
+    (values
+     (notnot (load file))
+     (let ((p1 (pathname (merge-pathnames file)))
+	   (p2 (funcall 'load-file-test-fun.1)))
+       (equalpt-or-report p1 p2))
+     (let ((p1 (truename file))
+	   (p2 (funcall 'load-file-test-fun.2)))
+       (equalpt-or-report p1 p2))))
+  t t t)
+
+;;; Test that the load pathname/truename variables are bound
+;;; properly when loading compiled files
+
+(deftest load.18
+  (let* ((file "load-test-file-2.lsp")
+	 (target (enough-namestring (compile-file-pathname file))))
+    (declare (special *load-test-var.1* *load-test-var.2*))
+    (compile-file file)
+    (makunbound '*load-test-var.1*)
+    (makunbound '*load-test-var.2*)
+    (load target)
+    (values
+     (let ((p1 (pathname (merge-pathnames target)))
+	   (p2 *load-test-var.1*))
+       (equalpt-or-report p1 p2))
+     (let ((p1 (truename target))
+	   (p2 *load-test-var.2*))
+       (equalpt-or-report p1 p2))))
+  t t)
+
+(deftest load.19
+  (let ((file (logical-pathname "CLTEST:LDTEST.LSP"))
+	(fn 'load-test-fun-3)
+	(*package* (find-package "CL-TEST")))
+    (with-open-file
+     (s file :direction :output :if-exists :supersede
+	:if-does-not-exist :create)
+     (format s "(in-package :cl-test) (defun ~a () :foo)" fn))
+    (fmakunbound fn)
+    (values
+     (notnot (load file))
+     (funcall fn)))
+  t :foo)
+
+;;; Defaults of the load variables
+
+(deftest load-pathname.1
+  *load-pathname*
+  nil)
+
+(deftest load-truename.1
+  *load-truename*
+  nil)
+
+(deftest load-print.1
+  *load-print*
+  nil)
+
+;;; Error tests
+
+(deftest load.error.1
+  (signals-error (load "nonexistent-file.lsp") file-error)
+  t)
+
+(deftest load.error.2
+  (signals-error (load) program-error)
+  t)
 
+(deftest load.error.3
+  (signals-error (load "compile-file-test-file.lsp" :bad-key-arg t)
+		 program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/logical-pathname-translations.lsp
@@ -0,0 +1,8 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Wed Dec 31 09:46:08 2003
+;;;; Contains: Tests of LOGICAL-PATHNAME-TRANSLATIONS
+
+(in-package :cl-test)
+
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/logical-pathname.lsp
@@ -0,0 +1,93 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Dec 30 19:05:01 2003
+;;;; Contains: Tests of LOGICAL-PATHNAME
+
+(in-package :cl-test)
+
+(deftest logical-pathname.1
+  (loop for x in *logical-pathnames*
+	always (eql x (logical-pathname x)))
+  t)
+
+(deftest logical-pathname.2
+  (notnot-mv (typep (logical-pathname "CLTEST:FOO") 'logical-pathname))
+  t)
+
+(deftest logical-pathname.3
+  (let ((name "CLTEST:TEMP.DAT.NEWEST"))
+    (with-open-file
+     (s (logical-pathname name)
+	:direction :output
+	:if-exists :supersede
+	:if-does-not-exist :create)
+     (or (equalt (logical-pathname s) (logical-pathname name))
+	 (list (logical-pathname s) (logical-pathname name)))))
+  t)
+
+
+;;; Error tests
+
+(deftest logical-pathname.error.1
+  (check-type-error #'logical-pathname
+		    (typef '(or string stream logical-pathname)))
+  nil)
+
+(deftest logical-pathname.error.2
+  ;; Doesn't specify a host
+  (signals-error (logical-pathname "FOO.TXT") type-error)
+  t)
+
+(deftest logical-pathname.error.3
+  (signals-error
+   (with-open-file (s #p"logical-pathname.lsp" :direction :input)
+		   (logical-pathname s))
+   type-error)
+  t)
+
+(deftest logical-pathname.error.4
+  (signals-error
+   (with-open-stream
+    (is (make-concatenated-stream))
+    (with-open-stream
+     (os (make-broadcast-stream))
+     (with-open-stream
+      (s (make-two-way-stream is os))
+      (logical-pathname s))))
+   type-error)
+  t)
+
+(deftest logical-pathname.error.5
+  (signals-error
+   (with-open-stream
+    (is (make-concatenated-stream))
+    (with-open-stream
+     (os (make-broadcast-stream))
+     (with-open-stream
+      (s (make-echo-stream is os))
+      (logical-pathname s))))
+   type-error)
+  t)
+
+(deftest logical-pathname.error.6
+  (signals-error (with-open-stream (s (make-broadcast-stream)) (logical-pathname s)) type-error)
+  t)
+
+(deftest logical-pathname.error.7
+  (signals-error (with-open-stream (s (make-concatenated-stream)) (logical-pathname s)) type-error)
+  t)
+
+(deftest logical-pathname.error.8
+  (signals-error (with-open-stream (s (make-string-input-stream "foo"))
+				   (logical-pathname s)) type-error)
+  t)
+
+(deftest logical-pathname.error.9
+  (signals-error (with-output-to-string (s) (logical-pathname s)) type-error)
+  t)
+
+(deftest logical-pathname.error.10
+  (handler-case
+   (progn (eval '(locally (declare (optimize safety)) (logical-pathname "CLROOT:%"))) t)
+   (type-error () t))
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/make-broadcast-stream.lsp
@@ -0,0 +1,99 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Thu Jan 29 21:28:25 2004
+;;;; Contains: Tests of MAKE-BROADCAST-STREAM
+
+(in-package :cl-test)
+
+(deftest make-broadcast-stream.1
+  (let ((s (make-broadcast-stream)))
+    (assert (typep s 'stream))
+    (assert (typep s 'broadcast-stream))
+    (assert (output-stream-p s))
+    ;; (assert (not (input-stream-p s)))
+    (assert (open-stream-p s))
+    (assert (streamp s))
+    ;; (assert (eq (stream-element-type s) t))
+    (values
+     (notnot (typep s 'stream))
+     (notnot (typep s 'broadcast-stream))
+     (notnot (output-stream-p s))
+     (progn (write-char #\x s) nil)
+     ))
+  t t t nil)
+
+(deftest make-broadcast-stream.2
+  (with-output-to-string
+    (s1)
+    (let ((s (make-broadcast-stream s1)))
+      (assert (typep s 'stream))
+      (assert (typep s 'broadcast-stream))
+      (assert (output-stream-p s))
+      ;; (assert (not (input-stream-p s)))
+      (assert (open-stream-p s))
+      (assert (streamp s))
+      (assert (eql (stream-element-type s)
+		   (stream-element-type s1)))
+      (write-char #\x s)))
+  "x")
+
+(deftest make-broadcast-stream.3
+  (let ((s1 (make-string-output-stream))
+	(s2 (make-string-output-stream)))
+    (let ((s (make-broadcast-stream s1 s2)))
+      (assert (typep s 'stream))
+      (assert (typep s 'broadcast-stream))
+      (assert (output-stream-p s))
+      ;; (assert (not (input-stream-p s)))
+      (assert (open-stream-p s))
+      (assert (streamp s))
+      (assert (eql (stream-element-type s)
+		   (stream-element-type s2)))
+      (format s "This is a test"))
+    (values
+     (get-output-stream-string s1)
+     (get-output-stream-string s2)))
+  "This is a test"
+  "This is a test")
+
+(deftest make-broadcast-stream.4
+  (fresh-line (make-broadcast-stream))
+  nil)
+
+(deftest make-broadcast-stream.5
+  (file-length (make-broadcast-stream))
+  0)
+
+(deftest make-broadcast-stream.6
+  (file-position (make-broadcast-stream))
+  0)
+
+(deftest make-broadcast-stream.7
+  (file-string-length (make-broadcast-stream) "antidisestablishmentarianism")
+  1)
+
+(deftest make-broadcast-stream.8
+  (stream-external-format (make-broadcast-stream))
+  :default)
+
+
+
+;;; FIXME
+;;; Add tests for: close,
+;;;  peek-char, read-char-no-hang, terpri, fresh-line, unread-char,
+;;;  read-line, write-line, write-string, read-sequence, write-sequence,
+;;;  read-byte, write-byte, listen, clear-input, finish-output, force-output,
+;;;  clear-output, print, prin1 princ
+
+;;; Error tests
+
+(deftest make-broadcast-stream.error.1
+  (check-type-error #'make-broadcast-stream
+		    #'(lambda (x) (and (streamp x) (output-stream-p x))))
+  nil)
+
+(deftest make-broadcast-stream.error.2
+  (check-type-error #'make-broadcast-stream
+		    #'(lambda (x) (and (streamp x) (output-stream-p x)))
+		    *streams*)
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/make-concatenated-stream.lsp
@@ -0,0 +1,323 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Feb 14 08:41:18 2004
+;;;; Contains: Tests of MAKE-CONCATENATED-STREAM
+
+(in-package :cl-test)
+
+(deftest make-concatenated-stream.1
+  (let ((s (make-concatenated-stream)))
+    (read s nil :eof))
+  :eof)
+
+(deftest make-concatenated-stream.2
+  (let ((s (make-concatenated-stream)))
+    (notnot-mv (input-stream-p s)))
+  t)
+
+(deftest make-concatenated-stream.3
+  (let ((s (make-concatenated-stream)))
+    (output-stream-p s))
+  nil)
+
+(deftest make-concatenated-stream.4
+  (let ((s (make-concatenated-stream)))
+    (notnot-mv (streamp s)))
+  t)
+
+(deftest make-concatenated-stream.5
+  (let ((s (make-concatenated-stream)))
+    (notnot-mv (typep s 'stream)))
+  t)
+
+(deftest make-concatenated-stream.6
+  (let ((s (make-concatenated-stream)))
+    (notnot-mv (typep s 'concatenated-stream)))
+  t)
+
+(deftest make-concatenated-stream.7
+  (let ((s (make-concatenated-stream)))
+    (notnot-mv (open-stream-p s)))
+  t)
+
+(deftest make-concatenated-stream.8
+  (let ((s (make-concatenated-stream *standard-input*)))
+    (notnot-mv (stream-element-type s)))
+  t)
+
+(deftest make-concatenated-stream.9
+  (let ((pn #p"tmp.dat")
+	(element-type '(unsigned-byte 8)))
+    (with-open-file (s pn :direction :output :element-type element-type
+		       :if-exists :supersede)
+		    (dolist (b '(1 5 9 13)) (write-byte b s)))
+    (with-open-file
+     (s1 pn :direction :input :element-type element-type)
+     (with-open-file
+      (s2 pn :direction :input :element-type element-type)
+      (let ((s (make-concatenated-stream s1 s2)))
+	(loop repeat 8 collect (read-byte s))))))
+  (1 5 9 13 1 5 9 13))
+
+(deftest make-concatenated-stream.10
+  (let ((s (make-concatenated-stream)))
+    (read-byte s nil :eof))
+  :eof)
+
+(deftest make-concatenated-stream.11
+  (let ((s (make-concatenated-stream)))
+    (peek-char nil s nil :eof))
+  :eof)
+
+(deftest make-concatenated-stream.12
+  (with-input-from-string
+   (s1 "a")
+   (with-input-from-string
+    (s2 "b")
+    (let ((s (make-concatenated-stream s1 s2)))
+      (values
+       (peek-char nil s)
+       (read-char s)
+       (peek-char nil s)
+       (read-char s)
+       (peek-char nil s nil :eof)))))
+  #\a #\a #\b #\b :eof)
+
+(deftest make-concatenated-stream.13
+  (with-input-from-string
+   (s1 "  a  ")
+   (with-input-from-string
+    (s2 "  b  ")
+    (let ((s (make-concatenated-stream s1 s2)))
+      (values
+       (peek-char t s)
+       (read-char s)
+       (peek-char t s)
+       (read-char s)
+       (peek-char t s nil :eof)))))
+  #\a #\a #\b #\b :eof)
+
+(deftest make-concatenated-stream.14
+  (with-input-from-string
+   (s1 "a")
+   (with-input-from-string
+    (s2 "b")
+    (let ((s (make-concatenated-stream s1 s2)))
+      (values
+       (read-char s)
+       (unread-char #\a s)
+       (read-char s)
+       (read-char s)
+       (unread-char #\b s)
+       (read-char s)
+       (read-char s nil :eof)))))
+  #\a nil #\a #\b nil #\b :eof)
+
+(deftest make-concatenated-stream.15
+  (let ((s (make-concatenated-stream)))
+    (read-char-no-hang s nil :eof))
+  :eof)
+
+(deftest make-concatenated-stream.16
+  (with-input-from-string
+   (s1 "a")
+   (with-input-from-string
+    (s2 "b")
+    (let ((s (make-concatenated-stream s1 s2)))
+      (values
+       (read-char-no-hang s)
+       (read-char-no-hang s)
+       (read-char-no-hang s nil :eof)))))
+  #\a #\b :eof)
+
+(deftest make-concatenated-stream.17
+  (with-input-from-string
+   (s1 "a")
+   (with-input-from-string
+    (s2 "b")
+    (let ((s (make-concatenated-stream s1 s2)))
+      (multiple-value-bind (str mnp)
+	  (read-line s)
+	(values str (notnot mnp))))))
+  "ab" t)
+
+(deftest make-concatenated-stream.18
+  (with-input-from-string
+   (s1 "ab")
+   (with-input-from-string
+    (s2 "")
+    (let ((s (make-concatenated-stream s1 s2)))
+      (multiple-value-bind (str mnp)
+	  (read-line s)
+	(values str (notnot mnp))))))
+  "ab" t)
+
+(deftest make-concatenated-stream.19
+  (with-input-from-string
+   (s1 "")
+   (with-input-from-string
+    (s2 "ab")
+    (let ((s (make-concatenated-stream s1 s2)))
+      (multiple-value-bind (str mnp)
+	  (read-line s)
+	(values str (notnot mnp))))))
+  "ab" t)
+
+(deftest make-concatenated-stream.20
+  (with-input-from-string
+   (s1 "ab")
+   (with-input-from-string
+    (s2 (concatenate 'string (string #\Newline) "def"))
+    (let ((s (make-concatenated-stream s1 s2)))
+      (read-line s))))
+  "ab" nil)
+
+(deftest make-concatenated-stream.21
+  (with-input-from-string
+   (s1 "")
+   (with-input-from-string
+    (s2 "")
+    (let ((s (make-concatenated-stream s1 s2)))
+      (multiple-value-bind (str mnp)
+	  (read-line s nil :eof)
+	(values str (notnot mnp))))))
+  :eof t)
+
+(deftest make-concatenated-stream.22
+  (let ((pn #p"tmp.dat")
+	(element-type '(unsigned-byte 8)))
+    (with-open-file (s pn :direction :output :element-type element-type
+		       :if-exists :supersede)
+		    (dolist (b '(1 5 9 13)) (write-byte b s)))
+    (with-open-file
+     (s1 pn :direction :input :element-type element-type)
+     (with-open-file
+      (s2 pn :direction :input :element-type element-type)
+      (let ((s (make-concatenated-stream s1 s2))
+	    (x (vector nil nil nil nil nil nil nil nil)))
+	(values
+	 (read-sequence x s)
+	 x)))))
+  8
+  #(1 5 9 13 1 5 9 13))
+
+(deftest make-concatenated-stream.23
+  (let ((pn #p"tmp.dat")
+	(element-type '(unsigned-byte 8)))
+    (with-open-file (s pn :direction :output :element-type element-type
+		       :if-exists :supersede)
+		    (dolist (b '(1 5 9 13)) (write-byte b s)))
+    (with-open-file
+     (s1 pn :direction :input :element-type element-type)
+     (with-open-file
+      (s2 pn :direction :input :element-type element-type)
+      (let ((s (make-concatenated-stream s1 s2))
+	    (x (vector nil nil nil nil nil nil)))
+	(values
+	 (read-sequence x s)
+	 x)))))
+  6
+  #(1 5 9 13 1 5))
+
+(deftest make-concatenated-stream.24
+  (let ((pn #p"tmp.dat")
+	(element-type '(unsigned-byte 8)))
+    (with-open-file (s pn :direction :output :element-type element-type
+		       :if-exists :supersede)
+		    (dolist (b '(1 5 9 13)) (write-byte b s)))
+    (with-open-file
+     (s1 pn :direction :input :element-type element-type)
+     (with-open-file
+      (s2 pn :direction :input :element-type element-type)
+      (let ((s (make-concatenated-stream s1 s2))
+	    (x (vector nil nil nil nil nil nil nil nil nil nil)))
+	(values
+	 (read-sequence x s)
+	 x)))))
+  8
+  #(1 5 9 13 1 5 9 13 nil nil))
+
+(deftest make-concatenated-stream.25
+  (close (make-concatenated-stream))
+  t)
+
+(deftest make-concatenated-stream.26
+  (let ((s (make-concatenated-stream)))
+    (values (prog1 (close s) (close s))
+	    (open-stream-p s)))
+  t nil)
+
+(deftest make-concatenated-stream.27
+  (with-input-from-string
+   (s1 "abc")
+   (let ((s (make-concatenated-stream s1)))
+     (values
+      (notnot (open-stream-p s1))
+      (notnot (open-stream-p s))
+      (close s)
+      (notnot (open-stream-p s1))
+      (open-stream-p s))))
+  t t t t nil)
+
+(deftest make-concatenated-stream.28
+  (with-input-from-string
+   (s1 "a")
+   (let ((s (make-concatenated-stream s1)))
+     (notnot-mv (listen s))))
+  t)
+
+(deftest make-concatenated-stream.28a
+  (listen (make-concatenated-stream))
+  nil)
+
+(deftest make-concatenated-stream.29
+  (with-input-from-string
+   (s1 "")
+   (let ((s (make-concatenated-stream s1)))
+     (listen s)))
+  nil)
+
+(deftest make-concatenated-stream.30
+  (with-input-from-string
+   (s1 "")
+   (with-input-from-string
+    (s2 "a")
+    (let ((s (make-concatenated-stream s1 s2)))
+      (notnot-mv (listen s)))))
+  t)
+
+(deftest make-concatenated-stream.31
+  (with-input-from-string
+   (s1 "")
+   (with-input-from-string
+    (s2 "")
+    (let ((s (make-concatenated-stream s1 s2)))
+      (listen s))))
+  nil)
+
+(deftest make-concatenated-stream.32
+  (clear-input (make-concatenated-stream))
+  nil)
+
+(deftest make-concatenated-stream.33
+  (with-input-from-string
+   (s1 "abc")
+   (clear-input (make-concatenated-stream s1)))
+  nil)
+
+;;; Error cases
+
+(deftest make-concatenated-stream.error.1
+  (loop for x in *mini-universe*
+	unless (or (and (streamp x) (input-stream-p x))
+		   (eval `(signals-error (make-concatenated-stream ',x) t)))
+	collect x)
+  nil)
+
+(deftest make-concatenated-stream.error.2
+  (loop for x in *streams*
+	unless (or (and (streamp x) (input-stream-p x))
+		   (eval `(signals-error (make-concatenated-stream ',x) t)))
+	collect x)
+  nil)
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/make-echo-stream.lsp
@@ -0,0 +1,332 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Thu Feb 12 04:34:42 2004
+;;;; Contains: Tests of MAKE-ECHO-STREAM
+
+(in-package :cl-test)
+
+(deftest make-echo-stream.1
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (values
+     (read-char s)
+     (get-output-stream-string os)))
+  #\f "f")
+
+(deftest make-echo-stream.2
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (get-output-stream-string os))
+  "")
+
+(deftest make-echo-stream.3
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (values (read-line s nil)
+	    (get-output-stream-string os)))
+  "foo" "foo")
+
+;;; Tests of READ-BYTE on echo streams
+
+(deftest make-echo-stream.4
+  (let ((pn #p"tmp.dat")
+	(pn2 #p"tmp2.dat")
+	(element-type '(unsigned-byte 8)))
+    (with-open-file (os pn
+			:direction :output
+			:element-type element-type
+			:if-exists :supersede)
+		    (loop for x in '(2 3 5 7 11)
+			  do (write-byte x os)))
+    (with-open-file
+     (is pn :direction :input :element-type element-type)
+     (values
+      (with-open-file
+       (os pn2 :direction :output :if-exists :supersede
+	   :element-type element-type)
+       (let ((s (make-echo-stream is os)))
+	 (loop repeat 6 collect (read-byte s nil :eof1))))
+      (with-open-file
+       (s pn2 :direction :input :element-type element-type)
+       (loop repeat 6 collect (read-byte s nil :eof2))))))
+  (2 3 5 7 11 :eof1)
+  (2 3 5 7 11 :eof2))
+
+(deftest make-echo-stream.5
+  (let ((pn #p"tmp.dat")
+	(pn2 #p"tmp2.dat")
+	(element-type '(unsigned-byte 8)))
+    (with-open-file (os pn
+			:direction :output
+			:element-type element-type
+			:if-exists :supersede)
+		    (loop for x in '(2 3 5 7 11)
+			  do (write-byte x os)))
+    (with-open-file
+     (is pn :direction :input :element-type element-type)
+     (values
+      (with-open-file
+       (os pn2 :direction :output :if-exists :supersede
+	   :element-type element-type)
+       (let ((s (make-echo-stream is os)))
+	 (loop repeat 6 collect (read-byte s nil 100))))
+      (with-open-file
+       (s pn2 :direction :input :element-type element-type)
+       (loop repeat 6 collect (read-byte s nil 200))))))
+  (2 3 5 7 11 100)
+  (2 3 5 7 11 200))
+
+(deftest make-echo-stream.6
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (values (coerce (loop repeat 3 collect (read-char-no-hang s)) 'string)
+	    (get-output-stream-string os)))
+  "foo" "foo")
+
+(deftest make-echo-stream.7
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (values (coerce (loop repeat 4 collect (read-char-no-hang s nil '#\z))
+		    'string)
+	    (get-output-stream-string os)))
+  "fooz" "foo")
+
+;;; peek-char + echo streams is tested in peek-char.lsp
+;;; unread-char + echo streams is tested in unread-char.lsp
+
+(deftest make-echo-stream.8
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os))
+	 (x (copy-seq "xxxxxx")))
+    (values
+     (read-sequence x s)
+     x
+     (get-output-stream-string os)))
+  3
+  "fooxxx"
+  "foo")
+
+(deftest make-echo-stream.9
+  (let ((pn #p"tmp.dat")
+	(pn2 #p"tmp2.dat")
+	(element-type '(unsigned-byte 8)))
+    (with-open-file (os pn
+			:direction :output
+			:element-type element-type
+			:if-exists :supersede)
+		    (loop for x in '(2 3 5 7 11)
+			  do (write-byte x os)))
+    (with-open-file
+     (is pn :direction :input :element-type element-type)
+     (values
+      (with-open-file
+       (os pn2 :direction :output :if-exists :supersede
+	   :element-type element-type)
+       (let ((s (make-echo-stream is os))
+	     (x (vector 0 0 0 0 0 0 0 0)))
+	 (list (read-sequence x s)
+	       x)))
+      (with-open-file
+       (s pn2 :direction :input :element-type element-type)
+       (loop repeat 8 collect (read-byte s nil nil))))))
+  (5 #(2 3 5 7 11 0 0 0))
+  (2 3 5 7 11 nil nil nil))
+
+(deftest make-echo-stream.10
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (values
+     (notnot (open-stream-p s))
+     (close s)
+     (open-stream-p s)
+     (notnot (open-stream-p is))
+     (notnot (open-stream-p os))))
+  t t nil t t)
+
+(deftest make-echo-stream.11
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (values
+     (notnot (listen s))
+     (read-char s)
+     (notnot (listen s))
+     (read-char s)
+     (notnot (listen s))
+     (read-char s)
+     (listen s)))
+  t #\f t #\o t #\o nil)
+
+(deftest make-echo-stream.12
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (values
+     (notnot (streamp s))
+     (notnot (typep s 'stream))
+     (notnot (typep s 'echo-stream))
+     (notnot (input-stream-p s))
+     (notnot (output-stream-p s))
+     (notnot (stream-element-type s))))
+  t t t t t t)
+
+;;; FIXME
+;;; Add tests for clear-input, file-position(?)
+;;;  Also, add tests for output operations (since echo-streams are
+;;;   bidirectional)
+
+(deftest make-echo-stream.13
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (values
+     (write-char #\0 s)
+     (close s)
+     (get-output-stream-string os)))
+  #\0 t "0")
+
+(deftest make-echo-stream.14
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (values
+     (terpri s)
+     (close s)
+     (get-output-stream-string os)))
+  nil t #.(string #\Newline))
+
+(deftest make-echo-stream.15
+  (let ((pn #p"tmp.dat")
+	(pn2 #p"tmp2.dat")
+	(element-type '(unsigned-byte 8)))
+    (with-open-file (os pn
+			:direction :output
+			:element-type element-type
+			:if-exists :supersede))
+    (with-open-file
+     (is pn :direction :input :element-type element-type)
+     (values
+      (with-open-file
+       (os pn2 :direction :output :if-exists :supersede
+	   :element-type element-type)
+       (let ((s (make-echo-stream is os))
+	     (x (mapcar #'char-code (coerce "abcdefg" 'list))))
+	 (loop for b in x do
+	       (assert (equal (list b)
+			      (multiple-value-list (write-byte b s)))))
+	 (close s)))))
+    (with-open-file
+     (is pn2 :direction :input :element-type element-type)
+     (let ((x (vector 0 0 0 0 0 0 0)))
+       (read-sequence x is)
+       (values
+	(read-byte is nil :done)
+	(map 'string #'code-char x)))))
+  :done
+  "abcdefg")
+
+(deftest make-echo-stream.16
+  (let ((pn #p"tmp.dat")
+	(pn2 #p"tmp2.dat")
+	(element-type '(unsigned-byte 8)))
+    (with-open-file (os pn
+			:direction :output
+			:element-type element-type
+			:if-exists :supersede))
+    (with-open-file
+     (is pn :direction :input :element-type element-type)
+     (values
+      (with-open-file
+       (os pn2 :direction :output :if-exists :supersede
+	   :element-type element-type)
+       (let ((s (make-echo-stream is os))
+	     (x (map 'vector #'char-code "abcdefg")))
+	 (assert (equal (multiple-value-list (write-sequence x s)) (list x)))
+	 (close s)))))
+    (with-open-file
+     (is pn2 :direction :input :element-type element-type)
+     (let ((x (vector 0 0 0 0 0 0 0)))
+       (read-sequence x is)
+       (values
+	(read-byte is nil :done)
+	(map 'string #'code-char x)))))
+  :done
+  "abcdefg")
+
+(deftest make-echo-stream.17
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (values
+     (write-char #\X s)
+     (notnot (fresh-line s))
+     (finish-output s)
+     (force-output s)
+     (close s)
+     (get-output-stream-string os)))
+ #\X t nil nil t #.(coerce '(#\X #\Newline) 'string))
+
+(deftest make-echo-stream.18
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (values
+     (write-string "159" s)
+     (close s)
+     (get-output-stream-string os)))
+  "159" t "159")
+
+(deftest make-echo-stream.20
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (values
+     (write-string "0159X" s :start 1 :end 4)
+     (close s)
+     (get-output-stream-string os)))
+  "0159X" t "159")
+
+(deftest make-echo-stream.21
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (values
+     (write-line "159" s)
+     (close s)
+     (get-output-stream-string os)))
+  "159" t #.(concatenate 'string "159" (string #\Newline)))
+
+(deftest make-echo-stream.22
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-echo-stream is os)))
+    (values
+     (write-char #\0 s)
+     (clear-output s)))
+  #\0 nil)
+
+;;; Error tests
+
+(deftest make-echo-stream.error.1
+  (signals-error (make-echo-stream) program-error)
+  t)
+
+(deftest make-echo-stream.error.2
+  (signals-error (make-echo-stream *standard-input*) program-error)
+  t)
+
+(deftest make-echo-stream.error.3
+  (signals-error (make-echo-stream *standard-input* *standard-output* nil)
+		 program-error)
+  t)
+
+
+
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/make-pathname.lsp
@@ -0,0 +1,171 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Nov 29 05:54:30 2003
+;;;; Contains: Tests of MAKE-PATHNAME
+
+(in-package :cl-test)
+
+(defvar *null-pathname*
+    (make-pathname))
+
+(defun make-pathname-test
+  (&rest args &key (defaults nil)
+	 (host (if defaults (pathname-host defaults)
+		 (pathname-host *default-pathname-defaults*)))
+	 (device (if defaults (pathname-device defaults)
+		   (pathname-device *null-pathname*)))
+	 (directory (if defaults (pathname-directory defaults)
+		      (pathname-directory *null-pathname*)))
+	 (name (if defaults (pathname-name defaults)
+		 (pathname-name  *null-pathname*)))
+	 (type (if defaults (pathname-type defaults)
+		 (pathname-type *null-pathname*)))
+	 (version (if defaults (pathname-version defaults)
+		    (pathname-version *null-pathname*)))
+	 case)
+  (declare (ignorable case))
+  (let* ((vals (multiple-value-list (apply #'make-pathname args)))
+	 (pn (first vals)))
+    (and (= (length vals) 1)
+	 (typep pn 'pathname)
+	 (equalp (pathname-host pn) host)
+	 (equalp (pathname-device pn) device)
+	 ;; (equalp (pathname-directory pn) directory)
+	 (let ((pnd (pathname-directory pn)))
+	   (if (eq directory :wild)
+	       (member pnd '((:absolute :wild-inferiors)
+			     (:absolute :wild))
+		       :test #'equal)
+	     (equalp pnd directory)))	     
+	 (equalp (pathname-name pn) name)
+	 (equalp (pathname-type pn) type)
+	 (equalp (pathname-version pn) version)
+	 t)))
+  
+  
+
+(deftest make-pathname.1
+  (make-pathname-test)
+  t)
+
+(deftest make-pathname.2
+  (make-pathname-test :name "foo")
+  t)
+
+(deftest make-pathname.2a
+  (do-special-strings
+   (s "foo")
+   (assert (make-pathname-test :name s)))
+  nil)
+
+(deftest make-pathname.3
+  (make-pathname-test :name "foo" :type "txt")
+  t)
+
+(deftest make-pathname.3a
+  (do-special-strings
+   (s "txt")
+   (assert (make-pathname-test :name "foo" :type s)))
+  nil)
+
+(deftest make-pathname.4
+  (make-pathname-test :type "lsp")
+  t)
+
+(deftest make-pathname.5
+  (make-pathname-test :directory :wild)
+  t)
+
+(deftest make-pathname.6
+  (make-pathname-test :name :wild)
+  t)
+
+(deftest make-pathname.7
+  (make-pathname-test :type :wild)
+  t)
+
+(deftest make-pathname.8
+  (make-pathname-test :version :wild)
+  t)
+
+(deftest make-pathname.9
+  (make-pathname-test :defaults *default-pathname-defaults*)
+  t)
+
+(deftest make-pathname.10
+  (make-pathname-test :defaults (make-pathname :name "foo" :type "bar"))
+  t)
+
+(deftest make-pathname.11
+  (make-pathname-test :version :newest)
+  t)
+
+(deftest make-pathname.12
+  (make-pathname-test :case :local)
+  t)
+
+(deftest make-pathname.13
+  (make-pathname-test :case :common)
+  t)
+
+(deftest make-pathname.14
+  (let ((*default-pathname-defaults*
+	 (make-pathname :name "foo" :type "lsp" :version :newest)))
+    (make-pathname-test))
+  t)
+
+;;; Works on the components of actual pathnames
+(deftest make-pathname.rebuild
+  (loop for p in *pathnames*
+	for host = (pathname-host p)
+	for device = (pathname-device p)
+	for directory = (pathname-directory p)
+	for name = (pathname-name p)
+	for type = (pathname-type p)
+	for version = (pathname-version p)
+	for p2 = (make-pathname
+		  :host host
+		  :device device
+		  :directory directory
+		  :name name
+		  :type type
+		  :version version)
+	unless (equal p p2)
+	collect (list p p2))
+  nil)
+
+;;; Various constraints on :directory
+
+(deftest make-pathname-error-absolute-up
+  (signals-error (directory (make-pathname :directory '(:absolute :up)))
+		 file-error)
+  t)
+
+(deftest make-pathname-error-absolute-back
+  (signals-error (directory (make-pathname :directory '(:absolute :back)))
+		 file-error)
+  t)
+
+;; The next test is correct, but was causing very large amounts of time to be spent
+;; in buggy implementations
+;;#|
+(deftest make-pathname-error-absolute-wild-inferiors-up
+  (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :up)))
+		 file-error)
+  t)
+;;|#
+
+(deftest make-pathname-error-relative-wild-inferiors-up
+  (signals-error (length (directory (make-pathname :directory '(:relative :wild-inferiors :up))))
+		 file-error)
+  t)
+
+(deftest make-pathname-error-absolute-wild-inferiors-back
+  (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :back)))
+		 file-error)
+  t)
+
+(deftest make-pathname-error-relative-wild-inferiors-back
+  (signals-error (directory (make-pathname :directory '(:relative :wild-inferiors :back)))
+		 file-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/make-string-input-stream.lsp
@@ -0,0 +1,93 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Feb 14 18:36:48 2004
+;;;; Contains: Tests for MAKE-STRING-INPUT-STREAM
+
+(in-package :cl-test)
+
+(deftest make-string-input-stream.1
+  (let ((s (make-string-input-stream "")))
+    (values
+     (notnot (typep s 'stream))
+     (notnot (streamp s))
+     (notnot (input-stream-p s))
+     (output-stream-p s)))
+  t t t nil)
+
+(deftest make-string-input-stream.2
+  (let ((s (make-string-input-stream "abcd")))
+    (values
+     (notnot (typep s 'stream))
+     (notnot (streamp s))
+     (notnot (input-stream-p s))
+     (output-stream-p s)))
+  t t t nil)
+
+
+(deftest make-string-input-stream.3
+  (let ((s (make-string-input-stream "abcd" 1)))
+    (values (read-line s)))
+  "bcd")
+
+
+(deftest make-string-input-stream.4
+  (let ((s (make-string-input-stream "abcd" 0 2)))
+    (values (read-line s)))
+  "ab")
+
+(deftest make-string-input-stream.5
+  (let ((s (make-string-input-stream "abcd" 1 nil)))
+    (values (read-line s)))
+  "bcd")
+
+(deftest make-string-input-stream.6
+  (let ((str1 (make-array 6 :element-type 'character
+			  :initial-contents "abcdef"
+			  :fill-pointer 4)))
+    (let ((s (make-string-input-stream str1)))
+      (values (read-line s) (read-char s nil :eof))))
+  "abcd" :eof)
+
+(deftest make-string-input-stream.7
+  (let* ((str1 (make-array 6 :element-type 'character
+			   :initial-contents "abcdef"))
+	 (str2 (make-array 4 :element-type 'character
+			   :displaced-to str1)))
+    (let ((s (make-string-input-stream str2)))
+      (values (read-line s) (read-char s nil :eof))))
+  "abcd" :eof)
+
+(deftest make-string-input-stream.8
+  (let* ((str1 (make-array 6 :element-type 'character
+			   :initial-contents "abcdef"))
+	 (str2 (make-array 4 :element-type 'character
+			   :displaced-to str1
+			   :displaced-index-offset 1)))
+    (let ((s (make-string-input-stream str2)))
+      (values (read-line s) (read-char s nil :eof))))
+  "bcde" :eof)
+
+(deftest make-string-input-stream.9
+  (let ((str1 (make-array 6 :element-type 'character
+			  :initial-contents "abcdef"
+			  :adjustable t)))
+    (let ((s (make-string-input-stream str1)))
+      (values (read-line s) (read-char s nil :eof))))
+  "abcdef" :eof)
+
+(deftest make-string-input-stream.10
+  :notes (:allow-nil-arrays :nil-vectors-are-strings)
+  (let ((s (make-string-input-stream
+	    (make-array 0 :element-type nil))))
+    (read-char s nil :eof))
+  :eof)
+
+;;; Error tests
+
+(deftest make-string-input-stream.error.1
+  (signals-error (make-string-input-stream) program-error)
+  t)
+
+(deftest make-string-input-stream.error.2
+  (signals-error (make-string-input-stream "abc" 1 2 nil) program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/make-string-output-stream.lsp
@@ -0,0 +1,139 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Feb 14 19:42:07 2004
+;;;; Contains: Tests of MAKE-STRING-OUTPUT-STREAM
+
+(in-package :cl-test)
+
+(deftest make-string-output-stream.1
+  (let ((s (make-string-output-stream)))
+    (values
+     (notnot (typep s 'stream))
+     (notnot (typep s 'string-stream))
+     (input-stream-p s)
+     (notnot (output-stream-p s))
+     (notnot (open-stream-p s))))
+  t t nil t t)
+
+(deftest make-string-output-stream.2
+  (let ((s (make-string-output-stream :element-type 'character)))
+    (values
+     (notnot (typep s 'stream))
+     (notnot (typep s 'string-stream))
+     (input-stream-p s)
+     (notnot (output-stream-p s))
+     (notnot (open-stream-p s))))
+  t t nil t t)
+
+(deftest make-string-output-stream.3
+  (let ((s (make-string-output-stream :element-type 'base-char)))
+    (values
+     (notnot (typep s 'stream))
+     (notnot (typep s 'string-stream))
+     (input-stream-p s)
+     (notnot (output-stream-p s))
+     (notnot (open-stream-p s))))
+  t t nil t t)
+
+(deftest make-string-output-stream.4
+  :notes (:nil-vectors-are-strings)
+  (let ((s (make-string-output-stream :element-type nil)))
+    (values
+     (notnot (typep s 'stream))
+     (notnot (typep s 'string-stream))
+     (input-stream-p s)
+     (notnot (output-stream-p s))
+     (notnot (open-stream-p s))))
+  t t nil t t)
+
+(deftest make-string-output-stream.5
+  (let ((s (make-string-output-stream :allow-other-keys nil)))
+    (values
+     (notnot (typep s 'stream))
+     (notnot (typep s 'string-stream))
+     (input-stream-p s)
+     (notnot (output-stream-p s))
+     (notnot (open-stream-p s))))
+  t t nil t t)
+
+(deftest make-string-output-stream.6
+  (let ((s (make-string-output-stream :allow-other-keys t :foo 'bar)))
+    (values
+     (notnot (typep s 'stream))
+     (notnot (typep s 'string-stream))
+     (input-stream-p s)
+     (notnot (output-stream-p s))
+     (notnot (open-stream-p s))))
+  t t nil t t)
+
+(deftest make-string-output-stream.7
+  (let ((s (make-string-output-stream :foo 'bar :allow-other-keys t
+				      :allow-other-keys nil
+				      :foo2 'x)))
+    (values
+     (notnot (typep s 'stream))
+     (notnot (typep s 'string-stream))
+     (input-stream-p s)
+     (notnot (output-stream-p s))
+     (notnot (open-stream-p s))))
+  t t nil t t)
+
+(deftest make-string-output-stream.8
+  (let ((s (make-string-output-stream)))
+    (write-string "abc" s)
+    (write-string "def" s)
+    (get-output-stream-string s))
+  "abcdef")
+
+(deftest make-string-output-stream.9
+  (let ((s (make-string-output-stream :element-type 'character)))
+    (write-string "abc" s)
+    (write-string "def" s)
+    (get-output-stream-string s))
+  "abcdef")
+
+(deftest make-string-output-stream.10
+  (let ((s (make-string-output-stream :element-type 'base-char)))
+    (write-string "abc" s)
+    (write-string "def" s)
+    (get-output-stream-string s))
+  "abcdef")
+
+(deftest make-string-output-stream.11
+  :notes (:nil-vectors-are-strings)
+  (let ((s (make-string-output-stream :element-type nil)))
+    (get-output-stream-string s))
+  "")
+
+(deftest make-string-output-stream.12
+  :notes (:nil-vectors-are-strings)
+  (let ((s (make-string-output-stream :element-type nil)))
+    (typep #\a (array-element-type (get-output-stream-string s))))
+  nil)
+
+(deftest make-string-output-stream.13
+  (let ((s (make-string-output-stream)))
+    (values
+     (close s)
+     (open-stream-p s)))
+  t nil)
+
+;;; Error tests
+
+(deftest make-string-output-stream.error.1
+  (signals-error (make-string-output-stream nil) program-error)
+  t)
+
+(deftest make-string-output-stream.error.2
+  (signals-error (make-string-output-stream :foo nil) program-error)
+  t)
+
+(deftest make-string-output-stream.error.3
+  (signals-error (make-string-output-stream :allow-other-keys nil
+					    :foo 'bar)
+		 program-error)
+  t)
+
+
+
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/make-synonym-stream.lsp
@@ -0,0 +1,97 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Wed Jan 28 06:54:33 2004
+;;;; Contains: Tests of MAKE-SYNONYM-STREAM
+
+(in-package :cl-test)
+
+(deftest make-synonym-stream.1
+  (with-input-from-string
+   (*s* "abcde")
+   (declare (special *s*))
+   (let ((ss (make-synonym-stream '*s*)))
+     (assert (typep ss 'stream))
+     (assert (typep ss 'synonym-stream))
+     (assert (input-stream-p ss))
+     (assert (not (output-stream-p ss)))
+     (assert (open-stream-p ss))
+     (assert (streamp ss))
+     (assert (stream-element-type ss))
+     (values
+      (read-char *s*)
+      (read-char ss)
+      (read-char *s*)
+      (read-char ss)
+      (read-char ss))))
+  #\a #\b #\c #\d #\e)
+
+
+;;; This test was wrong (section 21.1.4)
+#|
+(deftest make-synonym-stream.2
+   (let ((ss (make-synonym-stream '*s*)))
+     (with-input-from-string
+      (*s* "z")
+      (declare (special *s*))
+      (assert (typep ss 'stream))
+      (assert (typep ss 'synonym-stream))
+      (assert (input-stream-p ss))
+      (assert (not (output-stream-p ss)))
+      (assert (open-stream-p ss))
+      (assert (streamp ss))
+      (assert (stream-element-type ss))
+      (read-char ss)))
+   #\z)
+|#
+
+(deftest make-synonym-stream.3
+  (with-output-to-string
+   (*s*)
+   (declare (special *s*))
+   (let ((ss (make-synonym-stream '*s*)))
+     (assert (typep ss 'stream))
+     (assert (typep ss 'synonym-stream))
+     (assert (output-stream-p ss))
+     (assert (not (input-stream-p ss)))
+     (assert (open-stream-p ss))
+     (assert (streamp ss))
+     (assert (stream-element-type ss))
+     (write-char #\a *s*)
+     (write-char #\b ss)
+     (write-char #\x *s*)
+     (write-char #\y ss)))
+  "abxy")
+
+(deftest make-synonym-stream.4
+  (let ((ss (make-synonym-stream '*terminal-io*)))
+     (assert (typep ss 'stream))
+     (assert (typep ss 'synonym-stream))
+     (assert (output-stream-p ss))
+     (assert (input-stream-p ss))
+     (assert (open-stream-p ss))
+     (assert (streamp ss))
+     (assert (stream-element-type ss))
+     nil)
+  nil)
+
+
+;;; FIXME
+;;; Add tests for: close,
+;;;  peek-char, read-char-no-hang, terpri, fresh-line, unread-char,
+;;;  read-line, write-line, write-string, read-sequence, write-sequence,
+;;;  read-byte, write-byte, listen, clear-input, finish-output, force-output,
+;;;  clear-output, format, print, prin1, princ
+
+;;; Error cases
+
+(deftest make-synonym-stream.error.1
+  (signals-error (make-synonym-stream) program-error)
+  t)
+
+(deftest make-synonym-stream.error.2
+  (signals-error (make-synonym-stream '*standard-input* nil) program-error)
+  t)
+
+(deftest make-synonym-stream.error.3
+  (check-type-error #'make-synonym-stream #'symbolp)
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/make-two-way-stream.lsp
@@ -0,0 +1,244 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Fri Jan 30 05:39:56 2004
+;;;; Contains: Tests for MAKE-TWO-WAY-STREAM
+
+(in-package :cl-test)
+
+(deftest make-two-way-stream.1
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-two-way-stream is os)))
+    (assert (typep s 'stream))
+    (assert (typep s 'two-way-stream))
+    (assert (streamp s))
+    (assert (open-stream-p s))
+    (assert (input-stream-p s))
+    (assert (output-stream-p s))
+    (assert (stream-element-type s))
+    (values
+     (read-char s)
+     (write-char #\b s)
+     (read-char s)
+     (write-char #\a s)
+     (read-char s)
+     (write-char #\r s)
+     (get-output-stream-string os)))
+  #\f #\b #\o #\a #\o #\r "bar")
+
+(deftest make-two-way-stream.2
+   (let* ((is (make-string-input-stream "foo"))
+	  (os (make-string-output-stream))
+	  (s (make-two-way-stream is os)))
+     (values
+      (close s)
+      (open-stream-p s)
+      (notnot (open-stream-p is))
+      (notnot (open-stream-p os))
+      (write-char #\8 os)
+      (get-output-stream-string os)))
+   t nil t t #\8 "8")
+
+(deftest make-two-way-stream.3
+   (let* ((is (make-string-input-stream "foo"))
+	  (os (make-string-output-stream))
+	  (s (make-two-way-stream is os)))
+     (values
+      (peek-char nil s)
+      (read-char s)
+      (get-output-stream-string os)))
+   #\f #\f "")
+
+(deftest make-two-way-stream.4
+   (let* ((is (make-string-input-stream "foo"))
+	  (os (make-string-output-stream))
+	  (s (make-two-way-stream is os)))
+     (values
+      (read-char-no-hang s)
+      (read-char-no-hang s nil)
+      (read-char-no-hang s t :eof)
+      (read-char-no-hang s nil :eof)
+      (get-output-stream-string os)))
+   #\f #\o #\o :eof "")
+
+(deftest make-two-way-stream.5
+   (let* ((is (make-string-input-stream "foo"))
+	  (os (make-string-output-stream))
+	  (s (make-two-way-stream is os)))
+     (values
+      (terpri s)
+      (get-output-stream-string os)))
+   nil #.(string #\Newline))
+
+(deftest make-two-way-stream.6
+   (let* ((is (make-string-input-stream "foo"))
+	  (os (make-string-output-stream))
+	  (s (make-two-way-stream is os)))
+     (values
+      (write-char #\+ s)
+      (notnot (fresh-line s))
+      (read-char s)
+      (get-output-stream-string os)))
+   #\+ t #\f #.(coerce (list #\+ #\Newline) 'string))
+
+(deftest make-two-way-stream.7
+   (let* ((is (make-string-input-stream "foo"))
+	  (os (make-string-output-stream))
+	  (s (make-two-way-stream is os)))
+     (values
+      (read-char s)
+      (unread-char #\f s)
+      (read-char s)
+      (read-char s)
+      (unread-char #\o s)
+      (get-output-stream-string os)))
+   #\f nil #\f #\o nil "")
+
+(deftest make-two-way-stream.8
+   (let* ((is (make-string-input-stream "foo"))
+	  (os (make-string-output-stream))
+	  (s (make-two-way-stream is os)))
+     (values
+      (read-line s)
+      (get-output-stream-string os)))
+   "foo" "")
+
+(deftest make-two-way-stream.9
+   (let* ((is (make-string-input-stream "foo"))
+	  (os (make-string-output-stream))
+	  (s (make-two-way-stream is os)))
+     (values
+      (write-string "bar" s)
+      (get-output-stream-string os)))
+   "bar" "bar")
+
+(deftest make-two-way-stream.10
+   (let* ((is (make-string-input-stream "foo"))
+	  (os (make-string-output-stream))
+	  (s (make-two-way-stream is os)))
+     (values
+      (write-line "bar" s)
+      (get-output-stream-string os)))
+   "bar" #.(concatenate 'string "bar" '(#\Newline)))
+
+(deftest make-two-way-stream.11
+  (let* ((is (make-string-input-stream "foo"))
+	  (os (make-string-output-stream))
+	  (s (make-two-way-stream is os)))
+    (let ((x (vector nil nil nil)))
+     (values
+      (read-sequence x s)
+      x
+      (get-output-stream-string os))))
+  3 #(#\f #\o #\o) "")
+
+(deftest make-two-way-stream.12
+  (let ((pn1 #p"tmp.dat")
+	(pn2 #p"tmp2.dat")
+	(element-type '(unsigned-byte 8)))
+    (with-open-file (s pn1 :direction :output :if-exists :supersede
+		       :element-type element-type)
+		    (dolist (b '(3 8 19 41)) (write-byte b s)))
+    (with-open-file
+     (is pn1 :direction :input :element-type element-type)
+     (with-open-file
+      (os pn2 :direction :output :element-type element-type
+	  :if-exists :supersede)
+      (let ((s (make-two-way-stream is os))
+	    (x (vector nil nil nil nil)))
+	(assert (eql (read-sequence x s) 4))
+	(assert (equalp x #(3 8 19 41)))
+	(let ((y #(100 5 18 211 0 178)))
+	  (assert (eql (write-sequence y s) y))
+	  (close s)))))
+    (with-open-file
+     (s pn2 :direction :input :element-type element-type)
+     (let ((x (vector nil nil nil nil nil nil nil)))
+       (values
+	(read-sequence x s)
+	x))))
+  6
+  #(100 5 18 211 0 178 nil))
+
+(deftest make-two-way-stream.13
+  (let ((pn1 #p"tmp.dat")
+	(pn2 #p"tmp2.dat")
+	(element-type '(unsigned-byte 32)))
+    (with-open-file (s pn1 :direction :output :if-exists :supersede
+		       :element-type element-type)
+		    (dolist (b '(3 8 19 41)) (write-byte b s)))
+    (with-open-file
+     (is pn1 :direction :input :element-type element-type)
+     (with-open-file
+      (os pn2 :direction :output :element-type element-type
+	  :if-exists :supersede)
+      (let ((s (make-two-way-stream is os))
+	    (x (vector nil nil nil nil)))
+	(assert (eql (read-sequence x s) 4))
+	(assert (equalp x #(3 8 19 41)))
+	(let ((y #(100 5 18 211 0 178)))
+	  (assert (eql (write-sequence y s) y))
+	  (close s)))))
+    (with-open-file
+     (s pn2 :direction :input :element-type element-type)
+     (let ((x (vector nil nil nil nil nil nil nil)))
+       (values
+	(read-sequence x s)
+	x))))
+  6
+  #(100 5 18 211 0 178 nil))
+
+(deftest make-two-way-stream.14
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-two-way-stream is os)))
+    (values
+     (write-string "abc" s)
+     (clear-input s)
+     (write-string "def" s)
+     (get-output-stream-string os)))
+  "abc" nil "def" "abcdef")
+
+;;; Error tests
+
+(deftest make-two-way-stream.error.1
+  (signals-error (make-two-way-stream) program-error)
+  t)
+
+(deftest make-two-way-stream.error.2
+  (signals-error (make-two-way-stream (make-string-input-stream "foo"))
+		 program-error)
+  t)
+
+(deftest make-two-way-stream.error.3
+  (signals-error (let ((os (make-string-output-stream)))
+		   (make-two-way-stream (make-string-input-stream "foo")
+					os nil))
+		 program-error)
+  t)
+
+(deftest make-two-way-stream.error.4
+  (check-type-error #'(lambda (x) (make-two-way-stream x (make-string-output-stream)))
+		    #'(lambda (x) (and (streamp x) (input-stream-p x))))
+  nil)
+
+(deftest make-two-way-stream.error.5
+  (check-type-error #'(lambda (x) (make-two-way-stream x (make-string-output-stream)))
+		    #'(lambda (x) (and (streamp x) (input-stream-p x)))
+		    *streams*)
+  nil)
+
+(deftest make-two-way-stream.error.6
+  (check-type-error #'(lambda (x) (make-two-way-stream (make-string-input-stream "foo") x))
+		    #'(lambda (x) (and (streamp x) (output-stream-p x))))
+  nil)
+
+(deftest make-two-way-stream.error.7
+  (check-type-error #'(lambda (x) (make-two-way-stream (make-string-input-stream "foo") x))
+		    #'(lambda (x) (and (streamp x) (output-stream-p x)))
+		    *streams*)
+  nil)
+
+
+
+						
\ No newline at end of file
--- /dev/null
+++ gcl-2.6.12/ansi-tests/merge-pathnames.lsp
@@ -0,0 +1,124 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Wed Dec 31 11:25:55 2003
+;;;; Contains: Tests of MERGE-PATHNAMES
+
+(in-package :cl-test)
+
+#|
+(defun merge-pathnames-test (&rest args)
+  (assert (<= 1 (length args) 3))
+  (let* ((p1 (car args))
+	 (p2 (if (cdr args) (cadr args) *default-pathname-defaults*))
+	 (default-version (if (cddr args) (caddr args) :newest))
+	 (results (multiple-value-list (apply #'merge-pathnames args))))
+    (assert (= (length results) 1))
+    (let ((p3 (first results)))
+      
+|#
+
+(deftest merge-pathnames.1
+  (let* ((p1 (make-pathname :name "foo"))
+	 (p2 (merge-pathnames p1 p1 nil)))
+    (values
+     (equalpt (pathname-name p1) "foo")
+     (if (equalpt p1 p2) t
+       (list p1 p2))))
+  t t)
+
+(deftest merge-pathnames.2
+  (let* ((p1 (make-pathname :name "foo"))
+	 (p2 (merge-pathnames p1 p1)))
+    (values
+     (equalpt (pathname-host p1) (pathname-host p2))
+     (equalpt (pathname-device p1) (pathname-device p2))
+     (equalpt (pathname-directory p1) (pathname-directory p2))
+     (pathname-name p1)
+     (pathname-name p2)
+     (equalpt (pathname-type p1) (pathname-type p2))
+     (if (pathname-version p1)
+	 (equalpt (pathname-version p1) (pathname-version p2))
+       (equalpt (pathname-version p2) :newest))))
+  t t t "foo" "foo" t t)
+
+(deftest merge-pathnames.3
+  (let* ((p1 (make-pathname :name "foo"))
+	 (p2 (make-pathname :name "bar"))
+	 (p3 (merge-pathnames p1 p2)))
+    (values
+     (equalpt (pathname-host p1) (pathname-host p3))
+     (equalpt (pathname-device p1) (pathname-device p3))
+     (equalpt (pathname-directory p1) (pathname-directory p3))
+     (pathname-name p1)
+     (pathname-name p3)
+     (equalpt (pathname-type p1) (pathname-type p3))
+     (if (pathname-version p1)
+	 (equalpt (pathname-version p1) (pathname-version p3))
+       (equalpt (pathname-version p3) :newest))))
+  t t t "foo" "foo" t t)
+
+(deftest merge-pathnames.4
+  (let* ((p1 (make-pathname :name "foo"))
+	 (p2 (make-pathname :type "lsp"))
+	 (p3 (merge-pathnames p1 p2)))
+    (values
+     (equalpt (pathname-host p1) (pathname-host p3))
+     (equalpt (pathname-device p1) (pathname-device p3))
+     (equalpt (pathname-directory p1) (pathname-directory p3))
+     (pathname-name p1)
+     (pathname-type p2)
+     (pathname-type p3)
+     (equalpt (pathname-type p2) (pathname-type p3))
+     (if (pathname-version p1)
+	 (equalpt (pathname-version p1) (pathname-version p3))
+       (equalpt (pathname-version p3) :newest))))
+  t t t "foo" "lsp" "lsp" t t)
+
+(deftest merge-pathnames.5
+  (let* ((p1 (make-pathname :name "foo"))
+	 (p2 (make-pathname :type "lsp" :version :newest))
+	 (p3 (merge-pathnames p1 p2 nil)))
+    (values
+     (equalpt (pathname-host p1) (pathname-host p3))
+     (equalpt (pathname-device p1) (pathname-device p3))
+     (equalpt (pathname-directory p1) (pathname-directory p3))
+     (pathname-name p1)
+     (pathname-name p3)
+     (pathname-type p2)
+     (pathname-type p3)
+     (equalpt (pathname-version p1) (pathname-version p3))))
+  t t t "foo" "foo" "lsp" "lsp" t)
+
+(deftest merge-pathnames.6
+  (let* ((p1 (make-pathname))
+	 (p2 (make-pathname :name "foo" :version :newest))
+	 (p3 (merge-pathnames p1 p2 nil)))
+    (values
+     (equalpt (pathname-host p1) (pathname-host p3))
+     (equalpt (pathname-device p1) (pathname-device p3))
+     (equalpt (pathname-directory p1) (pathname-directory p3))
+     (pathname-name p2)
+     (pathname-name p3)
+     (equalpt (pathname-type p2) (pathname-type p3))
+     (pathname-version p2)
+     (pathname-version p3)))
+  t t t "foo" "foo" t :newest :newest)
+
+(deftest merge-pathnames.7
+  (let* ((p1 (make-pathname))
+	 (p2 *default-pathname-defaults*)
+	 (p3 (merge-pathnames p1)))
+    (values
+     (equalpt (pathname-host p1) (pathname-host p3))
+     (equalpt (pathname-host p2) (pathname-host p3))
+     (equalpt (pathname-device p2) (pathname-device p3))
+     (equalpt (pathname-directory p2) (pathname-directory p3))
+     (equalpt (pathname-name p2) (pathname-name p3))
+     (equalpt (pathname-type p2) (pathname-type p3))
+     (cond
+      ((pathname-version p1) (equalpt (pathname-version p1)
+				      (pathname-version p3)))
+      ((pathname-version p2) (equalpt (pathname-version p2)
+				      (pathname-version p3)))
+      (t (equalpt (pathname-version p3) :newest)))))
+  t t t t t t t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/namestring.lsp
@@ -0,0 +1,64 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Thu Sep  2 07:24:42 2004
+;;;; Contains: Tests for NAMESTRING
+
+(in-package :cl-test)
+
+(deftest namestring.1
+  (let* ((vals (multiple-value-list (namestring "namestring.lsp")))
+	 (s (first vals)))
+    (if (and (null (cdr vals))
+	     (stringp s)
+	     (equal (namestring s) s))
+	:good
+      vals))
+  :good)
+
+(deftest namestring.2
+  (do-special-strings
+   (s "namestring.lsp" nil)
+   (let ((ns (namestring s)))
+     (assert (stringp ns))
+     (assert (string= (namestring ns) ns))))
+  nil)
+
+;;; I'm not convinced these tested required behavior, so I'm commenting
+;;; them out for now.  FIXME: determine if they are bogus
+#|
+(deftest namestring.3
+  (let* ((name "namestring.lsp")
+	 (pn (merge-pathnames (pathname name)))
+	 (name2 (namestring pn))
+	 (pn2 (pathname name2)))
+    (or (equalt pn pn2) (list (list pn (pathname-host pn) (pathname-device pn)
+				    (pathname-directory pn) (pathname-name pn)
+				    (pathname-type pn) (pathname-version pn))
+			      (list pn2 (pathname-host pn2) (pathname-device pn2)
+				    (pathname-directory pn2) (pathname-name pn2)
+				    (pathname-type pn2) (pathname-version pn2)))))
+  t)
+
+(deftest namestring.4
+  (let* ((name "namestring.lsp")
+	 (pn (merge-pathnames (pathname name)))
+	 (name2 (with-open-file (s pn :direction :input) (namestring s)))
+	 (pn2 (pathname name2)))
+    (or (equalt pn pn2) (list (list pn (pathname-host pn) (pathname-device pn)
+				    (pathname-directory pn) (pathname-name pn)
+				    (pathname-type pn) (pathname-version pn))
+			      (list pn2 (pathname-host pn2) (pathname-device pn2)
+				    (pathname-directory pn2) (pathname-name pn2)
+				    (pathname-type pn2) (pathname-version pn2)))))
+  t)
+|#
+
+;;; Error tests
+
+(deftest namestring.error.1
+  (signals-error (namestring) program-error)
+  t)
+
+(deftest namestring.error.2
+  (signals-error (namestring "namestring.lsp" nil) program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/open-stream-p.lsp
@@ -0,0 +1,54 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Jan 13 19:52:30 2004
+;;;; Contains: Tests of OPEN-STREAM-P
+
+(in-package :cl-test)
+
+(deftest open-stream-p.1
+  (loop for s in (list *debug-io* *error-output* *query-io*
+		       *standard-input* *standard-output*
+		       *trace-output* *terminal-io*)
+	for results = (multiple-value-list (open-stream-p s))
+	unless (and (eql (length results) 1)
+		    (car results))
+	collect s)
+  nil)
+
+(deftest open-stream-p.2
+  (with-open-file (s "open-stream-p.lsp" :direction :input)
+		  (notnot-mv (open-stream-p s)))
+  t)
+
+(deftest open-stream-p.3
+  (with-open-file (s "foo.txt" :direction :output
+		     :if-exists :supersede)
+		  (notnot-mv (open-stream-p s)))
+  t)
+
+(deftest open-stream-p.4
+  (let ((s (open "open-stream-p.lsp" :direction :input)))
+    (close s)
+    (open-stream-p s))
+  nil)
+
+(deftest open-stream-p.5
+  (let ((s (open "foo.txt" :direction :output
+		 :if-exists :supersede)))
+    (close s)
+    (open-stream-p s))
+  nil)
+
+;;; error tests
+
+(deftest open-stream-p.error.1
+  (signals-error (open-stream-p) program-error)
+  t)
+
+(deftest open-stream-p.error.2
+  (signals-error (open-stream-p *standard-input* nil) program-error)
+  t)
+
+(deftest open-stream-p.error.3
+  (check-type-error #'open-stream-p #'streamp)
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/open.lsp
@@ -0,0 +1,1238 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Fri Jan 23 05:36:55 2004
+;;;; Contains: Tests of OPEN
+
+(in-package :cl-test)
+
+;;; Input streams
+
+(defun generator-for-element-type (type)
+  (etypecase type
+   ((member character base-char)
+    #'(lambda (i) (aref "abcdefghijklmnopqrstuvwxyz" (mod i 26))))
+   ((member signed-byte unsigned-byte bit)
+    #'(lambda (i) (logand i 1)))
+   (cons
+    (let ((op (car type))
+	  (arg1 (cadr type))
+	  (arg2 (caddr type)))
+      (ecase op
+	(unsigned-byte
+	 (let ((mask (1- (ash 1 arg1))))
+	   #'(lambda (i) (logand i mask))))
+	(signed-byte
+	 (let ((mask (1- (ash 1 (1- arg1)))))
+	   #'(lambda (i) (logand i mask))))
+	(integer
+	 (let* ((lo arg1)
+		(hi arg2)
+	       (lower-bound
+		(etypecase lo
+		  (integer lo)
+		  (cons (1+ (car lo)))))
+	       (upper-bound
+		(etypecase hi
+		  (integer hi)
+		  (cons (1- (car hi)))))
+	       (range (1+ (- upper-bound lower-bound))))
+	   #'(lambda (i) (+ lower-bound (mod i range))))))))))
+
+(compile 'generator-for-element-type)
+
+(defmacro def-open-test (name args form expected
+			      &key
+			      (notes nil notes-p)
+			      (build-form nil build-form-p)
+			      (element-type 'character element-type-p)
+			      (pathname #p"tmp.dat"))
+	  
+  (when element-type-p
+    (setf args (append args (list :element-type `',element-type))))
+
+  (unless build-form-p
+    (let ((write-element-form
+	   (cond
+	    ((subtypep element-type 'integer)
+	     `(write-byte
+	       (funcall (the function
+			  (generator-for-element-type ',element-type)) i)
+	       os))
+	    ((subtypep element-type 'character)
+	     `(write-char
+	       (funcall (the function
+			  (generator-for-element-type ',element-type)) i)
+	       os)))))
+      (setq build-form
+	    `(with-open-file
+	      (os pn :direction :output
+		  ,@(if element-type-p
+			`(:element-type ',element-type))
+		  :if-exists :supersede)
+	      (assert (open-stream-p os))
+	      (dotimes (i 10) ,write-element-form)
+	      (finish-output os)
+	    ))))
+			      
+  `(deftest ,name
+     ,@(when notes-p `(:notes ,notes))
+     (let ((pn ,pathname))
+       (delete-all-versions pn)
+       ,build-form
+       (let ((s (open pn ,@args)))
+	 (unwind-protect
+	     (progn
+	       (assert (open-stream-p s))
+	       (assert (typep s 'file-stream))
+	       ,@
+	       (unless (member element-type '(signed-byte unsigned-byte))
+		 #-allegro
+		 `((assert (subtypep ',element-type
+				     (stream-element-type s))))
+		 #+allegro nil
+		 )
+	       ,form)
+	   (close s))))
+     ,@expected))
+
+;; (compile 'def-open-test)
+
+(def-open-test open.1 () (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.2 (:direction :input)
+  (values (read-line s nil)) ("abcdefghij") :element-type character)
+(def-open-test open.3 (:direction :input)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.4 (:direction :input)
+  (values (read-line s nil)) ("abcdefghij") :element-type base-char)
+(def-open-test open.5 (:if-exists :error)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.6 (:if-exists :error :direction :input)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.7 (:if-exists :new-version)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.8 (:if-exists :new-version :direction :input)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.9 (:if-exists :rename)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.10 (:if-exists :rename :direction :input)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.11 (:if-exists :rename-and-delete)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.12 (:if-exists :rename-and-delete :direction :input)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.13 (:if-exists :overwrite)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.14 (:if-exists :overwrite :direction :input)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.15 (:if-exists :append)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.16 (:if-exists :append :direction :input)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.17 (:if-exists :supersede)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.18 (:if-exists :supersede :direction :input)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.19 (:if-exists nil)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.20 (:if-exists nil :direction :input)
+  (values (read-line s nil)) ("abcdefghij"))
+
+(def-open-test open.21 (:if-does-not-exist nil)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.22 (:if-does-not-exist nil :direction :input)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.23 (:if-does-not-exist :error)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.24 (:if-does-not-exist :error :direction :input)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.25 (:if-does-not-exist :create)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.26 (:if-does-not-exist :create :direction :input)
+  (values (read-line s nil)) ("abcdefghij"))
+
+(def-open-test open.27 (:external-format :default)
+  (values (read-line s nil)) ("abcdefghij"))
+(def-open-test open.28 (:external-format :default :direction :input)
+  (values (read-line s nil)) ("abcdefghij"))
+
+(def-open-test open.29 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 0 1 0 1 0 1 0 1)) :element-type (unsigned-byte 1))
+(def-open-test open.30 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 0 1 0 1 0 1 0 1)) :element-type (unsigned-byte 1))
+
+(def-open-test open.31 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 0 1 2 3 0 1)) :element-type (unsigned-byte 2))
+(def-open-test open.32 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 0 1 2 3 0 1)) :element-type (unsigned-byte 2))
+
+(def-open-test open.33 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 0 1)) :element-type (unsigned-byte 3))
+(def-open-test open.34 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 0 1)) :element-type (unsigned-byte 3))
+
+(def-open-test open.35 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 4))
+(def-open-test open.36 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 4))
+
+(def-open-test open.37 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 5))
+(def-open-test open.38 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 5))
+
+(def-open-test open.39 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 6))
+(def-open-test open.40 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 6))
+
+(def-open-test open.41 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 7))
+(def-open-test open.42 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 7))
+
+(def-open-test open.43 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 8))
+(def-open-test open.44 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 8))
+
+(def-open-test open.45 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 9))
+(def-open-test open.46 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 9))
+
+(def-open-test open.47 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 10))
+(def-open-test open.48 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 10))
+
+(def-open-test open.49 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 20))
+(def-open-test open.50 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 20))
+
+(def-open-test open.51 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 25))
+(def-open-test open.52 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 25))
+
+(def-open-test open.53 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 30))
+(def-open-test open.54 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 30))
+
+(def-open-test open.55 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 32))
+(def-open-test open.56 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 32))
+
+(def-open-test open.57 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 33))
+(def-open-test open.58 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 33))
+
+(def-open-test open.59 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 0 1 0 1 0 1 0 1)) :element-type unsigned-byte)
+(def-open-test open.60 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 0 1 0 1 0 1 0 1)) :element-type unsigned-byte)
+
+(def-open-test open.61 ()
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 0 1 0 1 0 1 0 1)) :element-type signed-byte)
+(def-open-test open.62 (:direction :input)
+  (let ((seq (make-array 10))) (read-sequence seq s) seq)
+  (#(0 1 0 1 0 1 0 1 0 1)) :element-type signed-byte)
+
+
+(def-open-test open.63 ()
+  (values (read-line s nil)) ("abcdefghij")
+  :pathname "tmp.dat")
+
+(def-open-test open.64 ()
+  (values (read-line s nil)) ("abcdefghij")
+  :pathname (logical-pathname "CLTEST:TMP.DAT"))
+
+;;; It works on recognizable subtypes.
+(deftest open.65
+  (let ((type '(or (integer 0 1) (integer 100 200)))
+	(pn #p"tmp.dat")
+	(vals '(0 1 100 120 130 190 200 1 0 150)))
+    (or
+     (not (subtypep type 'integer))
+     (progn
+       (with-open-file
+	(os pn :direction :output
+	    :element-type type
+	    :if-exists :supersede)
+	(dolist (e vals) (write-byte e os)))
+       (let ((s (open pn :direction :input
+		      :element-type type))
+	     (seq (make-array 10)))
+	 (unwind-protect
+	     (progn (read-sequence seq s) seq)
+	   (close s))
+	 (notnot (every #'eql seq vals))))))
+  t)
+
+;;; FIXME: Add -- tests for when the filespec is a stream
+
+(deftest open.66
+  (let ((pn #p"tmp.dat"))
+    (delete-all-versions pn)
+    (with-open-file
+     (s pn :direction :io :if-exists :rename-and-delete
+	:if-does-not-exist :create)
+     (format s "some stuff~%")
+     (finish-output s)
+     (let ((is (open s :direction :input)))
+       (unwind-protect
+	   (values
+	    (read-char is)
+	    (notnot (file-position s :start))
+	    (read-line is)
+	    (read-line s))
+	 (close is)))))
+  #\s
+  t
+  "ome stuff"
+  "some stuff")
+
+(deftest open.67
+  (let ((pn #p"tmp.dat"))
+    (delete-all-versions pn)
+    (let ((s (open pn :direction :output)))
+      (unwind-protect
+	  (progn
+	    (format s "some stuff~%")
+	    (finish-output s)
+	    (close s)
+	    (let ((is (open s :direction :input)))
+	      (unwind-protect
+		  (values (read-line is))
+		(close is))))
+	(when (open-stream-p s) (close s)))))
+  "some stuff")
+
+;;; FIXME: Add -- tests for when element-type is :default
+
+;;; Tests of file creation
+
+(defmacro def-open-output-test
+  (name args form expected
+	&rest keyargs
+	&key
+	(element-type 'character)
+	(build-form
+	 `(dotimes (i 10)
+	    ,(cond
+	      ((subtypep element-type 'integer)
+	       `(write-byte
+		 (funcall (the function
+			    (generator-for-element-type ',element-type)) i)
+		 s))
+	      ((subtypep element-type 'character)
+	       `(write-char
+		 (funcall (the function
+			    (generator-for-element-type ',element-type)) i)
+		 s)))))
+	&allow-other-keys)
+  `(def-open-test ,name (:direction :output ,@args)
+     (progn
+       ,build-form
+       (assert (output-stream-p s))
+       ,form)
+     ,expected
+     :build-form nil
+     ,@keyargs))
+
+;; (compile 'def-open-output-test)
+
+(def-open-output-test open.output.1 ()
+  (progn (close s)
+	 (with-open-file (is #p"tmp.dat") (values (read-line is nil))))
+  ("abcdefghij"))
+
+(def-open-output-test open.output.2 ()
+  (progn (close s)
+	 (with-open-file (is "tmp.dat") (values (read-line is nil))))
+  ("abcdefghij")
+  :pathname "tmp.dat")
+
+(def-open-output-test open.output.3
+  ()
+  (progn (close s)
+	 (with-open-file (is (logical-pathname "CLTEST:TMP.DAT"))
+			 (values (read-line is nil))))
+  ("abcdefghij")
+  :pathname (logical-pathname "CLTEST:TMP.DAT"))
+
+(def-open-output-test open.output.4 ()
+  (progn (close s)
+	 (with-open-file (is #p"tmp.dat" :element-type 'character)
+			 (values (read-line is nil))))
+  ("abcdefghij")
+  :element-type character)
+
+(def-open-output-test open.output.5 ()
+  (progn (close s) (with-open-file (is #p"tmp.dat"
+				       :element-type 'base-char)
+				   (values (read-line is nil))))
+  ("abcdefghij")
+  :element-type base-char)
+
+(def-open-output-test open.output.6 ()
+  (progn (close s) (with-open-file (is #p"tmp.dat"
+				       :element-type '(integer 0 1))
+				   (let ((seq (make-array 10)))
+				     (read-sequence seq is)
+				     seq)))
+  (#(0 1 0 1 0 1 0 1 0 1))
+  :element-type (integer 0 1))
+
+(def-open-output-test open.output.7 ()
+  (progn (close s) (with-open-file (is #p"tmp.dat"
+				       :element-type 'bit)
+				   (let ((seq (make-array 10)))
+				     (read-sequence seq is)
+				     seq)))
+  (#(0 1 0 1 0 1 0 1 0 1))
+  :element-type bit)
+
+(def-open-output-test open.output.8 ()
+  (progn (close s) (with-open-file (is #p"tmp.dat"
+				       :element-type '(unsigned-byte 1))
+				   (let ((seq (make-array 10)))
+				     (read-sequence seq is)
+				     seq)))
+  (#(0 1 0 1 0 1 0 1 0 1))
+  :element-type (unsigned-byte 1))
+
+(def-open-output-test open.output.9 ()
+  (progn (close s) (with-open-file (is #p"tmp.dat"
+				       :element-type '(unsigned-byte 2))
+				   (let ((seq (make-array 10)))
+				     (read-sequence seq is)
+				     seq)))
+  (#(0 1 2 3 0 1 2 3 0 1))
+  :element-type (unsigned-byte 2))
+
+(def-open-output-test open.output.10 ()
+  (progn (close s) (with-open-file (is #p"tmp.dat"
+				       :element-type '(unsigned-byte 3))
+				   (let ((seq (make-array 10)))
+				     (read-sequence seq is)
+				     seq)))
+  (#(0 1 2 3 4 5 6 7 0 1))
+  :element-type (unsigned-byte 3))
+
+(def-open-output-test open.output.11 ()
+  (progn (close s) (with-open-file (is #p"tmp.dat"
+				       :element-type '(unsigned-byte 4))
+				   (let ((seq (make-array 10)))
+				     (read-sequence seq is)
+				     seq)))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 4))
+
+
+(def-open-output-test open.output.12 ()
+  (progn (close s) (with-open-file (is #p"tmp.dat"
+				       :element-type '(unsigned-byte 6))
+				   (let ((seq (make-array 10)))
+				     (read-sequence seq is)
+				     seq)))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 6))
+
+(def-open-output-test open.output.13 ()
+  (progn (close s) (with-open-file (is #p"tmp.dat"
+				       :element-type '(unsigned-byte 8))
+				   (let ((seq (make-array 10)))
+				     (read-sequence seq is)
+				     seq)))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 8))
+
+(def-open-output-test open.output.14 ()
+  (progn (close s) (with-open-file (is #p"tmp.dat"
+				       :element-type '(unsigned-byte 12))
+				   (let ((seq (make-array 10)))
+				     (read-sequence seq is)
+				     seq)))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 12))
+
+(def-open-output-test open.output.15 ()
+  (progn (close s) (with-open-file (is #p"tmp.dat"
+				       :element-type '(unsigned-byte 16))
+				   (let ((seq (make-array 10)))
+				     (read-sequence seq is)
+				     seq)))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 16))
+
+(def-open-output-test open.output.16 ()
+  (progn (close s) (with-open-file (is #p"tmp.dat"
+				       :element-type '(unsigned-byte 24))
+				   (let ((seq (make-array 10)))
+				     (read-sequence seq is)
+				     seq)))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 24))
+
+(def-open-output-test open.output.17 ()
+  (progn (close s) (with-open-file (is #p"tmp.dat"
+				       :element-type '(unsigned-byte 32))
+				   (let ((seq (make-array 10)))
+				     (read-sequence seq is)
+				     seq)))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 32))
+
+(def-open-output-test open.output.18 ()
+  (progn (close s) (with-open-file (is #p"tmp.dat"
+				       :element-type '(unsigned-byte 64))
+				   (let ((seq (make-array 10)))
+				     (read-sequence seq is)
+				     seq)))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 64))
+
+(def-open-output-test open.output.19 ()
+  (progn (close s) (with-open-file (is #p"tmp.dat"
+				       :element-type '(unsigned-byte 100))
+				   (let ((seq (make-array 10)))
+				     (read-sequence seq is)
+				     seq)))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 100))
+
+(deftest open.output.20
+  (let ((pn #p"tmp.dat"))
+    (with-open-file (s pn :direction :output :if-exists :supersede))
+    (open pn :direction :output :if-exists nil))
+  nil)
+
+(def-open-test open.output.21 (:if-exists :new-version :direction :output)
+  (progn (write-sequence "wxyz" s)
+	 (close s)
+	 (with-open-file
+	  (s pn :direction :input)
+	  (values (read-line s nil))))
+  ("wxyz")
+  :notes (:open-if-exists-new-version-no-error)
+  )
+
+(def-open-test open.output.22 (:if-exists :rename :direction :output)
+  (progn (write-sequence "wxyz" s)
+	 (close s)
+	 (with-open-file
+	  (s pn :direction :input)
+	  (values (read-line s nil))))
+  ("wxyz"))
+
+(def-open-test open.output.23 (:if-exists :rename-and-delete
+					  :direction :output)
+  (progn (write-sequence "wxyz" s)
+	 (close s)
+	 (with-open-file
+	  (s pn :direction :input)
+	  (values (read-line s nil))))
+  ("wxyz"))
+
+(def-open-test open.output.24 (:if-exists :overwrite
+					  :direction :output)
+  (progn (write-sequence "wxyz" s)
+	 (close s)
+	 (with-open-file
+	  (s pn :direction :input)
+	  (values (read-line s nil))))
+  ("wxyzefghij"))
+
+(def-open-test open.output.25 (:if-exists :append
+					  :direction :output)
+  (progn (write-sequence "wxyz" s)
+	 (close s)
+	 (with-open-file
+	  (s pn :direction :input)
+	  (values (read-line s nil))))
+  ("abcdefghijwxyz"))
+
+(def-open-test open.output.26 (:if-exists :supersede
+					  :direction :output)
+  (progn (write-sequence "wxyz" s)
+	 (close s)
+	 (with-open-file
+	  (s pn :direction :input)
+	  (values (read-line s nil))))
+  ("wxyz"))
+
+(def-open-output-test open.output.27 (:if-does-not-exist :create
+							 :direction :output)
+  (progn (close s)
+	 (with-open-file
+	  (is pn :direction :input)
+	  (values (read-line is nil))))
+  ("abcdefghij"))
+
+(deftest open.output.28
+  (let ((pn #p"tmp.dat"))
+    (delete-all-versions pn)
+    (open pn :direction :output :if-does-not-exist nil))
+  nil)
+
+(def-open-output-test open.output.28a (:external-format :default)
+  (progn (close s)
+	 (with-open-file (is #p"tmp.dat") (values (read-line is nil))))
+  ("abcdefghij"))
+
+(def-open-output-test open.output.29
+  (:external-format (prog1
+		      (with-open-file (s "foo.dat" :direction :output
+					 :if-exists :supersede)
+				      (stream-external-format s))
+		      (delete-all-versions "foo.dat")
+		      ))
+  (progn (close s)
+	 (with-open-file (is #p"tmp.dat") (values (read-line is nil))))
+  ("abcdefghij"))
+
+;;; Default behavior of open :if-exists is :create when the version
+;;; of the filespec is :newest
+
+(deftest open.output.30
+  :notes (:open-if-exists-new-version-no-error)
+  (let ((pn (make-pathname :name "tmp" :type "dat" :version :newest)))
+    (or (not (eql (pathname-version pn) :newest))
+	(progn
+	  ;; Create file
+	  (let ((s1 (open pn :direction :output :if-exists :overwrite
+			  :if-does-not-exist :create)))
+	    (unwind-protect
+		;; Now try again
+		(let ((s2 (open pn :direction :output)))
+		  (unwind-protect
+		      (write-line "abcdef" s2)
+		    (close s2))
+		  (unwind-protect
+		      (progn
+			(setq s2 (open s1 :direction :input))
+			(equalt (read-line s2 nil) "abcdef"))
+		    (close s2)))
+	      (close s1)
+	      (delete-all-versions pn)
+	      )))))
+  t)
+
+(def-open-output-test open.output.31 (:if-exists :rename
+				      :direction :output)
+  (progn (close s)
+	 (with-open-file
+	  (is pn :direction :input)
+	  (values (read-line is nil))))
+  ("abcdefghij"))
+
+(def-open-output-test open.output.32 (:if-exists :rename-and-delete
+				      :direction :output)
+  (progn (close s)
+	 (with-open-file
+	  (is pn :direction :input)
+	  (values (read-line is nil))))
+  ("abcdefghij"))
+
+(def-open-output-test open.output.33 (:if-exists :new-version
+				      :direction :output)
+  (progn (close s)
+	 (with-open-file
+	  (is pn :direction :input)
+	  (values (read-line is nil))))
+  ("abcdefghij"))
+
+(def-open-output-test open.output.34 (:if-exists :supersede
+				      :direction :output)
+  (progn (close s)
+	 (with-open-file
+	  (is pn :direction :input)
+	  (values (read-line is nil))))
+  ("abcdefghij"))
+
+(def-open-output-test open.output.35 (:if-exists nil
+				      :direction :output)
+  (progn (close s)
+	 (with-open-file
+	  (is pn :direction :input)
+	  (values (read-line is nil))))
+  ("abcdefghij"))	    
+
+;;; Add -- tests for when the filespec is a stream
+
+
+;;; Tests of bidirectional IO
+
+(defmacro def-open-io-test
+  (name args form expected
+	&rest keyargs
+	&key
+	(element-type 'character)
+	(build-form
+	 `(dotimes (i 10)
+	    ,(cond
+	      ((subtypep element-type 'integer)
+	       `(write-byte
+		 (funcall (the function
+			    (generator-for-element-type ',element-type)) i)
+		 s))
+	      ((subtypep element-type 'character)
+	       `(write-char
+		 (funcall (the function
+			    (generator-for-element-type ',element-type)) i)
+		 s)))))
+	&allow-other-keys)
+  `(def-open-test ,name (:direction :io ,@args)
+     (progn
+       ,build-form
+       (assert (input-stream-p s))
+       (assert (output-stream-p s))
+       ,form)
+     ,expected
+     :build-form nil
+     ,@keyargs))
+
+;; (compile 'def-open-io-test)
+
+(def-open-io-test open.io.1 ()
+  (progn (file-position s :start)
+	 (values (read-line s nil)))
+  ("abcdefghij"))
+
+(def-open-io-test open.io.2 ()
+  (progn (file-position s :start)
+	 (values (read-line s nil)))
+  ("abcdefghij")
+  :pathname "tmp.dat")
+
+(def-open-io-test open.io.3
+  ()
+  (progn (file-position s :start)
+	 (values (read-line s nil)))
+  ("abcdefghij")
+  :pathname (logical-pathname "CLTEST:TMP.DAT"))
+
+(def-open-io-test open.io.4 ()
+  (progn (file-position s :start)
+	 (values (read-line s nil)))
+  ("abcdefghij")
+  :element-type character)
+
+(def-open-io-test open.io.5 ()
+  (progn (file-position s :start)
+	 (values (read-line s nil)))
+  ("abcdefghij")
+  :element-type base-char)
+
+(def-open-io-test open.io.6 ()
+  (progn (file-position s :start)
+	 (let ((seq (make-array 10)))
+	   (read-sequence seq s)
+	   seq))
+  (#(0 1 0 1 0 1 0 1 0 1))
+  :element-type (integer 0 1))
+
+(def-open-io-test open.io.7 ()
+  (progn (file-position s :start)
+	 (let ((seq (make-array 10)))
+	   (read-sequence seq s)
+	   seq))
+  (#(0 1 0 1 0 1 0 1 0 1))
+  :element-type bit)
+
+(def-open-io-test open.io.8 ()
+  (progn (file-position s :start)
+	 (let ((seq (make-array 10)))
+	   (read-sequence seq s)
+	   seq))
+  (#(0 1 0 1 0 1 0 1 0 1))
+  :element-type (unsigned-byte 1))
+
+(def-open-io-test open.io.9 ()
+  (progn (file-position s :start)
+	 (let ((seq (make-array 10)))
+	   (read-sequence seq s)
+	   seq))
+  (#(0 1 2 3 0 1 2 3 0 1))
+  :element-type (unsigned-byte 2))
+
+(def-open-io-test open.io.10 ()
+  (progn (file-position s :start)
+	 (let ((seq (make-array 10)))
+	   (read-sequence seq s)
+	   seq))
+  (#(0 1 2 3 4 5 6 7 0 1))
+  :element-type (unsigned-byte 3))
+
+(def-open-io-test open.io.11 ()
+  (progn (file-position s :start)
+	 (let ((seq (make-array 10)))
+	   (read-sequence seq s)
+	   seq))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 4))
+
+
+(def-open-io-test open.io.12 ()
+  (progn (file-position s :start)
+	 (let ((seq (make-array 10)))
+	   (read-sequence seq s)
+	   seq))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 6))
+
+(def-open-io-test open.io.13 ()
+  (progn (file-position s :start)
+	 (let ((seq (make-array 10)))
+	   (read-sequence seq s)
+	   seq))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 8))
+
+(def-open-io-test open.io.14 ()
+  (progn (file-position s :start)
+	 (let ((seq (make-array 10)))
+	   (read-sequence seq s)
+	   seq))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 12))
+
+(def-open-io-test open.io.15 ()
+  (progn (file-position s :start)
+	 (let ((seq (make-array 10)))
+	   (read-sequence seq s)
+	   seq))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 16))
+
+(def-open-io-test open.io.16 ()
+  (progn (file-position s :start)
+	 (let ((seq (make-array 10)))
+	   (read-sequence seq s)
+	   seq))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 24))
+
+(def-open-io-test open.io.17 ()
+  (progn (file-position s :start)
+	 (let ((seq (make-array 10)))
+	   (read-sequence seq s)
+	   seq))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 32))
+
+(def-open-io-test open.io.18 ()
+  (progn (file-position s :start)
+	 (let ((seq (make-array 10)))
+	   (read-sequence seq s)
+	   seq))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 64))
+
+(def-open-io-test open.io.19 ()
+  (progn (file-position s :start)
+	 (let ((seq (make-array 10)))
+	   (read-sequence seq s)
+	   seq))
+  (#(0 1 2 3 4 5 6 7 8 9))
+  :element-type (unsigned-byte 100))
+
+(deftest open.io.20
+  (let ((pn #p"tmp.dat"))
+    (with-open-file (s pn :direction :io :if-exists :supersede))
+    (open pn :direction :io :if-exists nil))
+  nil)
+
+(def-open-test open.io.21 (:if-exists :new-version :direction :io)
+  (progn (write-sequence "wxyz" s)
+	 (file-position s :start)
+	 (values (read-line s nil)))
+  ("wxyz")
+  :notes (:open-if-exists-new-version-no-error)
+  )
+
+(def-open-test open.io.22 (:if-exists :rename :direction :io)
+  (progn (write-sequence "wxyz" s)
+	 (file-position s :start)
+	 (values (read-line s nil)))
+  ("wxyz"))
+
+(def-open-test open.io.23 (:if-exists :rename-and-delete
+			   :direction :io)
+  (progn (write-sequence "wxyz" s)
+	 (file-position s :start)
+	 (values (read-line s nil)))
+  ("wxyz"))
+
+(def-open-test open.io.24 (:if-exists :overwrite
+			   :direction :io)
+  (progn (write-sequence "wxyz" s)
+	 (file-position s :start)
+	 (values (read-line s nil)))
+  ("wxyzefghij"))
+
+(def-open-test open.io.25 (:if-exists :append
+			   :direction :io)
+  (progn (write-sequence "wxyz" s)
+	 (file-position s :start)
+	 (values (read-line s nil)))
+  ("abcdefghijwxyz"))
+
+(def-open-test open.io.26 (:if-exists :supersede
+			   :direction :io)
+  (progn (write-sequence "wxyz" s)
+	 (file-position s :start)
+	 (values (read-line s nil)))
+  ("wxyz"))
+
+(def-open-io-test open.io.27 (:if-does-not-exist :create
+			      :direction :io)
+  (progn (file-position s :start)
+	 (values (read-line s nil)))
+  ("abcdefghij"))
+
+(deftest open.io.28
+  (let ((pn #p"tmp.dat"))
+    (delete-all-versions pn)
+    (open pn :direction :io :if-does-not-exist nil))
+  nil)
+
+(def-open-io-test open.io.28a (:external-format :default)
+  (progn (file-position s :start)
+	 (values (read-line s nil)))
+  ("abcdefghij"))
+
+(def-open-io-test open.io.29
+  (:external-format (prog1
+		      (with-open-file (s "foo.dat" :direction :io
+					 :if-exists :supersede)
+				      (stream-external-format s))
+		      (delete-all-versions "foo.dat")
+		      ))
+  (progn (file-position s :start)
+	 (values (read-line s nil)))
+  ("abcdefghij"))
+
+;;; Default behavior of open :if-exists is :create when the version
+;;; of the filespec is :newest
+
+(deftest open.io.30
+  :notes (:open-if-exists-new-version-no-error)
+  (let ((pn (make-pathname :name "tmp" :type "dat" :version :newest)))
+    (or (not (eql (pathname-version pn) :newest))
+	(progn
+	  ;; Create file
+	  (let ((s1 (open pn :direction :io :if-exists :overwrite
+			  :if-does-not-exist :create)))
+	    (unwind-protect
+		;; Now try again
+		(let ((s2 (open pn :direction :io)))
+		  (unwind-protect
+		      (write-line "abcdef" s2)
+		    (close s2))
+		  (unwind-protect
+		      (progn
+			(setq s2 (open s1 :direction :input))
+			(equalt (read-line s2 nil) "abcdef"))
+		    (close s2)))
+	      (close s1)
+	      (delete-all-versions pn)
+	      )))))
+  t)
+
+(def-open-io-test open.io.31 (:if-exists :rename
+			      :direction :io)
+  (progn (file-position s :start)
+	 (values (read-line s nil)))
+  ("abcdefghij"))
+
+(def-open-io-test open.io.32 (:if-exists :rename-and-delete
+			      :direction :io)
+  (progn (file-position s :start)
+	 (values (read-line s nil)))
+  ("abcdefghij"))
+
+(def-open-io-test open.io.33 (:if-exists :new-version
+			      :direction :io)
+  (progn (file-position s :start)
+	 (values (read-line s nil)))
+  ("abcdefghij"))
+
+(def-open-io-test open.io.34 (:if-exists :supersede
+			      :direction :io)
+  (progn (file-position s :start)
+	 (values (read-line s nil)))
+  ("abcdefghij"))
+
+(def-open-io-test open.io.35 (:if-exists nil
+			      :direction :io)
+  (progn (file-position s :start)
+	 (values (read-line s nil)))
+  ("abcdefghij"))
+
+;;;; :PROBE tests
+
+(defmacro def-open-probe-test
+  (name args form
+	&key (build-form nil build-form-p)
+	(pathname #p"tmp.dat"))
+  (unless build-form-p
+    (setf build-form
+	  `(with-open-file (s pn :direction :output
+			      :if-exists :supersede))))
+  `(deftest ,name
+     (let ((pn ,pathname))
+       (delete-all-versions pn)
+       ,build-form
+       (let ((s (open pn :direction :probe ,@args)))
+	 (values
+	  ,(if build-form
+	       `(and
+		 (typep s 'file-stream)
+		 (not (open-stream-p s))
+		 )
+	     `(not s))
+	  ,form)))
+     t t))
+
+(def-open-probe-test open.probe.1 () t)
+(def-open-probe-test open.probe.2 (:if-exists :error) t)
+(def-open-probe-test open.probe.3 (:if-exists :new-version) t)
+(def-open-probe-test open.probe.4 (:if-exists :rename) t)
+(def-open-probe-test open.probe.5 (:if-exists :rename-and-delete) t)
+(def-open-probe-test open.probe.6 (:if-exists :overwrite) t)
+(def-open-probe-test open.probe.7 (:if-exists :append) t)
+(def-open-probe-test open.probe.8 (:if-exists :supersede) t)
+
+(def-open-probe-test open.probe.9 (:if-does-not-exist :error) t)
+(def-open-probe-test open.probe.10 (:if-does-not-exist nil) t)
+(def-open-probe-test open.probe.11 (:if-does-not-exist :create) t)
+
+(def-open-probe-test open.probe.12 () t :build-form nil)
+(def-open-probe-test open.probe.13 (:if-exists :error) t :build-form nil)
+(def-open-probe-test open.probe.14 (:if-exists :new-version) t :build-form nil)
+(def-open-probe-test open.probe.15 (:if-exists :rename) t :build-form nil)
+(def-open-probe-test open.probe.16 (:if-exists :rename-and-delete) t
+  :build-form nil)
+(def-open-probe-test open.probe.17 (:if-exists :overwrite) t
+  :build-form nil)
+(def-open-probe-test open.probe.18 (:if-exists :append) t
+  :build-form nil)
+(def-open-probe-test open.probe.19 (:if-exists :supersede) t
+  :build-form nil)
+
+(def-open-probe-test open.probe.20 (:if-does-not-exist nil) t
+  :build-form nil)
+
+(deftest open.probe.21
+  (let ((pn #p"tmp.dat"))
+    (delete-all-versions pn)
+    (let ((s (open pn :direction :probe :if-does-not-exist :create)))
+      (values
+       (notnot s)
+       (notnot (probe-file pn)))))
+  t t)
+
+(deftest open.probe.22
+  (let ((pn #p"tmp.dat"))
+    (delete-all-versions pn)
+    (let ((s (open pn :direction :probe :if-does-not-exist :create
+		   :if-exists :error)))
+      (values
+       (notnot s)
+       (notnot (probe-file pn)))))
+  t t)
+
+(def-open-probe-test open.probe.23 (:external-format :default) t)
+(def-open-probe-test open.probe.24 (:element-type 'character) t)
+(def-open-probe-test open.probe.25 (:element-type 'bit) t)
+(def-open-probe-test open.probe.26 (:element-type '(unsigned-byte 2)) t)
+(def-open-probe-test open.probe.27 (:element-type '(unsigned-byte 4)) t)
+(def-open-probe-test open.probe.28 (:element-type '(unsigned-byte 8)) t)
+(def-open-probe-test open.probe.29 (:element-type '(unsigned-byte 9)) t)
+(def-open-probe-test open.probe.30 (:element-type '(unsigned-byte 15)) t)
+(def-open-probe-test open.probe.31 (:element-type '(unsigned-byte 16)) t)
+(def-open-probe-test open.probe.32 (:element-type '(unsigned-byte 17)) t)
+(def-open-probe-test open.probe.33 (:element-type '(unsigned-byte 31)) t)
+(def-open-probe-test open.probe.34 (:element-type '(unsigned-byte 32)) t)
+(def-open-probe-test open.probe.35 (:element-type '(unsigned-byte 33)) t)
+(def-open-probe-test open.probe.36 (:element-type '(integer -1002 13112)) t)
+
+;;;; Error tests
+
+(deftest open.error.1
+  (signals-error (open) program-error)
+  t)
+
+(deftest open.error.2
+  (signals-error-always
+   (let ((pn #p"tmp.dat"))
+     (close (open pn :direction :output :if-does-not-exist :create))
+     (open pn :if-exists :error :direction :output))
+   file-error)
+  t t)
+
+(deftest open.error.3
+  (signals-error-always
+   (let ((pn #p"tmp.dat"))
+     (close (open pn :direction :output :if-does-not-exist :create))
+     (open pn :if-exists :error :direction :io))
+   file-error)
+  t t)
+
+(deftest open.error.4
+  (signals-error-always
+   (let ((pn #p"tmp.dat"))
+     (delete-all-versions pn)
+     (open pn))
+   file-error)
+  t t)
+
+(deftest open.error.5
+  (signals-error-always
+   (let ((pn #p"tmp.dat"))
+     (delete-all-versions pn)
+     (open pn :if-does-not-exist :error))
+   file-error)
+  t t)
+
+(deftest open.error.6
+  (signals-error-always
+   (let ((pn #p"tmp.dat"))
+     (delete-all-versions pn)
+     (open pn :direction :input))
+   file-error)
+  t t)
+
+(deftest open.error.7
+  (signals-error-always
+   (let ((pn #p"tmp.dat"))
+     (delete-all-versions pn)
+     (open pn :if-does-not-exist :error :direction :input))
+   file-error)
+  t t)
+
+(deftest open.error.8
+  (signals-error-always
+   (let ((pn #p"tmp.dat"))
+     (delete-all-versions pn)
+     (open pn :direction :output :if-does-not-exist :error))
+   file-error)
+  t t)
+
+(deftest open.error.9
+  (signals-error-always
+   (let ((pn #p"tmp.dat"))
+     (delete-all-versions pn)
+     (open pn :direction :io :if-does-not-exist :error))
+   file-error)
+  t t)
+
+(deftest open.error.10
+  (signals-error-always
+   (let ((pn #p"tmp.dat"))
+     (delete-all-versions pn)
+     (open pn :direction :probe :if-does-not-exist :error))
+   file-error)
+  t t)
+
+(deftest open.error.11
+  (signals-error-always
+   (let ((pn #p"tmp.dat"))
+     (delete-all-versions pn)
+     (open pn :direction :output :if-exists :overwrite))
+   file-error)
+  t t)
+
+(deftest open.error.12
+  (signals-error-always
+   (let ((pn #p"tmp.dat"))
+     (delete-all-versions pn)
+     (open pn :direction :output :if-exists :append))
+   file-error)
+  t t)
+
+(deftest open.error.13
+  (signals-error-always
+   (let ((pn #p"tmp.dat"))
+     (delete-all-versions pn)
+     (open pn :direction :io :if-exists :overwrite))
+   file-error)
+  t t)
+
+(deftest open.error.14
+  (signals-error-always
+   (let ((pn #p"tmp.dat"))
+     (delete-all-versions pn)
+     (open pn :direction :io :if-exists :append))
+   file-error)
+  t t)
+
+(deftest open.error.15
+  (signals-error-always
+   (open (make-pathname :name :wild :type "lsp"))
+   file-error)
+  t t)
+
+(deftest open.error.16
+  (signals-error-always
+   (open (make-pathname :name "open" :type :wild))
+   file-error)
+  t t)
+
+(deftest open.error.17
+  (signals-error-always
+   (let ((pn (make-pathname :name "open" :type "lsp" :version :wild)))
+     (if (wild-pathname-p pn) (open pn)
+       (error 'file-error)))
+   file-error)
+  t t)
+
+(deftest open.error.18
+  (signals-error-always
+   (open #p"tmp.dat" :direction :output :if-exists :supersede
+	 :external-form (gensym))
+   error)
+  t t)
+
+
+;;; FIXME -- add tests for :element-type :default
+
+;;; FIXME -- add tests for filespec being a specialized string
--- /dev/null
+++ gcl-2.6.12/ansi-tests/output-stream-p.lsp
@@ -0,0 +1,39 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Jan 13 19:46:12 2004
+;;;; Contains: Tests of OUTPUT-STREAM-P
+
+(in-package :cl-test)
+
+(deftest output-stream-p.1
+  (notnot-mv (output-stream-p *standard-output*))
+  t)
+
+(deftest output-stream-p.2
+  (notnot-mv (output-stream-p *terminal-io*))
+  t)
+
+(deftest output-stream-p.3
+  (with-open-file (s "output-stream-p.lsp" :direction :input)
+		  (output-stream-p s))
+  nil)
+
+(deftest output-stream-p.4
+  (with-open-file (s "foo.txt" :direction :output
+		     :if-exists :supersede)
+		  (notnot-mv (output-stream-p s)))
+  t)
+
+;;; Error tests
+
+(deftest output-stream-p.error.1
+  (signals-error (output-stream-p) program-error)
+  t)
+
+(deftest output-stream-p.error.2
+  (signals-error (output-stream-p *standard-output* nil) program-error)
+  t)
+
+(deftest output-stream-p.error.3
+  (check-type-error #'output-stream-p #'streamp)
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/parse-namestring.lsp
@@ -0,0 +1,89 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Aug 14 13:59:18 2004
+;;;; Contains: Tests of PARSE-NAMESTRING
+
+(in-package :cl-test)
+
+;;; "Parsing a null string always succeeds, producing a pathname
+;;;  with all components (except the host) equal to nil."
+
+(deftest parse-namestring.1
+  (let ((vals (multiple-value-list (parse-namestring ""))))
+    (assert (= (length vals) 2))
+    (let ((pn (first vals))
+	  (pos (second vals)))
+      (values
+       (pathname-directory pn)
+       (pathname-device pn)
+       (pathname-name pn)
+       (pathname-type pn)
+       (pathname-version pn)
+       pos)))
+  nil nil nil nil nil 0)
+
+(deftest parse-namestring.2
+  (let ((vals (multiple-value-list (parse-namestring (make-array 0 :element-type 'base-char)))))
+    (assert (= (length vals) 2))
+    (let ((pn (first vals))
+	  (pos (second vals)))
+      (values
+       (pathname-directory pn)
+       (pathname-device pn)
+       (pathname-name pn)
+       (pathname-type pn)
+       (pathname-version pn)
+       pos)))
+  nil nil nil nil nil 0)
+
+(deftest parse-namestring.3
+  (let ((vals (multiple-value-list (parse-namestring (make-array 4 :element-type 'base-char
+								 :initial-element #\X
+								 :fill-pointer 0)))))
+    (assert (= (length vals) 2))
+    (let ((pn (first vals))
+	  (pos (second vals)))
+      (values
+       (pathname-directory pn)
+       (pathname-device pn)
+       (pathname-name pn)
+       (pathname-type pn)
+       (pathname-version pn)
+       pos)))
+  nil nil nil nil nil 0)
+
+(deftest parse-namestring.4
+  (loop for etype in '(standard-char base-char character)
+	for s0 = (make-array 4 :element-type etype :initial-element #\X)
+	for s = (make-array 0 :element-type etype :displaced-to s0
+			    :displaced-index-offset 1)
+	for vals = (multiple-value-list (parse-namestring s))
+	for pn = (first vals)
+	for pos = (second vals)
+	do (assert (= (length vals) 2))
+	nconc
+	(let ((result (list (pathname-directory pn)
+			    (pathname-device pn)
+			    (pathname-name pn)
+			    (pathname-type pn)
+			    (pathname-version pn)
+			    pos)))
+	  (unless (equal result '(nil nil nil nil nil 0))
+	    (list (list etype result)))))
+  nil)
+
+;;; Error tests
+
+(deftest parse-namestring.error.1
+  (signals-error (parse-namestring) program-error)
+  t)
+
+(deftest parse-name-string.error.2
+  (signals-error (parse-namestring "" nil *default-pathname-defaults* :foo nil) program-error)
+  t)
+
+(deftest parse-name-string.error.3
+  (signals-error (parse-namestring "" nil *default-pathname-defaults* :start) program-error)
+  t)
+
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/pathname-device.lsp
@@ -0,0 +1,74 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Dec  6 14:23:54 2003
+;;;; Contains: Tests for PATHNAME-DEVICE
+
+(in-package :cl-test)
+
+(compile-and-load "pathnames-aux.lsp")
+
+(deftest pathname-device.1
+  (loop for p in *pathnames*
+	for device = (pathname-device p)
+	unless (or (stringp device)
+		   (member device '(nil :wild :unspecific)))
+	collect (list p device))
+  nil)
+
+(deftest pathname-device.2
+  (loop for p in *pathnames*
+	for device = (pathname-device p :case :local)
+	unless (or (stringp device)
+		   (member device '(nil :wild :unspecific)))
+	collect (list p device))
+  nil)
+
+(deftest pathname-device.3
+  (loop for p in *pathnames*
+	for device = (pathname-device p :case :common)
+	unless (or (stringp device)
+		   (member device '(nil :wild :unspecific)))
+	collect (list p device))
+  nil)
+
+(deftest pathname-device.4
+  (loop for p in *pathnames*
+	for device = (pathname-device p :allow-other-keys nil)
+	unless (or (stringp device)
+		   (member device '(nil :wild :unspecific)))
+	collect (list p device))
+  nil)
+
+(deftest pathname-device.5
+  (loop for p in *pathnames*
+	for device = (pathname-device p :foo 'bar :allow-other-keys t)
+	unless (or (stringp device)
+		   (member device '(nil :wild :unspecific)))
+	collect (list p device))
+  nil)
+
+(deftest pathname-device.6
+  (loop for p in *pathnames*
+	for device = (pathname-device p :allow-other-keys t :allow-other-keys nil :foo 'bar)
+	unless (or (stringp device)
+		   (member device '(nil :wild :unspecific)))
+	collect (list p device))
+  nil)
+
+;;; section 19.3.2.1
+(deftest pathname-device.7
+  (loop for p in *logical-pathnames*
+	always (eq (pathname-device p) :unspecific))
+  t)
+
+(deftest pathname-device.8
+  (do-special-strings (s "" nil) (pathname-device s))
+  nil)
+
+(deftest pathname-device.error.1
+  (signals-error (pathname-device) program-error)
+  t)
+
+(deftest pathname-device.error.2
+  (check-type-error #'pathname-device #'could-be-pathname-designator)
+  nil)
\ No newline at end of file
--- /dev/null
+++ gcl-2.6.12/ansi-tests/pathname-directory.lsp
@@ -0,0 +1,89 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Dec  6 14:24:39 2003
+;;;; Contains: Tests for PATHNAME-DIRECTORY
+
+(in-package :cl-test)
+
+(compile-and-load "pathnames-aux.lsp")
+
+(deftest pathname-directory.1
+  (loop for p in *pathnames*
+	for directory = (pathname-directory p)
+	unless (or (stringp directory)
+		   (member directory '(nil :wild :unspecific))
+		   (and (consp directory)
+			(member (car directory) '(:absolute :relative))))
+	collect (list p directory))
+  nil)
+
+(deftest pathname-directory.2
+  (loop for p in *pathnames*
+	for directory = (pathname-directory p :case :local)
+	unless (or (stringp directory)
+		   (member directory '(nil :wild :unspecific))
+		   (and (consp directory)
+			(member (car directory) '(:absolute :relative))))
+	collect (list p directory))
+  nil)
+
+(deftest pathname-directory.3
+  (loop for p in *pathnames*
+	for directory = (pathname-directory p :case :common)
+	unless (or (stringp directory)
+		   (member directory '(nil :wild :unspecific))
+		   (and (consp directory)
+			(member (car directory) '(:absolute :relative))))
+	collect (list p directory))
+  nil)
+
+(deftest pathname-directory.4
+  (loop for p in *pathnames*
+	for directory = (pathname-directory p :allow-other-keys nil)
+	unless (or (stringp directory)
+		   (member directory '(nil :wild :unspecific))
+		   (and (consp directory)
+			(member (car directory) '(:absolute :relative))))
+	collect (list p directory))
+  nil)
+
+(deftest pathname-directory.5
+  (loop for p in *pathnames*
+	for directory = (pathname-directory p :foo 'bar :allow-other-keys t)
+	unless (or (stringp directory)
+		   (member directory '(nil :wild :unspecific))
+		   (and (consp directory)
+			(member (car directory) '(:absolute :relative))))
+	collect (list p directory))
+  nil)
+
+(deftest pathname-directory.6
+  (loop for p in *pathnames*
+	for directory = (pathname-directory p :allow-other-keys t
+					    :allow-other-keys nil
+					    'foo 'bar)
+	unless (or (stringp directory)
+		   (member directory '(nil :wild :unspecific))
+		   (and (consp directory)
+			(member (car directory) '(:absolute :relative))))
+	collect (list p directory))
+  nil)
+
+;;; section 19.3.2.1
+(deftest pathname-directory.7
+  (loop for p in *logical-pathnames*
+	when (eq (pathname-directory p) :unspecific)
+	collect p)
+  nil)
+
+(deftest pathname-directory.8
+  (do-special-strings (s "" nil) (pathname-directory s))
+  nil)
+
+(deftest pathname-directory.error.1
+  (signals-error (pathname-directory) program-error)
+  t)
+
+(deftest pathname-directory.error.2
+  (check-type-error #'pathname-directory #'could-be-pathname-designator)
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/pathname-host.lsp
@@ -0,0 +1,79 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Dec  6 14:23:22 2003
+;;;; Contains: Tests for PATHNAME-HOST
+
+(in-package :cl-test)
+
+(compile-and-load "pathnames-aux.lsp")
+
+(deftest pathname-host.1
+  (loop for p in *pathnames*
+	always (eql (length (multiple-value-list (pathname-host p))) 1))
+  t)
+
+(deftest pathname-host.2
+  (loop for p in *pathnames*
+	always (eql (length (multiple-value-list (pathname-host p :case :local))) 1))
+  t)
+
+(deftest pathname-host.3
+  (loop for p in *pathnames*
+	always (eql (length (multiple-value-list (pathname-host p :case :common))) 1))
+  t)
+
+(deftest pathname-host.4
+  (loop for p in *pathnames*
+	always (eql (length (multiple-value-list (pathname-host p :allow-other-keys nil))) 1))
+  t)
+
+(deftest pathname-host.5
+  (loop for p in *pathnames*
+	always (eql (length (multiple-value-list
+			     (pathname-host p :foo t :allow-other-keys t))) 1))
+  t)
+
+(deftest pathname-host.6
+  (loop for p in *pathnames*
+	always (eql (length (multiple-value-list
+			     (pathname-host p :allow-other-keys t
+					    :allow-other-keys nil
+					    'foo t))) 1))
+  t)
+
+;;; section 19.3.2.1
+(deftest pathname-host.7
+  (loop for p in *logical-pathnames*
+	when (eq (pathname-host p) :unspecific)
+	collect p)
+  nil)
+
+(deftest pathname-host.8
+  (do-special-strings (s "" nil) (pathname-host s))
+  nil)
+
+#|
+(deftest pathname-host.9
+  (loop for p in *pathnames*
+	for host = (pathname-host p)
+	unless (or (stringp host)
+		   (and (listp host) (every #'stringp host))
+		   (eql host :unspecific))
+	collect (list p host))
+  nil)
+|#
+
+;;; Error cases
+
+(deftest pathname-host.error.1
+  (signals-error (pathname-host) program-error)
+  t)
+
+(deftest pathname-host.error.2
+  (check-type-error #'pathname-host #'could-be-pathname-designator)
+  nil)
+
+(deftest pathname-host.error.3
+  (signals-error (pathname-host *default-pathname-defaults* '#:bogus t)
+		 program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/pathname-match-p.lsp
@@ -0,0 +1,103 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Aug 15 07:46:22 2004
+;;;; Contains: Tests for PATHNAME-MATCH-P
+
+(in-package :cl-test)
+
+(compile-and-load "pathnames-aux.lsp")
+
+;;; Much of the behavior cannot be tested portably.
+
+(deftest pathname-match-p.1
+  (let ((pn1 (make-pathname :name :wild))
+	(pn2 (make-pathname :name "foo")))
+    (pathname-match-p pn1 pn2))
+  nil)
+
+(deftest pathname-match-p.2
+  (let ((pn1 (make-pathname :type :wild))
+	(pn2 (make-pathname :type "txt")))
+    (pathname-match-p pn1 pn2))
+  nil)
+
+(deftest pathname-match-p.3
+  (let ((pn1 (make-pathname :directory '(:absolute :wild)))
+	(pn2 (make-pathname :directory '(:absolute))))
+    (pathname-match-p pn1 pn2))
+  nil)
+
+(deftest pathname-match-p.4
+  (let ((pn1 (make-pathname :directory '(:relative :wild)))
+	(pn2 (make-pathname :directory '(:relative))))
+    (pathname-match-p pn1 pn2))
+  nil)
+
+(deftest pathname-match-p.5
+  (let ((pn1 (make-pathname :directory '(:relative :wild)))
+	(pn2 (make-pathname :directory nil)))
+    (and (wild-pathname-p pn1)
+	 (not (pathname-directory pn2))
+	 (not (pathname-match-p pn1 pn2))))
+  nil)
+
+(deftest pathname-match-p.6
+  (let ((pn1 (make-pathname :version :wild))
+	(pn2 (make-pathname)))
+    (and (wild-pathname-p pn1)
+	 (not (pathname-version pn2))
+	 (not (pathname-match-p pn1 pn2))))
+  nil)
+
+;;; Specialized string tests
+
+(deftest pathname-match-p.7
+  (let ((wpn (parse-namestring "CLTEST:*.LSP")))
+    (assert (wild-pathname-p wpn))
+    (do-special-strings
+     (s "CLTEST:FOO.LSP" nil)
+     (assert (pathname-match-p s wpn))))
+  nil)
+
+(deftest pathname-match-p.8
+  (do-special-strings
+   (s "CLTEST:*.LSP" nil)
+   (assert (pathname-match-p "CLTEST:FOO.LSP" s)))
+  nil)
+   
+
+;;; Add more tests here
+
+;;; Here are error tests
+
+(deftest pathname-match-p.error.1
+  (signals-error (pathname-match-p) program-error)
+  t)
+
+(deftest pathname-match-p.error.2
+  (signals-error (pathname-match-p #p"") program-error)
+  t)
+
+(deftest pathname-match-p.error.3
+  (signals-error (pathname-match-p #p"" #p"" nil) program-error)
+  t)
+
+(deftest pathname-match-p.error.4
+  (check-type-error #'(lambda (x) (pathname-match-p x #p""))
+		    #'could-be-pathname-designator)
+  nil)
+
+(deftest pathname-match-p.error.5
+  (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pathname-match-p x #p""))
+		    #'could-be-pathname-designator)
+  nil)
+
+(deftest pathname-match-p.error.6
+  (check-type-error #'(lambda (x) (pathname-match-p #p"" x))
+		    #'could-be-pathname-designator)
+  nil)
+
+(deftest pathname-match-p.error.7
+  (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pathname-match-p #p"" x))
+		    #'could-be-pathname-designator)
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/pathname-name.lsp
@@ -0,0 +1,75 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Dec  6 14:45:16 2003
+;;;; Contains: Tests for PATHNAME-NAME
+
+(in-package :cl-test)
+
+(compile-and-load "pathnames-aux.lsp")
+
+(deftest pathname-name.1
+  (loop for p in *pathnames*
+	for name = (pathname-name p)
+	unless (or (stringp name)
+		   (member name '(nil :wild :unspecific)))
+	collect (list p name))
+  nil)
+
+(deftest pathname-name.2
+  (loop for p in *pathnames*
+	for name = (pathname-name p :case :local)
+	unless (or (stringp name)
+		   (member name '(nil :wild :unspecific)))
+	collect (list p name))
+  nil)
+
+(deftest pathname-name.3
+  (loop for p in *pathnames*
+	for name = (pathname-name p :case :common)
+	unless (or (stringp name)
+		   (member name '(nil :wild :unspecific)))
+	collect (list p name))
+  nil)
+
+(deftest pathname-name.4
+  (loop for p in *pathnames*
+	for name = (pathname-name p :allow-other-keys nil)
+	unless (or (stringp name)
+		   (member name '(nil :wild :unspecific)))
+	collect (list p name))
+  nil)
+
+(deftest pathname-name.5
+  (loop for p in *pathnames*
+	for name = (pathname-name p :foo 'bar :allow-other-keys t)
+	unless (or (stringp name)
+		   (member name '(nil :wild :unspecific)))
+	collect (list p name))
+  nil)
+
+(deftest pathname-name.6
+  (loop for p in *pathnames*
+	for name = (pathname-name p :allow-other-keys t :allow-other-keys nil :foo 'bar)
+	unless (or (stringp name)
+		   (member name '(nil :wild :unspecific)))
+	collect (list p name))
+  nil)
+
+;;; section 19.3.2.1
+(deftest pathname-name.7
+  (loop for p in *logical-pathnames*
+	when (eq (pathname-name p) :unspecific)
+	collect p)
+  nil)
+
+(deftest pathname-name.8
+  (do-special-strings (s "" nil) (pathname-name s))
+  nil)
+
+(deftest pathname-name.error.1
+  (signals-error (pathname-name) program-error)
+  t)
+
+(deftest pathname-name.error.2
+  (check-type-error #'pathname-name #'could-be-pathname-designator)
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/pathname-type.lsp
@@ -0,0 +1,75 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Dec  6 14:45:16 2003
+;;;; Contains: Tests for PATHNAME-TYPE
+
+(in-package :cl-test)
+
+(compile-and-load "pathnames-aux.lsp")
+
+(deftest pathname-type.1
+  (loop for p in *pathnames*
+	for type = (pathname-type p)
+	unless (or (stringp type)
+		   (member type '(nil :wild :unspecific)))
+	collect (list p type))
+  nil)
+
+(deftest pathname-type.2
+  (loop for p in *pathnames*
+	for type = (pathname-type p :case :local)
+	unless (or (stringp type)
+		   (member type '(nil :wild :unspecific)))
+	collect (list p type))
+  nil)
+
+(deftest pathname-type.3
+  (loop for p in *pathnames*
+	for type = (pathname-type p :case :common)
+	unless (or (stringp type)
+		   (member type '(nil :wild :unspecific)))
+	collect (list p type))
+  nil)
+
+(deftest pathname-type.4
+  (loop for p in *pathnames*
+	for type = (pathname-type p :allow-other-keys nil)
+	unless (or (stringp type)
+		   (member type '(nil :wild :unspecific)))
+	collect (list p type))
+  nil)
+
+(deftest pathname-type.5
+  (loop for p in *pathnames*
+	for type = (pathname-type p :foo 'bar :allow-other-keys t)
+	unless (or (stringp type)
+		   (member type '(nil :wild :unspecific)))
+	collect (list p type))
+  nil)
+
+(deftest pathname-type.6
+  (loop for p in *pathnames*
+	for type = (pathname-type p :allow-other-keys t :allow-other-keys nil :foo 'bar)
+	unless (or (stringp type)
+		   (member type '(nil :wild :unspecific)))
+	collect (list p type))
+  nil)
+
+;;; section 19.3.2.1
+(deftest pathname-type.7
+  (loop for p in *logical-pathnames*
+	when (eq (pathname-type p) :unspecific)
+	collect p)
+  nil)
+
+(deftest pathname-type.8
+  (do-special-strings (s "" nil) (pathname-type s))
+  nil)
+
+(deftest pathname-type.error.1
+  (signals-error (pathname-type) program-error)
+  t)
+
+(deftest pathname-type.error.2
+  (check-type-error #'pathname-type #'could-be-pathname-designator)
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/pathname-version.lsp
@@ -0,0 +1,40 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Dec  6 14:45:16 2003
+;;;; Contains: Tests for PATHNAME-VERSION
+
+(in-package :cl-test)
+
+(compile-and-load "pathnames-aux.lsp")
+
+(deftest pathname-version.1
+  (loop for p in *pathnames*
+	for version = (pathname-version p)
+	unless (or (integerp version) (symbolp version))
+	collect (list p version))
+  nil)
+
+;;; section 19.3.2.1
+(deftest pathname-version.2
+  (loop for p in *logical-pathnames*
+	when (eq (pathname-version p) :unspecific)
+	collect p)
+  nil)
+
+(deftest pathname-version.3
+  (do-special-strings (s "" nil) (pathname-version s))
+  nil)
+
+(deftest pathname-version.error.1
+  (signals-error (pathname-version) program-error)
+  t)
+
+(deftest pathname-version.error.2
+  (signals-error (pathname-version *default-pathname-defaults* nil)
+		 program-error)
+  t)
+
+(deftest pathname-version.error.3
+  (check-type-error #'pathname-version #'could-be-pathname-designator)
+  nil)
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/pathname.lsp
@@ -0,0 +1,88 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Nov 29 05:06:57 2003
+;;;; Contains: Tests of the function PATHNAME
+
+(in-package :cl-test)
+
+(deftest pathname.1
+  (loop for x in *pathnames*
+	always (eq x (pathname x)))
+  t)
+
+(deftest pathname.2
+  (equalt #p"ansi-aux.lsp" (pathname "ansi-aux.lsp"))
+  t)
+
+(deftest pathname.3
+  (let ((s (open "ansi-aux.lsp" :direction :input)))
+    (prog1 (equalt (truename (pathname s)) (truename #p"ansi-aux.lsp"))
+      (close s)))
+  t)
+
+(deftest pathname.4
+  (let ((s (open "ansi-aux.lsp" :direction :input)))
+    (close s)
+    (equalt (truename (pathname s)) (truename #p"ansi-aux.lsp")))
+  t)
+
+(deftest pathname.5
+  (loop for x in *logical-pathnames*
+	always (eq x (pathname x)))
+  t)
+
+(deftest pathname.6
+  (equalt #p"ansi-aux.lsp"
+	  (pathname (make-array 12 :initial-contents "ansi-aux.lsp"
+				:element-type 'base-char)))
+  t)
+
+(deftest pathname.7
+  (equalt #p"ansi-aux.lsp"
+	  (pathname (make-array 15 :initial-contents "ansi-aux.lspXXX"
+				:element-type 'base-char
+				:fill-pointer 12)))
+  t)
+
+(deftest pathname.8
+  (equalt #p"ansi-aux.lsp"
+	  (pathname (make-array 12 :initial-contents "ansi-aux.lsp"
+				:element-type 'base-char
+				:adjustable t)))
+  t)
+
+(deftest pathname.9
+  (equalt #p"ansi-aux.lsp"
+	  (pathname (make-array 15 :initial-contents "ansi-aux.lspXXX"
+				:element-type 'character
+				:fill-pointer 12)))
+  t)
+
+(deftest pathname.10
+  (equalt #p"ansi-aux.lsp"
+	  (pathname (make-array 12 :initial-contents "ansi-aux.lsp"
+				:element-type 'character
+				:adjustable t)))
+  t)
+
+(deftest pathname.11
+  (loop for etype in '(standard-char base-char character)
+	collect
+	(equalt #p"ansi-aux.lsp"
+		(pathname
+		 (let* ((s (make-array 15 :initial-contents "XXansi-aux.lspX"
+				       :element-type etype)))
+		   (make-array 12 :element-type etype
+			       :displaced-to s
+			       :displaced-index-offset 2)))))
+  (t t t))
+
+;;; Error tests
+
+(deftest pathname.error.1
+  (signals-error (pathname) program-error)
+  t)
+
+(deftest pathname.error.2
+  (signals-error (pathname (first *pathnames*) nil) program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/pathnamep.lsp
@@ -0,0 +1,31 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Dec  6 10:26:45 2003
+;;;; Contains: Tests of PATHNAMEP
+
+(in-package :cl-test)
+
+(deftest pathnamep.1
+  (check-type-predicate #'pathnamep 'pathname)
+  0)
+
+(deftest pathnamep.2
+  (check-predicate #'(lambda (x) (eql (length (multiple-value-list (pathnamep x))) 1)))
+  nil)
+
+(deftest pathnamep.3
+  (check-predicate (typef '(not logical-pathname)) #'pathnamep)
+  nil)
+
+(deftest pathnamep.error.1
+  (signals-error (pathnamep) program-error)
+  t)
+
+(deftest pathnamep.error.2
+  (signals-error (pathnamep nil nil) program-error)
+  t)
+
+(deftest pathnamep.error.3
+  (signals-error (pathnamep *default-pathname-defaults* nil)
+		 program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/pathnames-aux.lsp
@@ -0,0 +1,25 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Dec  6 15:05:05 2003
+;;;; Contains: Functions associated with pathname tests
+
+(in-package :cl-test)
+
+(defun could-be-pathname-designator (x)
+  (or (stringp x)
+      (pathnamep x)
+      (typep x 'file-stream)
+      (and (typep x 'synonym-stream)
+	   (could-be-pathname-designator
+	    (symbol-value
+	     (synonym-stream-symbol x))))))
+
+(defun explode-pathname (pn)
+  (list
+   :host   (pathname-host pn)
+   :device (pathname-device pn)
+   :directory (pathname-directory pn)
+   :name   (pathname-name pn)
+   :type   (pathname-type pn)
+   :version (pathname-version pn)))
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/pathnames.lsp
@@ -0,0 +1,19 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Nov 29 04:21:53 2003
+;;;; Contains: Various tests on pathnames
+
+(in-package :cl-test)
+
+(deftest pathnames-print-and-read-properly
+  (with-standard-io-syntax
+   (loop
+    for p1 in *pathnames*
+    for s = (handler-case (write-to-string p1 :readably t)
+			  (print-not-readable () :unreadable-error))
+    unless (eql s :unreadable-error)
+    append
+    (let ((p2 (read-from-string s)))
+     (unless (equal p1 p2)
+       (list (list p1 s p2))))))
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/peek-char.lsp
@@ -0,0 +1,329 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Jan 17 21:02:13 2004
+;;;; Contains: Tests of PEEK-CHAR
+
+(in-package :cl-test)
+
+(deftest peek-char.1
+  (with-input-from-string
+   (*standard-input* "abc")
+   (values
+    (peek-char)
+    (read-char)
+    (read-char)
+    (peek-char)
+    (read-char)))
+  #\a #\a #\b #\c #\c)
+
+(deftest peek-char.2
+  (with-input-from-string
+   (*standard-input* "   ab")
+   (values
+    (peek-char)
+    (read-char)
+    (peek-char t)
+    (read-char)
+    (peek-char t)
+    (read-char)))
+  #\Space #\Space #\a #\a #\b #\b)
+
+(deftest peek-char.3
+  (with-input-from-string
+   (*standard-input* (concatenate 'string
+				  (string #\Newline)
+				  (string #\Newline)
+				  "  "
+				  (string #\Newline)
+				  "ab"))
+   (values
+    (peek-char)
+    (read-char)
+    (peek-char t)
+    (read-char)
+    (peek-char t)
+    (read-char)))
+  #\Newline #\Newline #\a #\a #\b #\b)
+
+(when (name-char "Linefeed")
+  (deftest peek-char.4
+    (with-input-from-string
+     (*standard-input* (concatenate 'string
+				    (string (name-char "Linefeed"))
+				    (string (name-char "Linefeed"))
+				    "abc"))
+     (values
+      (peek-char)
+      (read-char)
+      (peek-char t)
+      (read-char)))
+    #.(name-char "Linefeed")
+    #.(name-char "Linefeed")
+    #\a #\a))
+
+(when (name-char "Page")
+  (deftest peek-char.5
+    (with-input-from-string
+     (*standard-input* (concatenate 'string
+				    (string (name-char "Page"))
+				    (string (name-char "Page"))
+				    "abc"))
+     (values
+      (peek-char)
+      (read-char)
+      (peek-char t)
+      (read-char)))
+    #.(name-char "Page")
+    #.(name-char "Page")
+    #\a #\a))
+
+(when (name-char "Tab")
+  (deftest peek-char.6
+    (with-input-from-string
+     (*standard-input* (concatenate 'string
+				    (string (name-char "Tab"))
+				    (string (name-char "Tab"))
+				    "abc"))
+     (values
+      (peek-char)
+      (read-char)
+      (peek-char t)
+      (read-char)))
+    #.(name-char "Tab")
+    #.(name-char "Tab")
+    #\a #\a))
+
+(when (name-char "Return")
+  (deftest peek-char.7
+    (with-input-from-string
+     (*standard-input* (concatenate 'string
+				    (string (name-char "Return"))
+				    (string (name-char "Return"))
+				    "abc"))
+     (values
+      (peek-char)
+      (read-char)
+      (peek-char t)
+      (read-char)))
+    #.(name-char "Return")
+    #.(name-char "Return")
+    #\a #\a))
+
+(deftest peek-char.8
+  (with-input-from-string
+   (s "a bcd")
+   (values
+    (peek-char nil s)
+    (read-char s)
+    (peek-char t s)
+    (read-char s)
+    (peek-char t s)
+    (read-char s)))
+  #\a #\a #\b #\b #\c #\c)
+
+(deftest peek-char.9
+  (with-input-from-string
+   (*standard-input* " a bCcde")
+   (values
+    (peek-char #\c)
+    (read-char)
+    (read-char)))
+  #\c #\c #\d)
+
+(deftest peek-char.10
+  (with-input-from-string
+   (*standard-input* "  ; foo")
+   (values
+    (peek-char t)
+    (read-char)))
+  #\; #\;)
+
+(deftest peek-char.11
+  (with-input-from-string
+   (s "")
+   (peek-char nil s nil))
+  nil)
+
+(deftest peek-char.12
+  (with-input-from-string
+   (s "")
+   (peek-char nil s nil 'foo))
+  foo)
+
+(deftest peek-char.13
+  (with-input-from-string
+   (s "   ")
+   (peek-char t s nil))
+  nil)
+
+(deftest peek-char.14
+  (with-input-from-string
+   (s "   ")
+   (peek-char t s nil 'foo))
+  foo)
+
+(deftest peek-char.15
+  (with-input-from-string
+   (s "ab c d")
+   (peek-char #\z s nil))
+  nil)
+
+(deftest peek-char.16
+  (with-input-from-string
+   (s "ab c d")
+   (peek-char #\z s nil 'foo))
+  foo)
+
+;;; Interaction with echo streams
+
+(deftest peek-char.17
+  (block done
+    (with-input-from-string
+     (is "ab")
+     (with-output-to-string
+       (os)
+       (let ((es (make-echo-stream is os)))
+	 (let ((pos1 (file-position os)))
+	   (unless (zerop pos1) (return-from done :good))
+	   (peek-char nil es nil)
+	   (let ((pos2 (file-position os)))
+	     (return-from done
+	       (if (eql pos1 pos2)
+		   :good
+		 (list pos1 pos2)))))))))
+  :good)
+
+(deftest peek-char.18
+  (block done
+    (with-input-from-string
+     (is "   ab")
+     (with-output-to-string
+       (os)
+       (let ((es (make-echo-stream is os)))
+	 (let ((pos1 (file-position os)))
+	   (unless (zerop pos1) (return-from done :good))
+	   (peek-char t es nil)
+	   (let ((pos2 (file-position os)))
+	     (return-from done
+	       (if (eql pos1 pos2)
+		   pos1
+		 :good))))))))
+  :good)
+
+(deftest peek-char.19
+  (block done
+    (with-input-from-string
+     (is "abcde")
+     (with-output-to-string
+       (os)
+       (let ((es (make-echo-stream is os)))
+	 (let ((pos1 (file-position os)))
+	   (unless (zerop pos1) (return-from done :good))
+	   (peek-char #\c es nil)
+	   (let ((pos2 (file-position os)))
+	     (return-from done
+	       (if (eql pos1 pos2)
+		   pos1
+		 :good))))))))
+  :good)
+
+;;; Interactions with the readtable
+
+(deftest peek-char.20
+  (let ((*readtable* (copy-readtable)))
+    (set-syntax-from-char #\Space #\a)
+    (with-input-from-string
+     (*standard-input* "  x")
+     (values
+      (peek-char)
+      (read-char)
+      (peek-char t)
+      (read-char))))
+  #\Space #\Space
+  #\Space #\Space  ; *not* #\x #\x
+  )
+
+(deftest peek-char.21
+  (let ((*readtable* (copy-readtable)))
+    (set-syntax-from-char #\x #\Space)
+    (with-input-from-string
+     (*standard-input* "xxa")
+     (values
+      (peek-char)
+      (read-char)
+      (peek-char t)
+      (read-char))))
+  #\x #\x
+  #\a #\a  ; *not* #\x #\x
+  )
+
+;;; Stream designators are accepted for the stream argument
+
+(deftest peek-char.22
+  (with-input-from-string
+   (is "!?*")
+   (let ((*terminal-io* (make-two-way-stream is (make-string-output-stream))))
+     (peek-char nil t)))
+  #\!)
+
+(deftest peek-char.23
+  (with-input-from-string
+   (*standard-input* "345")
+   (peek-char nil nil))
+  #\3)
+
+;;; Error tests
+
+(deftest peek-char.error.1
+  (signals-error
+   (with-input-from-string
+    (s "abc")
+    (peek-char s nil nil nil nil 'nonsense))
+   program-error)
+  t)
+
+
+(deftest peek-char.error.2
+  (signals-error-always
+   (with-input-from-string
+    (*standard-input* "")
+    (peek-char))
+   end-of-file)
+  t t)
+
+(deftest peek-char.error.3
+  (signals-error-always
+   (with-input-from-string
+    (s "")
+    (peek-char nil s))
+   end-of-file)
+  t t)
+
+(deftest peek-char.error.4
+  (signals-error-always
+   (with-input-from-string
+    (s " ")
+    (peek-char t s))
+   end-of-file)
+  t t)
+
+(deftest peek-char.error.5
+  (signals-error-always
+   (with-input-from-string
+    (s "abcd")
+    (peek-char #\z s))
+   end-of-file)
+  t t)
+
+;;; There was a consensus on comp.lang.lisp that the requirement
+;;; that an end-of-file error be thrown in the following case
+;;; is a spec bug
+#|
+(deftest peek-char.error.6
+  (signals-error
+   (with-input-from-string
+    (s "")
+    (peek-char nil s nil nil t))
+   end-of-file)
+  t)
+|#
--- /dev/null
+++ gcl-2.6.12/ansi-tests/probe-file.lsp
@@ -0,0 +1,58 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Mon Jan  5 20:46:29 2004
+;;;; Contains: Tests of PROBE-FILE
+
+(in-package :cl-test)
+
+(deftest probe-file.1
+  (probe-file #p"nonexistent")
+  nil)
+
+(deftest probe-file.2
+  (let ((s (open #p"probe-file.lsp" :direction :input)))
+    (prog1
+	(equalpt (truename #p"probe-file.lsp")
+		 (probe-file s))
+      (close s)))
+  t)
+
+(deftest probe-file.3
+  (let ((s (open #p"probe-file.lsp" :direction :input)))
+    (close s)
+    (equalpt (truename #p"probe-file.lsp")
+	     (probe-file s)))
+  t)
+
+(deftest probe-file.4
+  (equalpt (truename #p"probe-file.lsp")
+	   (probe-file "CLTEST:PROBE-FILE.LSP"))
+  t)
+
+;;; Specialized string tests
+
+(deftest probe-file.5
+  (do-special-strings
+   (str "probe-file.lsp" nil)
+   (let ((s (open str :direction :input)))
+     (assert (equalpt (truename #p"probe-file.lsp") (probe-file s)))
+     (close s)))
+  nil)
+       
+;;; Error tests
+
+(deftest probe-file.error.1
+  (signals-error (probe-file) program-error)
+  t)
+
+(deftest probe-file.error.2
+  (signals-error (probe-file #p"probe-file.lsp" nil) program-error)
+  t)
+
+(deftest probe-file.error.3
+  (signals-error-always (probe-file (make-pathname :name :wild)) file-error)
+  t t)
+
+(deftest probe-file.error.4
+  (signals-error-always (probe-file "CLTEST:*.FOO") file-error)
+  t t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/read-byte.lsp
@@ -0,0 +1,194 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Jan 17 17:30:49 2004
+;;;; Contains: Tests of READ-BYTE, WRITE-BYTE
+
+(in-package :cl-test)
+
+(deftest read-byte.1
+  (let ((s (open "foo.txt"
+		 :direction :output
+		 :if-exists :supersede
+		 :element-type '(unsigned-byte 8))))
+    (values
+     (write-byte 17 s)
+     (close s)
+     (progn
+       (setq s (open "foo.txt"
+		     :direction :input
+		     :element-type '(unsigned-byte 8)))
+       (read-byte s))
+     (close s)))
+  17 t 17 t)
+
+(deftest read-byte.2
+  (let ((s (open "foo.txt"
+		 :direction :output
+		 :if-exists :supersede
+		 :element-type '(unsigned-byte 8))))
+    (values
+     (close s)
+     (progn
+        (setq s (open "foo.txt"
+		     :direction :input
+		     :element-type '(unsigned-byte 8)))
+	(read-byte s nil 'foo))
+     (read-byte s nil)
+     (close s)))
+  t foo nil t)
+
+(deftest read-byte.3
+  (loop with b1 = 0
+	and b2 = 0
+	for i from 1 to 32
+	do (let ((s (open "foo.txt"
+			  :direction :output
+			  :if-exists :supersede
+			  :element-type `(unsigned-byte ,i))))
+	     (write-byte (1- (ash 1 i)) s)
+	     (write-byte 1 s)
+	     (close s))
+	unless (let ((s (open "foo.txt"
+			      :direction :input
+			      :element-type `(unsigned-byte ,i))))
+		 (prog1
+		   (and (eql (setq b1 (read-byte s)) (1- (ash 1 i)))
+			(eql (setq b2 (read-byte s)) 1))
+		   (close s)))
+	collect (list i b1 b2))
+  nil)
+
+(deftest read-byte.4
+  (loop with b1 = 0
+	and b2 = 0
+	for i from 33 to 200 by 7
+	do (let ((s (open "foo.txt"
+			  :direction :output
+			  :if-exists :supersede
+			  :element-type `(unsigned-byte ,i))))
+	     (write-byte (1- (ash 1 i)) s)
+	     (write-byte 1 s)
+	     (close s))
+	unless (let ((s (open "foo.txt"
+			      :direction :input
+			      :element-type `(unsigned-byte ,i))))
+		 (prog1
+		     (and (eql (setq b1 (read-byte s)) (1- (ash 1 i)))
+			  (eql (setq b2 (read-byte s)) 1))
+		   (close s)))
+	collect (list i b1 b2))
+  nil)
+
+;;; Error tests
+
+(deftest read-byte.error.1
+  (signals-error (read-byte) program-error)
+  t)
+
+(deftest read-byte.error.2
+  (progn
+    (let ((s (open "foo.txt"
+		   :direction :output
+		   :if-exists :supersede
+		  :element-type `(unsigned-byte 8))))
+      (close s))
+    (signals-error
+     (let ((s (open "foo.txt"
+		   :direction :input
+		   :element-type '(unsigned-byte 8))))
+       (read-byte s))
+     end-of-file))
+  t)
+
+(deftest read-byte.error.3
+  (progn
+    (let ((s (open "foo.txt"
+		   :direction :output
+		   :if-exists :supersede)))
+      (close s))
+    (signals-error
+     (let ((s (open "foo.txt" :direction :input)))
+       (unwind-protect
+	   (read-byte s)
+	 (close s)))
+     error))
+  t)
+
+(deftest read-byte.error.4
+  (signals-error-always
+   (progn
+     (let ((s (open "foo.txt"
+		    :direction :output
+		    :if-exists :supersede
+		    :element-type '(unsigned-byte 8))))
+       (close s))
+     (let ((s (open "foo.txt"
+		    :direction :input
+		    :element-type '(unsigned-byte 8))))
+       (unwind-protect
+	   (read-byte s t)
+	 (close s))))
+   end-of-file)
+  t t)
+
+(deftest read-byte.error.5
+  (check-type-error #'read-byte #'streamp)
+  nil)
+
+(deftest read-byte.error.6
+  (progn
+    (let ((s (open "foo.txt"
+		   :direction :output
+		   :if-exists :supersede
+		  :element-type '(unsigned-byte 8))))
+      (close s))
+    (signals-error
+     (let ((s (open "foo.txt"
+		   :direction :input
+		   :element-type '(unsigned-byte 8))))
+       (unwind-protect
+	   (read-byte s t t nil)
+	 (close s)))
+     program-error))
+  t)
+
+       
+(deftest write-byte.error.1
+  (signals-error (write-byte) program-error)
+  t)
+
+(deftest write-byte.error.2
+  (signals-error (write-byte 0) program-error)
+  t)
+
+(deftest write-byte.error.3
+  (signals-error
+   (let ((s (open "foo.txt"
+		  :direction :output
+		  :if-exists :supersede
+		  :element-type '(unsigned-byte 8))))
+     (unwind-protect
+	 (write 1 s nil)
+       (close s)))
+   program-error)
+  t)
+
+(deftest write-byte.error.4
+  (check-type-error #'(lambda (x) (write-byte 0 x)) #'streamp)
+  nil)
+
+(deftest write-byte.error.5
+   (signals-error
+    (let ((s (open "foo.txt"
+		   :direction :output
+		   :if-exists :supersede)))
+      (unwind-protect
+	  (write 1 s)
+	(close s)))
+    error)
+   t)
+
+
+
+    
+    
--- /dev/null
+++ gcl-2.6.12/ansi-tests/read-char-no-hang.lsp
@@ -0,0 +1,123 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Jan 18 20:32:38 2004
+;;;; Contains: Tests of READ-CHAR-NO-HANG
+
+(in-package :cl-test)
+
+(deftest read-char-no-hang.1
+  (with-input-from-string
+   (*standard-input* "a")
+   (read-char-no-hang))
+  #\a)
+
+(deftest read-char-no-hang.2
+  (with-input-from-string
+   (*standard-input* "abc")
+   (values
+    (read-char-no-hang)
+    (read-char-no-hang)
+    (read-char-no-hang)))
+  #\a #\b #\c)
+
+(when (code-char 0)
+  (deftest read-char-no-hang.3
+    (with-input-from-string
+     (*standard-input* (concatenate 'string
+				    "a"
+				    (string (code-char 0))
+				    "b"))
+     (values
+      (read-char-no-hang)
+      (read-char-no-hang)
+      (read-char-no-hang)))
+    #\a #.(code-char 0) #\b))
+
+(deftest read-char-no-hang.4
+  (with-input-from-string
+   (s "abc")
+   (values
+    (read-char-no-hang s)
+    (read-char-no-hang s)
+    (read-char-no-hang s)))
+  #\a #\b #\c)
+
+(deftest read-char-no-hang.5
+  (with-input-from-string
+   (s "")
+   (read-char-no-hang s nil))
+  nil)
+
+(deftest read-char-no-hang.6
+  (with-input-from-string
+   (s "")
+   (read-char-no-hang s nil 'foo))
+  foo)
+
+(deftest read-char-no-hang.7
+  (with-input-from-string
+   (s "abc")
+   (values
+    (read-char-no-hang s nil nil)
+    (read-char-no-hang s nil nil)
+    (read-char-no-hang s nil nil)))
+  #\a #\b #\c)
+
+(deftest read-char-no-hang.8
+  (with-input-from-string
+   (s "abc")
+   (values
+    (read-char-no-hang s nil t)
+    (read-char-no-hang s nil t)
+    (read-char-no-hang s nil t)))
+  #\a #\b #\c)
+
+(deftest read-char-no-hang.9
+  (with-input-from-string
+   (is "!?*")
+   (let ((*terminal-io* (make-two-way-stream is (make-string-output-stream))))
+     (read-char-no-hang t)))
+  #\!)
+
+(deftest read-char-no-hang.10
+  (with-input-from-string
+   (*standard-input* "345")
+   (read-char-no-hang nil))
+  #\3)
+
+;;; Need a test of the non-hanging.
+;;; This is hard to do portably.
+
+;;; Error tests
+
+(deftest read-char-no-hang.error.1
+  (signals-error
+   (with-input-from-string
+    (s "abc")
+    (read-char-no-hang s nil nil nil nil))
+   program-error)
+  t)
+
+(deftest read-char-no-hang.error.2
+  (signals-error-always
+   (with-input-from-string
+    (s "")
+    (read-char-no-hang s))
+   end-of-file)
+  t t)
+
+(deftest read-char-no-hang.error.3
+  (signals-error-always
+   (with-input-from-string
+    (s "")
+    (read-char-no-hang s t))
+   end-of-file)
+  t t)
+
+(deftest read-char-no-hang.error.4
+  (signals-error-always
+   (with-input-from-string
+    (s "")
+    (read-char-no-hang s t t))
+   end-of-file)
+  t t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/read-char.lsp
@@ -0,0 +1,121 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Jan 18 08:53:56 2004
+;;;; Contains: Tests of READ-CHAR
+
+(in-package :cl-test)
+
+(deftest read-char.1
+  (with-input-from-string
+   (*standard-input* "a")
+   (read-char))
+  #\a)
+
+(deftest read-char.2
+  (with-input-from-string
+   (*standard-input* "abc")
+   (values
+    (read-char)
+    (read-char)
+    (read-char)))
+  #\a #\b #\c)
+
+(when (code-char 0)
+  (deftest read-char.3
+    (with-input-from-string
+     (*standard-input* (concatenate 'string
+				    "a"
+				    (string (code-char 0))
+				    "b"))
+     (values
+      (read-char)
+      (read-char)
+      (read-char)))
+    #\a #.(code-char 0) #\b))
+
+(deftest read-char.4
+  (with-input-from-string
+   (s "abc")
+   (values
+    (read-char s)
+    (read-char s)
+    (read-char s)))
+  #\a #\b #\c)
+
+(deftest read-char.5
+  (with-input-from-string
+   (s "")
+   (read-char s nil))
+  nil)
+
+(deftest read-char.6
+  (with-input-from-string
+   (s "")
+   (read-char s nil 'foo))
+  foo)
+
+(deftest read-char.7
+  (with-input-from-string
+   (s "abc")
+   (values
+    (read-char s nil nil)
+    (read-char s nil nil)
+    (read-char s nil nil)))
+  #\a #\b #\c)
+
+(deftest read-char.8
+  (with-input-from-string
+   (s "abc")
+   (values
+    (read-char s nil t)
+    (read-char s nil t)
+    (read-char s nil t)))
+  #\a #\b #\c)
+
+(deftest read-char.9
+  (with-input-from-string
+   (is "!?*")
+   (let ((*terminal-io* (make-two-way-stream is (make-string-output-stream))))
+     (read-char t)))
+  #\!)
+
+(deftest read-char.10
+  (with-input-from-string
+   (*standard-input* "345")
+   (read-char nil))
+  #\3)
+
+
+;;; Error tests
+
+(deftest read-char.error.1
+  (signals-error
+   (with-input-from-string
+    (s "abc")
+    (read-char s nil nil nil nil))
+   program-error)
+  t)
+
+(deftest read-char.error.2
+  (signals-error-always
+   (with-input-from-string
+    (s "")
+    (read-char s))
+   end-of-file)
+  t t)
+
+(deftest read-char.error.3
+  (signals-error-always
+   (with-input-from-string
+    (s "")
+    (read-char s t))
+   end-of-file)
+  t t)
+
+(deftest read-char.error.4
+  (signals-error-always
+   (with-input-from-string
+    (s "")
+    (read-char s t t))
+   end-of-file)
+  t t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/read-line.lsp
@@ -0,0 +1,104 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Jan 18 20:53:59 2004
+;;;; Contains: Tests of READ-LINE
+
+(in-package :cl-test)
+
+(deftest read-line.1
+  (with-input-from-string
+   (*standard-input* " abcd ")
+   (let ((vals (multiple-value-list (read-line))))
+     (assert (= (length vals) 2))
+     (values (first vals) (notnot (second vals)))))
+  " abcd " t)
+
+(deftest read-line.2
+  (with-input-from-string
+   (*standard-input* (string #\Newline))
+   (read-line))
+  "" nil)
+
+(deftest read-line.3
+  (with-input-from-string
+   (s (concatenate 'string "abc" (string #\Newline)))
+   (read-line s))
+  "abc" nil)
+
+(deftest read-line.4
+  (with-input-from-string
+   (s "")
+   (let ((vals (multiple-value-list (read-line s nil))))
+     (assert (= (length vals) 2))
+     (values (first vals) (notnot (second vals)))))
+  nil t)
+
+(deftest read-line.5
+  (with-input-from-string
+   (s "")
+   (let ((vals (multiple-value-list (read-line s nil 'foo))))
+     (assert (= (length vals) 2))
+     (values (first vals) (notnot (second vals)))))
+  foo t)
+
+(deftest read-line.6
+  (with-input-from-string
+   (s " abcd ")
+   (let ((vals (multiple-value-list (read-line s t nil t))))
+     (assert (= (length vals) 2))
+     (values (first vals) (notnot (second vals)))))
+  " abcd " t)
+
+(deftest read-line.7
+  (with-input-from-string
+   (is "abc")
+   (let ((*terminal-io* (make-two-way-stream is *standard-output*)))
+     (let ((vals (multiple-value-list (read-line t))))
+       (assert (= (length vals) 2))
+       (assert (second vals))
+       (first vals))))
+  "abc")
+
+(deftest read-line.8
+  (with-input-from-string
+   (*standard-input* "abc")
+   (let ((vals (multiple-value-list (read-line nil))))
+     (assert (= (length vals) 2))
+     (assert (second vals))
+     (first vals)))
+  "abc")
+
+;;; Error tests
+
+(deftest read-line.error.1
+  (signals-error
+   (with-input-from-string
+    (s (concatenate 'string "abc" (string #\Newline)))
+    (read-line s t nil nil nil))
+   program-error)
+  t)
+
+(deftest read-line.error.2
+  (signals-error-always
+   (with-input-from-string
+    (s "")
+    (read-line s))
+   end-of-file)
+  t t)
+
+(deftest read-line.error.3
+  (signals-error-always
+   (with-input-from-string
+    (*standard-input* "")
+    (read-line))
+   end-of-file)
+  t t)
+
+(deftest read-line.error.4
+  (signals-error-always
+   (with-input-from-string
+    (s "")
+    (read-line s t))
+   end-of-file)
+  t t)
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/read-sequence.lsp
@@ -0,0 +1,300 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Mon Jan 19 06:55:04 2004
+;;;; Contains: Tests of READ-SEQUENCE
+
+(in-package :cl-test)
+
+;;; Read into a string
+
+(defmacro def-read-sequence-test (name init args input &rest expected)
+  `(deftest ,name
+     (let ((s ,init))
+       (with-input-from-string
+	(is ,input)
+	(values
+	 (read-sequence s is ,@args)
+	 s)))
+     ,@expected))
+
+(def-read-sequence-test read-sequence.string.1 (copy-seq "     ")
+  () "abcdefghijk" 5 "abcde")
+
+(def-read-sequence-test read-sequence.string.2 (copy-seq "     ")
+  () "abc" 3 "abc  ")
+
+(def-read-sequence-test read-sequence.string.3 (copy-seq "     ")
+  (:start 1) "abcdefghijk" 5 " abcd")
+
+(def-read-sequence-test read-sequence.string.4 (copy-seq "     ")
+  (:end 3) "abcdefghijk" 3 "abc  ")
+
+(def-read-sequence-test read-sequence.string.5 (copy-seq "     ")
+  (:start 1 :end 4) "abcdefghijk" 4 " abc ")
+
+(def-read-sequence-test read-sequence.string.6 (copy-seq "     ")
+  (:start 0 :end 0) "abcdefghijk" 0 "     ")
+
+(def-read-sequence-test read-sequence.string.7 (copy-seq "     ")
+  (:end nil) "abcdefghijk" 5 "abcde")
+
+(def-read-sequence-test read-sequence.string.8 (copy-seq "     ")
+  (:allow-other-keys nil) "abcdefghijk" 5 "abcde")
+
+(def-read-sequence-test read-sequence.string.9 (copy-seq "     ")
+  (:allow-other-keys t :foo 'bar) "abcdefghijk" 5 "abcde")
+
+(def-read-sequence-test read-sequence.string.10 (copy-seq "     ")
+  (:foo 'bar :allow-other-keys 'x) "abcdefghijk" 5 "abcde")
+
+(def-read-sequence-test read-sequence.string.11 (copy-seq "     ")
+  (:foo 'bar :allow-other-keys 'x :allow-other-keys nil)
+  "abcdefghijk" 5 "abcde")
+
+(def-read-sequence-test read-sequence.string.12 (copy-seq "     ")
+  (:end 5 :end 3 :start 0 :start 1) "abcdefghijk" 5 "abcde")
+
+;;; Read into a base string
+
+(def-read-sequence-test read-sequence.base-string.1
+  (make-array 5 :element-type 'base-char)
+  () "abcdefghijk" 5 "abcde")
+
+(def-read-sequence-test read-sequence.base-string.2
+  (make-array 5 :element-type 'base-char :initial-element #\Space)
+  () "abc" 3 "abc  ")
+
+(def-read-sequence-test read-sequence.base-string.3
+  (make-array 5 :element-type 'base-char :initial-element #\Space)
+  (:start 1) "abcdefghijk" 5 " abcd")
+
+(def-read-sequence-test read-sequence.base-string.4
+  (make-array 5 :element-type 'base-char :initial-element #\Space)
+  (:end 3) "abcdefghijk" 3 "abc  ")
+
+(def-read-sequence-test read-sequence.base-string.5
+  (make-array 5 :element-type 'base-char :initial-element #\Space)
+  (:start 1 :end 4) "abcdefghijk" 4 " abc ")
+
+(def-read-sequence-test read-sequence.base-string.6
+  (make-array 5 :element-type 'base-char :initial-element #\Space)
+  (:start 0 :end 0) "abcdefghijk" 0 "     ")
+
+(def-read-sequence-test read-sequence.base-string.7
+  (make-array 5 :element-type 'base-char :initial-element #\Space)
+  (:end nil) "abcdefghijk" 5 "abcde")
+
+;;; Read into a list
+
+(def-read-sequence-test read-sequence.list.1 (make-list 5)
+  () "abcdefghijk" 5 (#\a #\b #\c #\d #\e))
+
+(def-read-sequence-test read-sequence.list.2 (make-list 5)
+  () "abc" 3 (#\a #\b #\c nil nil))
+
+(def-read-sequence-test read-sequence.list.3 (make-list 5)
+  (:start 1) "abcdefghijk" 5 (nil #\a #\b #\c #\d))
+
+(def-read-sequence-test read-sequence.list.4 (make-list 5)
+  (:end 3) "abcdefghijk" 3 (#\a #\b #\c nil nil))
+
+(def-read-sequence-test read-sequence.list.5 (make-list 5)
+  (:end 4 :start 1) "abcdefghijk" 4 (nil #\a #\b #\c nil))
+
+(def-read-sequence-test read-sequence.list.6 (make-list 5)
+  (:start 0 :end 0) "abcdefghijk" 0 (nil nil nil nil nil))
+
+(def-read-sequence-test read-sequence.list.7 (make-list 5)
+  (:end nil) "abcdefghijk" 5 (#\a #\b #\c #\d #\e))
+
+;;; Read into a vector
+
+(def-read-sequence-test read-sequence.vector.1
+  (vector nil nil nil nil nil)
+  () "abcdefghijk" 5 #(#\a #\b #\c #\d #\e))
+
+(def-read-sequence-test read-sequence.vector.2
+  (vector nil nil nil nil nil)
+  () "abc" 3 #(#\a #\b #\c nil nil))
+
+(def-read-sequence-test read-sequence.vector.3
+  (vector nil nil nil nil nil)
+  (:start 2) "abcdefghijk" 5 #(nil nil #\a #\b #\c))
+
+(def-read-sequence-test read-sequence.vector.4
+  (vector nil nil nil nil nil)
+  (:start 1 :end 4) "abcdefghijk" 4 #(nil #\a #\b #\c nil))
+
+(def-read-sequence-test read-sequence.vector.5
+  (vector nil nil nil nil nil)
+  (:end 2) "abcdefghijk" 2 #(#\a #\b nil nil nil))
+
+(def-read-sequence-test read-sequence.vector.6
+  (vector nil nil nil nil nil)
+  (:end 0 :start 0) "abcdefghijk" 0 #(nil nil nil nil nil))
+
+(def-read-sequence-test read-sequence.vector.7
+  (vector nil nil nil nil nil)
+  (:end nil) "abcdefghijk" 5 #(#\a #\b #\c #\d #\e))
+
+;;; Read into a vector with a fill pointer
+
+(def-read-sequence-test read-sequence.fill-vector.1
+  (make-array 10 :initial-element nil :fill-pointer 5)
+  () "abcdefghijk" 5 #(#\a #\b #\c #\d #\e))
+
+(def-read-sequence-test read-sequence.fill-vector.2
+  (make-array 10 :initial-element nil :fill-pointer 5)
+  () "ab" 2 #(#\a #\b nil nil nil))
+
+(def-read-sequence-test read-sequence.fill-vector.3
+  (make-array 10 :initial-element nil :fill-pointer 5)
+  () "" 0 #(nil nil nil nil nil))
+
+(def-read-sequence-test read-sequence.fill-vector.4
+  (make-array 10 :initial-element nil :fill-pointer 5)
+  (:start 2) "abcdefghijk" 5 #(nil nil #\a #\b #\c))
+
+(def-read-sequence-test read-sequence.fill-vector.5
+  (make-array 10 :initial-element nil :fill-pointer 5)
+  (:start 1 :end 4) "abcdefghijk" 4 #(nil #\a #\b #\c nil))
+
+(def-read-sequence-test read-sequence.fill-vector.6
+  (make-array 10 :initial-element nil :fill-pointer 5)
+  (:end 2) "abcdefghijk" 2 #(#\a #\b nil nil nil))
+
+(def-read-sequence-test read-sequence.fill-vector.7
+  (make-array 10 :initial-element nil :fill-pointer 5)
+  (:end 0 :start 0) "abcdefghijk" 0 #(nil nil nil nil nil))
+
+(def-read-sequence-test read-sequence.fill-vector.8
+  (make-array 10 :initial-element nil :fill-pointer 5)
+  (:end nil) "abcdefghijk" 5 #(#\a #\b #\c #\d #\e))
+
+;;; Nil vectors
+
+(deftest read-sequence.nil-vector.1
+  :notes (:nil-vectors-are-strings)
+  (let ((s (make-array 0 :element-type nil)))
+    (with-input-from-string
+     (is "abcde")
+     (values
+      (read-sequence s is)
+      s)))
+  0 "")
+
+;;; Read into a bit vector
+
+(defmacro def-read-sequence-bv-test (name init args &rest expected)
+  `(deftest ,name
+     ;; Create output file
+     (progn
+       (let (os)
+	 (unwind-protect
+	     (progn
+	       (setq os (open "temp.dat" :direction :output
+			      :element-type '(unsigned-byte 8)
+			      :if-exists :supersede))
+	       (loop for i in '(0 1 1 0 0 1 1 0 1 0 1 1 1 0)
+		     do (write-byte i os)))
+	   (when os (close os))))
+       (let (is (bv (copy-seq ,init)))
+	 (unwind-protect
+	     (progn
+	       (setq is (open "temp.dat" :direction :input
+			      :element-type '(unsigned-byte 8)))
+	       (values
+		(read-sequence bv is ,@args)
+		bv))
+	   (when is (close is)))))
+     ,@expected))
+     
+(def-read-sequence-bv-test read-sequence.bv.1 #*00000000000000 ()
+  14 #*01100110101110)
+  
+(def-read-sequence-bv-test read-sequence.bv.2 #*00000000000000 (:start 0)
+  14 #*01100110101110)
+  
+(def-read-sequence-bv-test read-sequence.bv.3 #*00000000000000 (:end 14)
+  14 #*01100110101110)
+  
+(def-read-sequence-bv-test read-sequence.bv.4 #*00000000000000 (:end nil)
+  14 #*01100110101110)
+  
+(def-read-sequence-bv-test read-sequence.bv.5 #*00000000000000 (:start 2)
+  14 #*00011001101011)
+  
+(def-read-sequence-bv-test read-sequence.bv.6 #*00000000000000
+  (:start 2 :end 13)
+  13 #*00011001101010)
+
+(def-read-sequence-bv-test read-sequence.bv.7 #*00000000000000 (:end 6)
+  6 #*01100100000000)
+
+;;; Error cases
+
+(deftest read-sequence.error.1
+  (signals-error (read-sequence) program-error)
+  t)
+
+(deftest read-sequence.error.2
+  (signals-error (read-sequence (make-string 10)) program-error)
+  t)
+
+(deftest read-sequence.error.3
+  (signals-error
+   (read-sequence (make-string 5) (make-string-input-stream "abc") :start)
+   program-error)
+  t)
+
+(deftest read-sequence.error.4
+  (signals-error
+   (read-sequence (make-string 5) (make-string-input-stream "abc") :foo 1)
+   program-error)
+  t)
+
+(deftest read-sequence.error.5
+  (signals-error
+   (read-sequence (make-string 5) (make-string-input-stream "abc")
+		  :allow-other-keys nil :bar 2)
+   program-error)
+  t)
+
+(deftest read-sequence.error.6
+  (check-type-error #'(lambda (x) (read-sequence x (make-string-input-stream "abc")))
+		    #'sequencep)
+  nil)
+
+(deftest read-sequence.error.7
+  (signals-error
+   (read-sequence (cons 'a 'b) (make-string-input-stream "abc"))
+   type-error)
+  t)
+
+;;; This test appears to cause Allegro CL to crash
+(deftest read-sequence.error.8
+  (signals-type-error x -1
+		      (read-sequence (make-string 3)
+				     (make-string-input-stream "abc")
+				     :start x))
+  t)
+
+(deftest read-sequence.error.9
+  (check-type-error #'(lambda (s)
+			(read-sequence (make-string 3) (make-string-input-stream "abc")
+				       :start s))
+		    (typef 'unsigned-byte))
+  nil)
+
+(deftest read-sequence.error.10
+  (signals-type-error x -1
+		      (read-sequence (make-string 3) (make-string-input-stream "abc")
+				     :end x))
+  t)
+
+(deftest read-sequence.error.11
+  (check-type-error #'(lambda (e)
+			(read-sequence (make-string 3) (make-string-input-stream "abc")
+				       :end e))
+		    (typef '(or unsigned-byte null)))
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/rename-file.lsp
@@ -0,0 +1,199 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Thu Jan  8 06:22:53 2004
+;;;; Contains: Tests for RENAME-FILE
+
+(in-package :cl-test)
+
+(deftest rename-file.1
+  (let ((pn1 #p"file-to-be-renamed.txt")
+	(pn2 #p"file-that-was-renamed.txt"))
+    (delete-all-versions pn1)
+    (delete-all-versions pn2)
+    (with-open-file (s pn1 :direction :output) (format s "Whatever~%"))
+    (let ((results (multiple-value-list (rename-file pn1 pn2))))
+      (destructuring-bind (defaulted-new-name old-truename new-truename)
+	  results
+	  (values
+	   (=t (length results) 3)
+	   (probe-file pn1)
+	   (notnot (probe-file pn2))
+	   (list (notnot (pathnamep defaulted-new-name))
+		 (notnot (pathnamep old-truename))
+		 (notnot (pathnamep new-truename))
+		 (typep old-truename 'logical-pathname)
+		 (typep new-truename 'logical-pathname))
+	   (notnot (probe-file defaulted-new-name))
+	   (probe-file old-truename)
+	   (notnot (probe-file new-truename))))))
+  t nil t (t t t nil nil) t nil t)
+
+(deftest rename-file.2
+  (let ((pn1 "file-to-be-renamed.txt")
+	(pn2 "file-that-was-renamed.txt"))
+    (delete-all-versions pn1)
+    (delete-all-versions pn2)
+    (with-open-file (s pn1 :direction :output) (format s "Whatever~%"))
+    (let ((results (multiple-value-list (rename-file pn1 pn2))))
+      (destructuring-bind (defaulted-new-name old-truename new-truename)
+	  results
+	  (values
+	   (=t (length results) 3)
+	   (probe-file pn1)
+	   (notnot (probe-file pn2))
+	   (list (notnot (pathnamep defaulted-new-name))
+		 (notnot (pathnamep old-truename))
+		 (notnot (pathnamep new-truename))
+		 (typep old-truename 'logical-pathname)
+		 (typep new-truename 'logical-pathname))
+	   (notnot (probe-file defaulted-new-name))
+	   (probe-file old-truename)
+	   (notnot (probe-file new-truename))))))
+  t nil t (t t t nil nil) t nil t)
+
+ (deftest rename-file.3
+  (let* ((pn1 (make-pathname :name "file-to-be-renamed"
+			     :type "txt"
+			     :version :newest
+			     :defaults *default-pathname-defaults*))
+	 (pn2 (make-pathname :name "file-that-was-renamed"))
+	 (pn3 (make-pathname :name "file-that-was-renamed"
+			     :defaults pn1)))
+    (delete-all-versions pn1)
+    (delete-all-versions pn3)
+    (with-open-file (s pn1 :direction :output) (format s "Whatever~%"))
+    (let ((results (multiple-value-list (rename-file pn1 pn2))))
+      (destructuring-bind (defaulted-new-name old-truename new-truename)
+	  results
+	  (values
+	   (equalpt (pathname-type pn1)
+		    (pathname-type defaulted-new-name))
+	   (=t (length results) 3)
+	   (probe-file pn1)
+	   (notnot (probe-file pn3))
+	   (list (notnot (pathnamep defaulted-new-name))
+		 (notnot (pathnamep old-truename))
+		 (notnot (pathnamep new-truename))
+		 (typep old-truename 'logical-pathname)
+		 (typep new-truename 'logical-pathname))
+	   (notnot (probe-file defaulted-new-name))
+	   (probe-file old-truename)
+	   (notnot (probe-file new-truename))))))
+  t t nil t (t t t nil nil) t nil t)
+
+(deftest rename-file.4
+  (let ((pn1 "file-to-be-renamed.txt")
+	(pn2 "file-that-was-renamed.txt"))
+    (delete-all-versions pn1)
+    (delete-all-versions pn2)
+    (let ((s (open pn1 :direction :output)))
+      (format s "Whatever~%")
+      (close s)
+      (let ((results (multiple-value-list (rename-file s pn2))))
+	(destructuring-bind (defaulted-new-name old-truename new-truename)
+	    results
+	  (values
+	   (=t (length results) 3)
+	   (probe-file pn1)
+	   (notnot (probe-file pn2))
+	   (list (notnot (pathnamep defaulted-new-name))
+		 (notnot (pathnamep old-truename))
+		 (notnot (pathnamep new-truename))
+		 (typep old-truename 'logical-pathname)
+		 (typep new-truename 'logical-pathname))
+	   (notnot (probe-file defaulted-new-name))
+	   (probe-file old-truename)
+	   (notnot (probe-file new-truename)))))))
+  t nil t (t t t nil nil) t nil t)
+
+(deftest rename-file.5
+  (let ((pn1 "CLTEST:FILE-TO-BE-RENAMED.TXT")
+	(pn2 "CLTEST:FILE-THAT-WAS-RENAMED.TXT"))
+    (delete-all-versions pn1)
+    (delete-all-versions pn2)
+    (assert (typep (pathname pn1) 'logical-pathname))
+    (assert (typep (pathname pn2) 'logical-pathname))
+    (with-open-file (s pn1 :direction :output) (format s "Whatever~%"))
+    (let ((results (multiple-value-list (rename-file pn1 pn2))))
+      (destructuring-bind (defaulted-new-name old-truename new-truename)
+	  results
+	  (values
+	   (=t (length results) 3)
+	   (probe-file pn1)
+	   (notnot (probe-file pn2))
+	   (list (notnot (pathnamep defaulted-new-name))
+		 (notnot (pathnamep old-truename))
+		 (notnot (pathnamep new-truename))
+		 (typep old-truename 'logical-pathname)
+		 (typep new-truename 'logical-pathname))
+	   (notnot (probe-file defaulted-new-name))
+	   (probe-file old-truename)
+	   (notnot (probe-file new-truename))
+	   (notnot (typep defaulted-new-name 'logical-pathname))
+	   ))))
+  t nil t (t t t nil nil) t nil t t)
+
+;;; Specialized string tests
+
+(deftest rename-file.6
+  (do-special-strings
+   (s "file-to-be-renamed.txt" nil)
+   (let ((pn1 s)
+	 (pn2 "file-that-was-renamed.txt"))
+     (delete-all-versions pn1)
+     (delete-all-versions pn2)
+     (with-open-file (s pn1 :direction :output) (format s "Whatever~%"))
+     (let ((results (multiple-value-list (rename-file pn1 pn2))))
+       (destructuring-bind (defaulted-new-name old-truename new-truename)
+	   results
+	 (assert
+	  (equal
+	   (list
+	    (=t (length results) 3)
+	    (probe-file pn1)
+	    (notnot (probe-file pn2))
+	    (list (notnot (pathnamep defaulted-new-name))
+		  (notnot (pathnamep old-truename))
+		  (notnot (pathnamep new-truename))
+		  (typep old-truename 'logical-pathname)
+		  (typep new-truename 'logical-pathname))
+	    (notnot (probe-file defaulted-new-name))
+	    (probe-file old-truename)
+	    (notnot (probe-file new-truename)))
+	   '(t nil t (t t t nil nil) t nil t)))))))
+  nil)
+
+(deftest rename-file.7
+  (do-special-strings
+   (s "file-that-was-renamed.txt" nil)
+   (let ((pn1 "file-to-be-renamed.txt")
+	 (pn2 s))
+     (delete-all-versions pn1)
+     (delete-all-versions pn2)
+     (with-open-file (s pn1 :direction :output) (format s "Whatever~%"))
+     (let ((results (multiple-value-list (rename-file pn1 pn2))))
+       (destructuring-bind (defaulted-new-name old-truename new-truename)
+	   results
+	 (assert
+	  (equal
+	   (list
+	    (=t (length results) 3)
+	    (probe-file pn1)
+	    (notnot (probe-file pn2))
+	    (list (notnot (pathnamep defaulted-new-name))
+		  (notnot (pathnamep old-truename))
+		  (notnot (pathnamep new-truename))
+		  (typep old-truename 'logical-pathname)
+		  (typep new-truename 'logical-pathname))
+	    (notnot (probe-file defaulted-new-name))
+	    (probe-file old-truename)
+	    (notnot (probe-file new-truename)))
+	   '(t nil t (t t t nil nil) t nil t)))))))
+  nil)
+
+;;; Error tests
+
+(deftest rename-file.error.1
+  (signals-error (rename-file) program-error)
+  t)
+
--- gcl-2.6.12.orig/ansi-tests/rt.lsp
+++ gcl-2.6.12/ansi-tests/rt.lsp
@@ -21,81 +21,147 @@
  |  SOFTWARE.                                                                 |
  |----------------------------------------------------------------------------|#
 
-;This is the December 19, 1990 version of the regression tester.
+;This was the December 19, 1990 version of the regression tester, but
+;has since been modified.
 
 (in-package :regression-test)
 
+(declaim (ftype (function (t) t) get-entry expanded-eval do-entries))
+(declaim (type list *entries*))
+(declaim (ftype (function (t &rest t) t) report-error))
+(declaim (ftype (function (t &optional t) t) do-entry))
+
 (defvar *test* nil "Current test name")
 (defvar *do-tests-when-defined* nil)
-(defvar *entries* '(nil) "Test database")
+(defvar *entries* (list nil) "Test database.  Has a leading dummy cell that does not contain an entry.")
+(defvar *entries-tail* *entries* "Tail of the *entries* list")
+(defvar *entries-table* (make-hash-table :test #'equal)
+    "Map the names of entries to the cons cell in *entries* that precedes the one whose car is the entry.")
 (defvar *in-test* nil "Used by TEST")
 (defvar *debug* nil "For debugging")
 (defvar *catch-errors* t "When true, causes errors in a test to be caught.")
 (defvar *print-circle-on-failure* nil
   "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
 
-(defvar *compile-tests* nil "When true, compile the tests before running
-them.")
+(defvar *compile-tests* nil "When true, compile the tests before running them.")
+(defvar *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.")
 (defvar *optimization-settings* '((safety 3)))
 
+(defvar *failed-tests* nil "After DO-TESTS, becomes the list of names of tests that have failed")
+(defvar *passed-tests* nil "After DO-TESTS, becomes the list of names of tests that have passed")
+
 (defvar *expected-failures* nil
   "A list of test names that are expected to fail.")
 
-(defstruct (entry (:conc-name nil)
-		  (:type list))
-  pend name form)
-
-(defmacro vals (entry) `(cdddr ,entry))
-
-(defmacro defn (entry) `(cdr ,entry))
+(defvar *notes* (make-hash-table :test 'equal)
+  "A mapping from names of notes to note objects.")
+  
+(defstruct (entry (:conc-name nil))
+  pend name props form vals)
+
+;;; Note objects are used to attach information to tests.
+;;; A typical use is to mark tests that depend on a particular
+;;; part of a set of requirements, or a particular interpretation
+;;; of the requirements.
+
+(defstruct note
+  name  
+  contents
+  disabled ;; When true, tests with this note are considered inactive
+  )
+
+;; (defmacro vals (entry) `(cdddr ,entry))
+
+(defmacro defn (entry)
+  (let ((var (gensym)))
+    `(let ((,var ,entry))
+       (list* (name ,var) (form ,var) (vals ,var)))))
+
+(defun entry-notes (entry)
+  (let* ((props (props entry))
+	 (notes (getf props :notes)))
+    (if (listp notes)
+	notes
+      (list notes))))
+
+(defun has-disabled-note (entry)
+  (let ((notes (entry-notes entry)))
+    (loop for n in notes
+	  for note = (if (note-p n) n
+		       (gethash n *notes*))
+	  thereis (and note (note-disabled note)))))
+
+(defun has-note (entry note)
+  (unless (note-p note)
+    (let ((new-note (gethash note *notes*)))
+      (setf note new-note)))
+  (and note (not (not (member note (entry-notes entry))))))
 
 (defun pending-tests ()
-  (do ((l (cdr *entries*) (cdr l))
-       (r nil))
-      ((null l) (nreverse r))
-    (when (pend (car l))
-      (push (name (car l)) r))))
+  (loop for entry in (cdr *entries*)
+	when (and (pend entry) (not (has-disabled-note entry)))
+	collect (name entry)))
 
 (defun rem-all-tests ()
   (setq *entries* (list nil))
+  (setq *entries-tail* *entries*)
+  (clrhash *entries-table*)
   nil)
 
 (defun rem-test (&optional (name *test*))
-  (do ((l *entries* (cdr l)))
-      ((null (cdr l)) nil)
-    (when (equal (name (cadr l)) name)
-      (setf (cdr l) (cddr l))
-      (return name))))
+  (let ((pred (gethash name *entries-table*)))
+    (when pred
+      (if (null (cddr pred))
+	  (setq *entries-tail* pred)
+	(setf (gethash (name (caddr pred)) *entries-table*) pred))
+      (setf (cdr pred) (cddr pred))
+      (remhash name *entries-table*)
+      name)))
 
 (defun get-test (&optional (name *test*))
   (defn (get-entry name)))
 
 (defun get-entry (name)
-  (let ((entry (find name (cdr *entries*)
-		     :key #'name
-		     :test #'equal)))
+  (let ((entry ;; (find name (the list (cdr *entries*))
+	       ;;     :key #'name :test #'equal)
+	 (cadr (gethash name *entries-table*))
+	 ))
     (when (null entry)
       (report-error t
         "~%No test with name ~:@(~S~)."
 	name))
     entry))
 
-(defmacro deftest (name form &rest values)
-  `(add-entry '(t ,name ,form .,values)))
+(defmacro deftest (name &rest body)
+  (let* ((p body)
+	 (properties
+	  (loop while (keywordp (first p))
+		unless (cadr p)
+		do (error "Poorly formed deftest: ~A~%"
+			  (list* 'deftest name body))
+		append (list (pop p) (pop p))))
+	 (form (pop p))
+	 (vals p))
+    `(add-entry (make-entry :pend t
+			    :name ',name
+			    :props ',properties
+			    :form ',form
+			    :vals ',vals))))
 
 (defun add-entry (entry)
-  (setq entry (copy-list entry))
-  (do ((l *entries* (cdr l))) (nil)
-    (when (null (cdr l))
-      (setf (cdr l) (list entry))
-      (return nil))
-    (when (equal (name (cadr l)) 
-		 (name entry))
-      (setf (cadr l) entry)
+  (setq entry (copy-entry entry))
+  (let* ((pred (gethash (name entry) *entries-table*)))
+    (cond
+     (pred
+      (setf (cadr pred) entry)
       (report-error nil
         "Redefining test ~:@(~S~)"
-        (name entry))
-      (return nil)))
+        (name entry)))
+     (t
+      (setf (gethash (name entry) *entries-table*) *entries-tail*)
+      (setf (cdr *entries-tail*) (cons entry nil))
+      (setf *entries-tail* (cdr *entries-tail*))
+      )))
   (when *do-tests-when-defined*
     (do-entry entry))
   (setq *test* (name entry)))
@@ -105,53 +171,59 @@ them.")
 	 (apply #'format t args)
 	 (if error? (throw '*debug* nil)))
 	(error? (apply #'error args))
-	(t (apply #'warn args))))
+	(t (apply #'warn args)))
+  nil)
 
-(defun do-test (&optional (name *test*))
-  (do-entry (get-entry name)))
+(defun do-test (&optional (name *test*) &rest key-args)
+  (flet ((%parse-key-args
+	  (&key
+	   ((:catch-errors *catch-errors*) *catch-errors*)
+	   ((:compile *compile-tests*) *compile-tests*))
+	  (do-entry (get-entry name))))
+    (apply #'%parse-key-args key-args)))
+
+(defun my-aref (a &rest args)
+  (apply #'aref a args))
+
+(defun my-row-major-aref (a index)
+  (row-major-aref a index))
 
 (defun equalp-with-case (x y)
   "Like EQUALP, but doesn't do case conversion of characters.
    Currently doesn't work on arrays of dimension > 2."
   (cond
+   ((eq x y) t)
    ((consp x)
     (and (consp y)
 	 (equalp-with-case (car x) (car y))
 	 (equalp-with-case (cdr x) (cdr y))))
    ((and (typep x 'array)
 	 (= (array-rank x) 0))
-    (equalp-with-case (aref x) (aref y)))
+    (equalp-with-case (my-aref x) (my-aref y)))
    ((typep x 'vector)
     (and (typep y 'vector)
 	 (let ((x-len (length x))
 	       (y-len (length y)))
 	   (and (eql x-len y-len)
 		(loop
-		 for e1 across x
-		 for e2 across y
+		 for i from 0 below x-len
+		 for e1 = (my-aref x i)
+		 for e2 = (my-aref y i)
 		 always (equalp-with-case e1 e2))))))
    ((and (typep x 'array)
 	 (typep y 'array)
 	 (not (equal (array-dimensions x)
 		     (array-dimensions y))))
     nil)
-   #|
-   ((and (typep x 'array)
-	 (= (array-rank x) 2))
-    (let ((dim (array-dimensions x)))
-      (loop for i from 0 below (first dim)
-	    always (loop for j from 0 below (second dim)
-			 always (equalp-with-case (aref x i j)
-						  (aref y i j))))))
-   |#
 
    ((typep x 'array)
     (and (typep y 'array)
 	 (let ((size (array-total-size x)))
 	   (loop for i from 0 below size
-		 always (equalp-with-case (row-major-aref x i)
-					  (row-major-aref y i))))))
-
+		 always (equalp-with-case (my-row-major-aref x i)
+					  (my-row-major-aref y i))))))
+   ((typep x 'pathname)
+    (equal x y))
    (t (eql x y))))
 
 (defun do-entry (entry &optional
@@ -165,49 +237,110 @@ them.")
 	   r)
       ;; (declare (special *break-on-warnings*))
 
-      (flet ((%do
-	      ()
-	      (setf r
-		    (multiple-value-list
-		     (if *compile-tests*
-			 (funcall (compile
-				   nil
-				   `(lambda ()
-				      (declare
-				       (optimize ,@*optimization-settings*))
-				      ,(form entry))))
-		       (eval (form entry)))))))
-	(block aborted
-	  (if *catch-errors*
-	      (handler-bind (#-ecl (style-warning #'muffle-warning)
-				   (error #'(lambda (c)
-					      (setf aborted t)
-					      (setf r (list c))
-					      (return-from aborted nil))))
-			    (%do))
-	    (%do))))
-      
+      (block aborted
+	(setf r
+	      (flet ((%do ()
+			  (handler-bind
+			   #-sbcl nil
+			   #+sbcl ((sb-ext:code-deletion-note #'(lambda (c)
+								  (if (has-note entry :do-not-muffle)
+								      nil
+								    (muffle-warning c)))))
+			   (cond
+			    (*compile-tests*
+			     (multiple-value-list
+			      (funcall (compile
+					nil
+					`(lambda ()
+					   (declare
+					    (optimize ,@*optimization-settings*))
+					   ,(form entry))))))
+			    (*expanded-eval*
+			     (multiple-value-list
+			      (expanded-eval (form entry))))
+			    (t
+			     (multiple-value-list
+			      (eval (form entry))))))))
+		(if *catch-errors*
+		    (handler-bind
+		     (#-ecl (style-warning #'(lambda (c) (if (has-note entry :do-not-muffle-warnings)
+							     c
+							   (muffle-warning c))))
+			    (error #'(lambda (c)
+				       (setf aborted t)
+				       (setf r (list c))
+				       (return-from aborted nil))))
+		     (%do))
+		  (%do)))))
+
       (setf (pend entry)
 	    (or aborted
 		(not (equalp-with-case r (vals entry)))))
+      
       (when (pend entry)
 	(let ((*print-circle* *print-circle-on-failure*))
-	  (format s "~&Test ~:@(~S~) failed~%Form: ~S~%Expected value~P:~%"
-                  *test* (form entry) (length (vals entry)))
-          (dolist (v (vals entry)) (format s "~10t~S~%" v))
-	  (format s "Actual value~P:~%" (length r))
-	  (dolist (v r)
-	    (format s "~10t~S~:[~; [~2:*~A]~]~%"
-		    v (typep v 'condition)))))))
+	  (format s "~&Test ~:@(~S~) failed~
+                   ~%Form: ~S~
+                   ~%Expected value~P: ~
+                      ~{~S~^~%~17t~}~%"
+		  *test* (form entry)
+		  (length (vals entry))
+		  (vals entry))
+	  (handler-case
+	   (let ((st (format nil "Actual value~P: ~
+                      ~{~S~^~%~15t~}.~%"
+			     (length r) r)))
+	     (format s "~A" st))
+	   (error () (format s "Actual value: #<error during printing>~%")))
+	  (finish-output s)))))
   (when (not (pend entry)) *test*))
 
+(defun expanded-eval (form)
+  "Split off top level of a form and eval separately.  This reduces the chance that
+   compiler optimizations will fold away runtime computation."
+  (if (not (consp form))
+      (eval form)
+   (let ((op (car form)))
+     (cond
+      ((eq op 'let)
+       (let* ((bindings (loop for b in (cadr form)
+			      collect (if (consp b) b (list b nil))))
+	      (vars (mapcar #'car bindings))
+	      (binding-forms (mapcar #'cadr bindings)))
+	 (apply
+	  (the function
+	    (eval `(lambda ,vars ,@(cddr form))))
+	  (mapcar #'eval binding-forms))))
+      ((and (eq op 'let*) (cadr form))
+       (let* ((bindings (loop for b in (cadr form)
+			      collect (if (consp b) b (list b nil))))
+	      (vars (mapcar #'car bindings))
+	      (binding-forms (mapcar #'cadr bindings)))
+	 (funcall
+	  (the function
+	    (eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form))))
+	  (eval (car binding-forms)))))
+      ((eq op 'progn)
+       (loop for e on (cdr form)
+	     do (if (null (cdr e)) (return (eval (car e)))
+		  (eval (car e)))))
+      ((and (symbolp op) (fboundp op)
+	    (not (macro-function op))
+	    (not (special-operator-p op)))
+       (apply (symbol-function op)
+	      (mapcar #'eval (cdr form))))
+      (t (eval form))))))
+
 (defun continue-testing ()
   (if *in-test*
       (throw '*in-test* nil)
       (do-entries *standard-output*)))
 
-(defun do-tests (&optional
-		 (out *standard-output*))
+(defun do-tests (&key (out *standard-output*)
+		      ((:catch-errors *catch-errors*) *catch-errors*)
+		      ((:compile *compile-tests*) *compile-tests*))
+  (setq *failed-tests* nil
+	*passed-tests* nil)
   (dolist (entry (cdr *entries*))
     (setf (pend entry) t))
   (if (streamp out)
@@ -219,13 +352,19 @@ them.")
 (defun do-entries (s)
   (format s "~&Doing ~A pending test~:P ~
              of ~A tests total.~%"
-          (count t (cdr *entries*)
-		 :key #'pend)
+          (count t (the list (cdr *entries*)) :key #'pend)
 	  (length (cdr *entries*)))
+  (finish-output s)
   (dolist (entry (cdr *entries*))
-    (when (pend entry)
-      (format s "~@[~<~%~:; ~:@(~S~)~>~]"
-	      (do-entry entry s))))
+    (when (and (pend entry)
+	       (not (has-disabled-note entry)))
+      (let ((success? (do-entry entry s)))
+	(if success?
+	  (push (name entry) *passed-tests*)
+	  (push (name entry) *failed-tests*))
+	(format s "~@[~<~%~:; ~:@(~S~)~>~]" success?))
+      (finish-output s)
+      ))
   (let ((pending (pending-tests))
 	(expected-table (make-hash-table :test #'equal)))
     (dolist (ex *expected-failures*)
@@ -252,19 +391,46 @@ them.")
                          ~^, ~}~)."
 		    (length new-failures)
 		    new-failures)))
-          (when *expected-failures*
-            (let ((pending-table (make-hash-table :test #'equal)))
-              (dolist (ex pending)
-                (setf (gethash ex pending-table) t))
-              (let ((unexpected-successes
-                     (loop :for ex :in *expected-failures*
-                       :unless (gethash ex pending-table) :collect ex)))
-                (if unexpected-successes
-                    (format t "~&~:D unexpected successes: ~
-                   ~:@(~{~<~%   ~1:;~S~>~
-                         ~^, ~}~)."
-                            (length unexpected-successes)
-                            unexpected-successes)
-                    (format t "~&No unexpected successes.")))))
 	  ))
+      (finish-output s)
       (null pending))))
+
+;;; Note handling functions and macros
+
+(defmacro defnote (name contents &optional disabled)
+  `(eval-when (:load-toplevel :execute)
+     (let ((note (make-note :name ',name
+			    :contents ',contents
+			    :disabled ',disabled)))
+       (setf (gethash (note-name note) *notes*) note)
+       note)))
+
+(defun disable-note (n)
+  (let ((note (if (note-p n) n
+		(setf n (gethash n *notes*)))))
+    (unless note (error "~A is not a note or note name." n))
+    (setf (note-disabled note) t)
+    note))
+
+(defun enable-note (n)
+  (let ((note (if (note-p n) n
+		(setf n (gethash n *notes*)))))
+    (unless note (error "~A is not a note or note name." n))
+    (setf (note-disabled note) nil)
+    note))
+
+;;; Extended random regression
+
+(defun do-extended-tests (&key (tests *passed-tests*) (count nil)
+			       ((:catch-errors *catch-errors*) *catch-errors*)
+			       ((:compile *compile-tests*) *compile-tests*))
+  "Execute randomly chosen tests from TESTS until one fails or until
+   COUNT is an integer and that many tests have been executed."
+  (let ((test-vector (coerce tests 'simple-vector)))
+    (let ((n (length test-vector)))
+      (when (= n 0) (error "Must provide at least one test."))
+      (loop for i from 0
+	    for name = (svref test-vector (random n))
+	    until (eql i count)
+	    do (print name)
+	    unless (do-test name) return (values name (1+ i))))))
--- /dev/null
+++ gcl-2.6.12/ansi-tests/stream-element-type.lsp
@@ -0,0 +1,102 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Jan 13 20:09:50 2004
+;;;; Contains: Tests for STREAM-ELEMENT-TYPE
+
+(in-package :cl-test)
+
+(deftest stream-element-type.1
+  (loop for s in (list *debug-io* *error-output* *query-io*
+		       *standard-input* *standard-output*
+		       *trace-output* *terminal-io*)
+	for results = (multiple-value-list (stream-element-type s))
+	unless (and (eql (length results) 1)
+		    (car results))
+	collect s)
+  nil)
+
+(deftest stream-element-type.2
+  (let ((pn "foo.txt"))
+    (loop for i from 1 to 100
+	  for etype = `(unsigned-byte ,i)
+	  for s = (progn (delete-all-versions pn)
+			 (open pn :direction :output
+			       :element-type etype))
+	  unless
+	  (multiple-value-bind (sub good)
+	      (subtypep etype (stream-element-type s))
+	    (close s)
+	    (or sub (not good)))
+	  collect i))
+  nil)
+
+(deftest stream-element-type.3
+  (let ((pn "foo.txt"))
+    (loop for i from 1 to 100
+	  for etype = `(signed-byte ,i)
+	  for s = (progn (delete-all-versions pn)
+			 (open pn :direction :output
+			       :element-type etype))
+	  unless
+	  (multiple-value-bind (sub good)
+	      (subtypep etype (stream-element-type s))
+	    (close s)
+	    (or sub (not good)))
+	  collect i))
+  nil)
+
+(deftest stream-element-type.4
+  (let ((pn "foo.txt"))
+    (loop for i from 1 to 100
+	  for etype = `(integer 0 ,i)
+	  for s = (progn (delete-all-versions pn)
+			 (open pn :direction :output
+			       :element-type etype))
+	  unless
+	  (multiple-value-bind (sub good)
+	      (subtypep etype (stream-element-type s))
+	    (close s)
+	    (or sub (not good)))
+	  collect i))
+  nil)
+
+
+(deftest stream-element-type.5
+  :notes (:assume-no-simple-streams)
+  (let ((pn "foo.txt"))
+    (delete-all-versions pn)
+    (let ((s (open pn :direction :output)))
+      (let ((etype (stream-element-type s)))
+	(unwind-protect
+	    (equalt (multiple-value-list (subtypep* 'character etype))
+		    '(nil t))
+	  (close s)))))
+  nil)
+
+(deftest stream-element-type.6
+  :notes (:assume-no-simple-streams)
+  (let ((pn "foo.txt"))
+    (delete-all-versions pn)
+    (let ((s (open pn :direction :output
+		   :element-type :default)))
+      (let ((etype (stream-element-type s)))
+	(unwind-protect
+	    (multiple-value-bind (sub1 good1) (subtypep* etype 'integer)
+	      (multiple-value-bind (sub2 good2) (subtypep* etype 'character)
+		(or (not good1)
+		    (not good2)
+		    sub1 sub2)))
+	  (close s)))))
+  t)
+
+(deftest stream-element-type.error.1
+  (signals-error (stream-element-type) program-error)
+  t)
+
+(deftest stream-element-type.error.2
+  (signals-error (stream-element-type *standard-input* nil) program-error)
+  t)
+
+(deftest stream-element-type.error.3
+  (check-type-error #'stream-element-type #'streamp)
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/stream-error-stream.lsp
@@ -0,0 +1,34 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Feb 14 20:51:33 2004
+;;;; Contains: Tests of STREAM-ERROR-STREAM
+
+(in-package :cl-test)
+
+(deftest stream-error-stream.1
+  (with-input-from-string
+   (s "")
+   (handler-case
+    (read-char s)
+    (stream-error (c) (eqlt (stream-error-stream c) s))))
+  t)
+
+;;; Error tests
+
+(deftest stream-error-stream.error.1
+  (signals-error (stream-error-stream) program-error)
+  t)
+
+
+(deftest stream-error-stream.error.2
+  (signals-error
+   (with-input-from-string
+    (s "")
+    (handler-case
+     (read-char s)
+     (stream-error (c) (stream-error-stream c nil))))
+   program-error)
+  t)
+
+
+			  
--- /dev/null
+++ gcl-2.6.12/ansi-tests/stream-external-format.lsp
@@ -0,0 +1,24 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Jan 27 20:53:21 2004
+;;;; Contains: Tests of STREAM-EXTERNAL-FORMAT
+
+(in-package :cl-test)
+
+;;; This is tested in open.lsp
+
+;;; Error tests
+
+(deftest stream-external-format.error.1
+  (signals-error (stream-external-format) program-error)
+  t)
+
+(deftest stream-external-format.error.2
+  (signals-error
+   (let ((pn #p"tmp.dat"))
+     (delete-all-versions pn)
+     (with-open-file
+      (s pn :direction :output :if-exists :supersede)
+      (stream-external-format s nil)))
+   program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/streamp.lsp
@@ -0,0 +1,44 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Jan 17 17:12:38 2004
+;;;; Contains: Tests for STREAMP
+
+(in-package :cl-test)
+
+(deftest streamp.1
+  (loop for s in (list *debug-io* *error-output* *query-io*
+		       *standard-input* *standard-output*
+		       *trace-output* *terminal-io*)
+	unless (equal (multiple-value-list (notnot-mv (streamp s)))
+		      '(t))
+	collect s)
+  nil)
+
+(deftest streamp.2
+  (check-type-predicate #'streamp 'stream)
+  0)
+
+(deftest streamp.3
+  (let ((s (open "foo.txt" :direction :output
+		 :if-exists :supersede)))
+    (close s)
+    (notnot-mv (streamp s)))
+  t)
+
+(deftest streamp.4
+  (let ((s (open "foo.txt" :direction :output
+		 :if-exists :supersede)))
+    (unwind-protect
+	(notnot-mv (streamp s))
+      (close s)))
+  t)
+
+;;; Error tests
+
+(deftest streamp.error.1
+  (signals-error (streamp) program-error)
+  t)
+
+(deftest streamp.error.2
+  (signals-error (streamp *standard-input* nil) program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/synonym-stream-symbol.lsp
@@ -0,0 +1,23 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Thu Jan 29 21:21:06 2004
+;;;; Contains: Tests of SYNONYM-STREAM-SYMBOL
+
+(in-package :cl-test)
+
+(deftest synonym-stream-symbol.1
+  (synonym-stream-symbol (make-synonym-stream '*standard-input*))
+  *standard-input*)
+
+(deftest synonym-stream-symbol.error.1
+  (signals-error (synonym-stream-symbol) program-error)
+  t)
+
+(deftest synonym-stream-symbol.error.2
+  (signals-error (synonym-stream-symbol
+		  (make-synonym-stream '*terminal-io*)
+		  nil)
+		 program-error)
+  t)
+
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/terpri.lsp
@@ -0,0 +1,62 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Jan 18 20:35:57 2004
+;;;; Contains: Tests of TERPRI
+
+(in-package :cl-test)
+
+(deftest terpri.1
+  (let (result)
+    (values
+     (with-output-to-string
+       (*standard-output*)
+       (write-char #\a)
+       (setq result (terpri)))
+     result))
+  #.(concatenate 'string "a" (string #\Newline))
+  nil)
+
+(deftest terpri.2
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (write-char #\a s)
+       (setq result (terpri s)))
+     result))
+  #.(concatenate 'string "a" (string #\Newline))
+  nil)
+
+(deftest terpri.3
+  (with-output-to-string
+    (s)
+    (write-char #\x s)
+    (terpri s)
+    (terpri s)
+    (write-char #\y s))
+  #.(concatenate 'string "x" (string #\Newline) (string #\Newline) "y"))
+
+(deftest terpri.4
+  (with-output-to-string
+    (os)
+    (let ((*terminal-io* (make-two-way-stream *standard-input* os)))
+      (terpri t)
+      (finish-output t)))
+  #.(string #\Newline))
+
+(deftest terpri.5
+  (with-output-to-string
+    (*standard-output*)
+    (terpri nil))
+  #.(string #\Newline))
+
+;;; Error tests
+
+(deftest terpri.error.1
+  (signals-error
+   (with-output-to-string
+     (s)
+     (terpri s nil))
+   program-error)
+  t)
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/translate-logical-pathname.lsp
@@ -0,0 +1,48 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Mon Dec 29 14:45:50 2003
+;;;; Contains: Tests for TRANSLATE-LOGICAL-PATHNAME
+
+(in-package :cl-test)
+
+;; On physical pathnames, t-l-p returns the pathname itself
+
+;;; Every physical pathname is converted to itself
+(deftest translate-logical-pathname.1
+  (loop for p in *pathnames*
+	unless (or (typep p 'logical-pathname)
+		   (eq p (translate-logical-pathname p)))
+	collect p)
+  nil)
+
+;;; &key arguments are allowed
+(deftest translate-logical-pathname.2
+  (loop for p in *pathnames*
+	unless (or (typep p 'logical-pathname)
+		   (eq p (translate-logical-pathname
+			  p :allow-other-keys t)))
+	collect p)
+  nil)
+
+(deftest translate-logical-pathname.3
+  (loop for p in *pathnames*
+	unless (or (typep p 'logical-pathname)
+		   (eq p (translate-logical-pathname
+			  p :allow-other-keys nil)))
+	collect p)
+  nil)
+
+(deftest translate-logical-pathname.4
+  (loop for p in *pathnames*
+	unless (or (typep p 'logical-pathname)
+		   (eq p (translate-logical-pathname
+			  p :foo 1 :allow-other-keys t :bar 2)))
+	collect p)
+  nil)
+
+
+;;; errors
+
+(deftest translate-logical-pathname.error.1
+  (signals-error (translate-logical-pathname) program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/translate-pathname.lsp
@@ -0,0 +1,50 @@
+;-*- Mode:     Lisp -*-
+
+(in-package :cl-test)
+
+(deftest translate-pathname.1 (translate-pathname "foobar" "foobar" "foobar") #P"foobar")
+(deftest translate-pathname.2 (translate-pathname "foobar" "foobar" "foo*")   #P"foo")
+(deftest translate-pathname.3 (translate-pathname "foobar" "foobar" "*")      #P"foobar")
+(deftest translate-pathname.4 (translate-pathname "foobar" "foobar" "")       #P"foobar")
+
+(deftest translate-pathname.5 (translate-pathname "foobar" "foo*r"  "foobar") #P"foobar")
+(deftest translate-pathname.6 (translate-pathname "foobar" "foo*r"  "foo*")   #P"fooba")
+(deftest translate-pathname.7 (translate-pathname "foobar" "foo*r"  "*")      #P"foobar")
+(deftest translate-pathname.8 (translate-pathname "foobar" "foo*r"  "")       #P"foobar")
+
+(deftest translate-pathname.9  (translate-pathname "foobar" "*"  "foobar") #P"foobar")
+(deftest translate-pathname.10 (translate-pathname "foobar" "*"  "foo*")   #P"foofoobar")
+(deftest translate-pathname.11 (translate-pathname "foobar" "*"  "*")      #P"foobar")
+(deftest translate-pathname.12 (translate-pathname "foobar" "*"  "")       #P"foobar")
+
+(deftest translate-pathname.13 (translate-pathname "foobar" ""  "foobar") #P"foobar")
+(deftest translate-pathname.14 (translate-pathname "foobar" ""  "foo*")   #P"foofoobar")
+(deftest translate-pathname.15 (translate-pathname "foobar" ""  "*")      #P"foobar")
+(deftest translate-pathname.16 (translate-pathname "foobar" ""  "")       #P"foobar")
+
+(deftest translate-pathname.17 (translate-pathname "/a/bbfb/c/d/" "/a/bbfb/c/d/" "/a/qc/c/d/")   #P"/a/qc/c/d/")
+(deftest translate-pathname.18 (translate-pathname "/a/bbfb/c/d/" "/a/bbfb/c/d/" "/a/q*c*/c/d/") #P"/a/qc/c/d/")
+(deftest translate-pathname.19 (translate-pathname "/a/bbfb/c/d/" "/a/bbfb/c/d/" "/a/*/c/d/")    #P"/a/c/d/")
+(deftest translate-pathname.20 (translate-pathname "/a/bbfb/c/d/" "/a/bbfb/c/d/" "/a/**/d/")     #P"/a/d/")
+
+(deftest translate-pathname.21 (translate-pathname "/a/bbfb/c/d/" "/a/b*f*/c/d/" "/a/qc/c/d/")   #P"/a/qc/c/d/")
+(deftest translate-pathname.22 (translate-pathname "/a/bbfb/c/d/" "/a/b*f*/c/d/" "/a/q*c*/c/d/") #P"/a/qbcb/c/d/")
+(deftest translate-pathname.23 (translate-pathname "/a/bbfb/c/d/" "/a/b*f*/c/d/" "/a/*/c/d/")    #P"/a/bbfb/c/d/")
+(deftest translate-pathname.24 (translate-pathname "/a/bbfb/c/d/" "/a/b*f*/c/d/" "/a/**/d/")     #P"/a/bbfb/d/")
+
+(deftest translate-pathname.25 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "/a/qc/c/d/")   #P"/a/qc/c/d/")
+(deftest translate-pathname.26 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "/a/q*c*/c/d/") #P"/a/qc/c/d/")
+(deftest translate-pathname.27 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "/a/*/d/")      #P"/a/bbfb/d/")
+(deftest translate-pathname.28 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "/a/**/d/")     #P"/a/bbfb/c/d/")
+
+(deftest translate-pathname.29 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "a/qc/c/d/")    #P"a/qc/c/d/")
+(deftest translate-pathname.30 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "a/q*c*/c/d/")  #P"a/qc/c/d/")
+(deftest translate-pathname.31 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "a/*/d/")       #P"a/bbfb/d/")
+(deftest translate-pathname.32 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "a/**/d/")      #P"a/bbfb/c/d/")
+
+(deftest translate-pathname.33 (translate-pathname "/a/bbfb/c/d/" "/a/bbfb/c/d/" "a")        #P"/a/bbfb/c/d/a")
+(deftest translate-pathname.34 (translate-pathname "/a/bbfb/c/d/" "/a/b*f*/c/d/" "a")        #P"/a/bbfb/c/d/a")
+(deftest translate-pathname.35 (translate-pathname "/a/bbfb/c/d/" "/a/*/c/d/"    "a")        #P"/a/bbfb/c/d/a")
+(deftest translate-pathname.36 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/"     "a")        #P"/a/bbfb/c/d/a")
+
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/truename.lsp
@@ -0,0 +1,108 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Jan  6 05:32:37 2004
+;;;; Contains: Tests of TRUENAME
+
+(in-package :cl-test)
+
+(deftest truename.1
+  (let* ((pn #p"truename.lsp")
+	 (tn (truename pn)))
+    (values
+     (notnot (pathnamep pn))
+     (typep pn 'logical-pathname)
+     (equalt (pathname-name pn) (pathname-name tn))
+     (equalt (pathname-type pn) (pathname-type tn))
+     ))
+  t nil t t)
+
+(deftest truename.2
+  (let* ((name "truename.lsp")
+	 (pn (pathname name))
+	 (tn (truename name)))
+    (values
+     (notnot (pathnamep pn))
+     (typep pn 'logical-pathname)
+     (equalt (pathname-name pn) (pathname-name tn))
+     (equalt (pathname-type pn) (pathname-type tn))
+     ))
+  t nil t t)
+
+(deftest truename.3
+  (let* ((pn #p"truename.lsp"))
+    (with-open-file
+     (s pn :direction :input)
+     (let ((tn (truename s)))
+       (values
+	(notnot (pathnamep pn))
+	(typep pn 'logical-pathname)
+	(equalt (pathname-name pn) (pathname-name tn))
+	(equalt (pathname-type pn) (pathname-type tn))
+	))))
+  t nil t t)
+
+(deftest truename.4
+  (let* ((pn #p"truename.lsp"))
+    (let ((s (open pn :direction :input)))
+      (close s)
+      (let ((tn (truename s)))
+	(values
+	 (notnot (pathnamep pn))
+	 (typep pn 'logical-pathname)
+	 (equalt (pathname-name pn) (pathname-name tn))
+	 (equalt (pathname-type pn) (pathname-type tn))
+	 ))))
+  t nil t t)
+
+(deftest truename.5
+  (let* ((lpn "CLTEST:foo.txt")
+	 (pn (translate-logical-pathname lpn)))
+    (unless (probe-file lpn)
+      (with-open-file (s lpn :direction :output) (format s "Stuff~%")))
+    (let ((tn (truename lpn)))
+      (values
+       (notnot (pathnamep pn))
+       (if (equalt (pathname-name pn) (pathname-name tn))
+	   t (list (pathname-name pn) (pathname-name tn)))
+       (if (equalt (pathname-type pn) (pathname-type tn))
+	   t (list (pathname-type pn) (pathname-type tn)))
+       )))
+  t t t)
+
+;;; Specialized string tests
+
+(deftest truename.6
+  (do-special-strings
+   (s "truename.lsp" nil)
+   (assert (equalp (truename s) (truename "truename.lsp"))))
+  nil)
+
+;;; Error tests
+
+(deftest truename.error.1
+  (signals-error (truename) program-error)
+  t)
+
+(deftest truename.error.2
+  (signals-error (truename "truename.lsp" nil) program-error)
+  t)
+
+(deftest truename.error.3
+  (signals-error-always (truename "nonexistent") file-error)
+  t t)
+
+(deftest truename.error.4
+  (signals-error-always (truename #p"nonexistent") file-error)
+  t t)
+
+(deftest truename.error.5
+  (signals-error-always (truename (logical-pathname "CLTESTROOT:NONEXISTENT")) file-error)
+  t t)
+
+(deftest truename.error.6
+  (signals-error-always
+   (let ((pn (make-pathname :name :wild
+			    :defaults *default-pathname-defaults*)))
+     (truename pn))
+   file-error)
+  t t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/two-way-stream-input-stream.lsp
@@ -0,0 +1,26 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Thu Feb 12 04:22:50 2004
+;;;; Contains: Tests of TWO-WAY-STREAM-INPUT-STREAM
+
+(in-package :cl-test)
+
+(deftest two-way-stream-input-stream.1
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-two-way-stream is os)))
+    (equalt (multiple-value-list (two-way-stream-input-stream s))
+	    (list is)))
+  t)
+
+(deftest two-way-stream-input-stream.error.1
+  (signals-error (two-way-stream-input-stream) program-error)
+  t)
+
+(deftest two-way-stream-input-stream.error.2
+  (signals-error (let* ((is (make-string-input-stream "foo"))
+			(os (make-string-output-stream))
+			(s (make-two-way-stream is os)))
+		   (two-way-stream-input-stream s nil))
+		 program-error)
+  t)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/two-way-stream-output-stream.lsp
@@ -0,0 +1,26 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Thu Feb 12 04:25:59 2004
+;;;; Contains: Tests off TWO-WAY-STREAM-OUTPUT-STREAM
+
+(in-package :cl-test)
+
+(deftest two-way-stream-output-stream.1
+  (let* ((is (make-string-input-stream "foo"))
+	 (os (make-string-output-stream))
+	 (s (make-two-way-stream is os)))
+    (equalt (multiple-value-list (two-way-stream-output-stream s))
+	    (list os)))
+  t)
+
+(deftest two-way-stream-output-stream.error.1
+  (signals-error (two-way-stream-output-stream) program-error)
+  t)
+
+(deftest two-way-stream-output-stream.error.2
+  (signals-error (let* ((is (make-string-input-stream "foo"))
+			(os (make-string-output-stream))
+			(s (make-two-way-stream is os)))
+		   (two-way-stream-output-stream s nil))
+		 program-error)
+  t)
--- gcl-2.6.12.orig/ansi-tests/universe.lsp
+++ gcl-2.6.12/ansi-tests/universe.lsp
@@ -307,15 +307,50 @@
      #-(or GCL CMU ECL) (make-hash-table :test #'equalp)
      ))
 
-(defvar *pathnames*
-    (list
-     (make-pathname :name "foo")
-     (make-pathname :name "bar")
-     (make-pathname :name "foo" :type "txt")
-     (make-pathname :name "bar" :type "txt")
-     (make-pathname :name :wild)
-     (make-pathname :name :wild :type "txt")
-     ))
+(defparameter *pathnames*
+  (locally
+   (declare (optimize safety))
+   (loop for form in '((make-pathname :name "foo")
+		       (make-pathname :name "FOO" :case :common)
+		       (make-pathname :name "bar")
+		       (make-pathname :name "foo" :type "txt")
+		       (make-pathname :name "bar" :type "txt")
+		       (make-pathname :name "XYZ" :type "TXT" :case :common)
+		       (make-pathname :name nil)
+		       (make-pathname :name :wild)
+		       (make-pathname :name nil :type "txt")
+		       (make-pathname :name :wild :type "txt")
+		       (make-pathname :name :wild :type "TXT" :case :common)
+		       (make-pathname :name :wild :type "abc" :case :common)
+		       (make-pathname :directory :wild)
+		       (make-pathname :type :wild)
+		       (make-pathname :version :wild)
+		       (make-pathname :version :newest))
+	 append (ignore-errors (eval `(list ,form))))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (locally
+   (declare (optimize safety))
+   (ignore-errors
+     (setf (logical-pathname-translations "CLTESTROOT")
+	   `(("**;*.*.*" ,(make-pathname :directory '(:absolute :wild-inferiors)
+					 :name :wild :type :wild)))))
+   (ignore-errors
+     (setf (logical-pathname-translations "CLTEST")
+	   `(("**;*.*.*" ,(make-pathname
+			   :directory (append
+				       (pathname-directory
+					(truename (make-pathname)))
+				       '(:wild-inferiors))
+			   :name :wild :type :wild)))))
+   ))
+
+(defparameter *logical-pathnames*
+  (locally
+   (declare (optimize safety))
+   (append
+    (ignore-errors (list (logical-pathname "CLTESTROOT:")))
+    )))
 
 (defvar *streams*
     (remove-duplicates
--- /dev/null
+++ gcl-2.6.12/ansi-tests/unread-char.lsp
@@ -0,0 +1,92 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Jan 18 20:05:36 2004
+;;;; Contains: Tests of UNREAD-CHAR
+
+(in-package :cl-test)
+
+(deftest unread-char.1
+  (with-input-from-string
+   (*standard-input* "abc")
+   (values
+    (read-char)
+    (unread-char #\a)
+    (read-char)
+    (read-char)
+    (unread-char #\b)
+    (read-char)
+    (read-char)))
+  #\a nil #\a #\b nil #\b #\c)
+
+(deftest unread-char.2
+  (with-input-from-string
+   (s "abc")
+   (values
+    (read-char s)
+    (unread-char #\a s)
+    (read-char s)
+    (read-char s)
+    (unread-char #\b s)
+    (read-char s)
+    (read-char s)))
+  #\a nil #\a #\b nil #\b #\c)
+
+(deftest unread-char.3
+  (with-input-from-string
+   (is "abc")
+   (with-output-to-string
+     (os)
+     (let ((s (make-echo-stream is os)))
+       (read-char s)
+       (unread-char #\a s)
+       (read-char s)
+       (read-char s)
+       (read-char s)
+       (unread-char #\c s)
+       (read-char s))))
+  "abc")
+
+(deftest unread-char.4
+  (with-input-from-string
+   (*standard-input* "abc")
+   (values
+    (read-char)
+    (unread-char #\a nil)
+    (read-char)
+    (read-char)
+    (unread-char #\b nil)
+    (read-char)
+    (read-char)))
+  #\a nil #\a #\b nil #\b #\c)
+
+(deftest unread-char.5
+  (with-input-from-string
+   (is "abc")
+   (let ((*terminal-io* (make-two-way-stream
+			 is (make-string-output-stream))))
+     (values
+      (read-char t)
+      (unread-char #\a t)
+      (read-char t)
+      (read-char t)
+      (unread-char #\b t)
+      (read-char t)
+      (read-char t))))
+  #\a nil #\a #\b nil #\b #\c)
+
+;;; Error tests
+
+(deftest unread-char.error.1
+  (signals-error (unread-char) program-error)
+  t)
+
+(deftest unread-char.error.2
+  (signals-error
+   (with-input-from-string
+    (s "abc")
+    (read-char s)
+    (unread-char #\a s nil))
+   program-error)
+  t)
+
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/wild-pathname-p.lsp
@@ -0,0 +1,234 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Wed Dec 31 16:54:55 2003
+;;;; Contains: Tests of WILD-PATHNAME-P
+
+(in-package :cl-test)
+
+(compile-and-load "pathnames-aux.lsp")
+
+(deftest wild-pathname-p.1
+  (wild-pathname-p (make-pathname))
+  nil)
+
+(deftest wild-pathname-p.2
+  (loop for key in '(:host :device :directory :name :type :version nil)
+	when (wild-pathname-p (make-pathname) key)
+	collect key)
+  nil)
+
+(deftest wild-pathname-p.3
+  (let ((p (make-pathname :directory :wild)))
+    (notnot-mv (wild-pathname-p p)))
+  t)
+
+(deftest wild-pathname-p.4
+  (let ((p (make-pathname :directory :wild)))
+    (notnot-mv (wild-pathname-p p nil)))
+  t)
+
+(deftest wild-pathname-p.5
+  (let ((p (make-pathname :directory :wild)))
+    (notnot-mv (wild-pathname-p p :directory)))
+  t)
+
+(deftest wild-pathname-p.6
+  (let ((p (make-pathname :directory :wild)))
+    (loop for key in '(:host :device :name :type :version)
+	when (wild-pathname-p p key)
+	collect key))
+  nil)
+
+
+(deftest wild-pathname-p.7
+  (let ((p (make-pathname :directory '(:absolute :wild))))
+    (notnot-mv (wild-pathname-p p)))
+  t)
+
+(deftest wild-pathname-p.8
+  (let ((p (make-pathname :directory '(:absolute :wild))))
+    (notnot-mv (wild-pathname-p p nil)))
+  t)
+
+(deftest wild-pathname-p.9
+  (let ((p (make-pathname :directory '(:absolute :wild))))
+    (notnot-mv (wild-pathname-p p :directory)))
+  t)
+
+(deftest wild-pathname-p.10
+  (let ((p (make-pathname :directory '(:absolute :wild))))
+    (loop for key in '(:host :device :name :type :version)
+	when (wild-pathname-p p key)
+	collect key))
+  nil)
+
+
+(deftest wild-pathname-p.11
+  (let ((p (make-pathname :directory '(:relative :wild))))
+    (notnot-mv (wild-pathname-p p)))
+  t)
+
+(deftest wild-pathname-p.12
+  (let ((p (make-pathname :directory '(:relative :wild))))
+    (notnot-mv (wild-pathname-p p nil)))
+  t)
+
+(deftest wild-pathname-p.13
+  (let ((p (make-pathname :directory '(:relative :wild))))
+    (notnot-mv (wild-pathname-p p :directory)))
+  t)
+
+(deftest wild-pathname-p.14
+  (let ((p (make-pathname :directory '(:relative :wild))))
+    (loop for key in '(:host :device :name :type :version)
+	when (wild-pathname-p p key)
+	collect key))
+  nil)
+
+;;;
+
+(deftest wild-pathname-p.15
+  (let ((p (make-pathname :name :wild)))
+    (notnot-mv (wild-pathname-p p)))
+  t)
+
+(deftest wild-pathname-p.16
+  (let ((p (make-pathname :name :wild)))
+    (notnot-mv (wild-pathname-p p nil)))
+  t)
+
+(deftest wild-pathname-p.17
+  (let ((p (make-pathname :name :wild)))
+    (notnot-mv (wild-pathname-p p :name)))
+  t)
+
+(deftest wild-pathname-p.18
+  (let ((p (make-pathname :name :wild)))
+    (loop for key in '(:host :device :directory :type :version)
+	when (wild-pathname-p p key)
+	collect key))
+  nil)
+
+;;;    
+  
+(deftest wild-pathname-p.19
+  (let ((p (make-pathname :type :wild)))
+    (notnot-mv (wild-pathname-p p)))
+  t)
+
+(deftest wild-pathname-p.20
+  (let ((p (make-pathname :type :wild)))
+    (notnot-mv (wild-pathname-p p nil)))
+  t)
+
+(deftest wild-pathname-p.21
+  (let ((p (make-pathname :type :wild)))
+    (notnot-mv (wild-pathname-p p :type)))
+  t)
+
+(deftest wild-pathname-p.22
+  (let ((p (make-pathname :type :wild)))
+    (loop for key in '(:host :device :directory :name :version)
+	when (wild-pathname-p p key)
+	collect key))
+  nil)
+
+;;;
+
+ (deftest wild-pathname-p.23
+  (let ((p (make-pathname :version :wild)))
+    (notnot-mv (wild-pathname-p p)))
+  t)
+
+(deftest wild-pathname-p.24
+  (let ((p (make-pathname :version :wild)))
+    (notnot-mv (wild-pathname-p p nil)))
+  t)
+
+(deftest wild-pathname-p.25
+  (let ((p (make-pathname :version :wild)))
+    (notnot-mv (wild-pathname-p p :version)))
+  t)
+
+(deftest wild-pathname-p.26
+  (let ((p (make-pathname :version :wild)))
+    (loop for key in '(:host :device :directory :name :type)
+	when (wild-pathname-p p key)
+	collect key))
+  nil)
+
+;;;
+
+(deftest wild-pathname-p.27
+  (loop for p in (append *pathnames* *logical-pathnames*)
+	unless (if (wild-pathname-p p) (wild-pathname-p p nil)
+		 (not (wild-pathname-p p nil)))
+	collect p)
+  nil)
+
+(deftest wild-pathname-p.28
+  (loop for p in (append *pathnames* *logical-pathnames*)
+	when (and (loop for key in '(:host :device :directory
+					   :name :type :version)
+			thereis (wild-pathname-p p key))
+		  (not (wild-pathname-p p)))
+	collect p)
+  nil)
+
+;;; On streams associated with files
+
+(deftest wild-pathname-p.29
+  (with-open-file (s "foo.lsp"
+		     :direction :output
+		     :if-exists :append
+		     :if-does-not-exist :create)
+		  (wild-pathname-p s))
+  nil)
+
+(deftest wild-pathname-p.30
+  (let ((s (open "foo.lsp"
+		 :direction :output
+		 :if-exists :append
+		 :if-does-not-exist :create)))
+    (close s)
+    (wild-pathname-p s))
+  nil)
+
+;;; logical pathname designators
+
+(deftest wild-pathname-p.31
+  (wild-pathname-p "CLTEST:FOO.LISP")
+  nil)
+
+;;; Odd strings
+
+(deftest wild-pathname-p.32
+  (do-special-strings
+   (s "CLTEST:FOO.LISP" nil)
+   (let ((vals (multiple-value-list (wild-pathname-p s))))
+     (assert (equal vals '(nil)))))
+  nil)
+
+;;;
+
+(deftest wild-pathname-p.error.1
+  (signals-error (wild-pathname-p) program-error)
+  t)
+
+(deftest wild-pathname-p.error.2
+  (signals-error (wild-pathname-p *default-pathname-defaults* nil nil)
+		 program-error)
+  t)
+
+(deftest wild-pathname-p.error.3
+  (check-type-error #'wild-pathname-p
+		    (typef '(or pathname string file-stream
+				synonym-stream)))
+  nil)
+
+(deftest wild-pathname-p.error.4
+  (check-type-error #'(lambda (x) (declare (optimize (safety 0)))
+			(wild-pathname-p x))
+		    (typef '(or pathname string file-stream
+				synonym-stream)))
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/with-input-from-string.lsp
@@ -0,0 +1,245 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Feb 14 20:13:02 2004
+;;;; Contains: Tests of WITH-INPUT-FROM-STRING
+
+(in-package :cl-test)
+
+(deftest with-input-from-string.1
+  (with-input-from-string
+   (s "abc")
+   (values (read-char s) (read-char s) (read-char s) (read-char s nil :eof)))
+  #\a #\b #\c :eof)
+
+(deftest with-input-from-string.2
+  (with-input-from-string (s "abc"))
+  nil)
+
+(deftest with-input-from-string.3
+  (with-input-from-string (s "abc") (declare (optimize speed)))
+  nil)
+
+(deftest with-input-from-string.3a
+  (with-input-from-string (s "abc")
+			  (declare (optimize speed))
+			  (declare (optimize space)))
+  nil)
+
+(deftest with-input-from-string.4
+  (with-input-from-string
+   (s "abc")
+   (declare (optimize safety))
+   (read-char s)
+   (read-char s))
+  #\b)
+
+(deftest with-input-from-string.5
+  (let ((i nil))
+    (values
+     (with-input-from-string
+      (s "abc" :index i))
+     i))
+  nil 0)
+
+(deftest with-input-from-string.6
+  (let ((i (list nil)))
+    (values
+     (with-input-from-string
+      (s "abc" :index (car i)))
+     i))
+  nil (0))
+
+(deftest with-input-from-string.7
+  (let ((i nil))
+    (values
+     (with-input-from-string
+      (s "abc" :index i)
+      (list i (read-char s) i (read-char s) i))
+     i))
+  (nil #\a nil #\b nil) 2)
+
+(deftest with-input-from-string.9
+  (with-input-from-string
+   (s "abc")
+   (values
+    (notnot (typep s 'stream))
+    (notnot (typep s 'string-stream))
+    (notnot (open-stream-p s))
+    (notnot (input-stream-p s))
+    (output-stream-p s)))
+  t t t t nil)
+
+(deftest with-input-from-string.10
+  :notes (:nil-vectors-are-strings)
+  (with-input-from-string
+   (s (make-array 0 :element-type nil))
+   (values
+    (notnot (typep s 'stream))
+    (notnot (typep s 'string-stream))
+    (notnot (open-stream-p s))
+    (notnot (input-stream-p s))
+    (output-stream-p s)))
+  t t t t nil)
+
+(deftest with-input-from-string.11
+  (with-input-from-string
+   (s (make-array 3 :element-type 'character :initial-contents "abc"))
+   (values
+    (notnot (typep s 'stream))
+    (notnot (typep s 'string-stream))
+    (notnot (open-stream-p s))
+    (notnot (input-stream-p s))
+    (output-stream-p s)
+    (read-line s)))
+  t t t t nil "abc")
+
+(deftest with-input-from-string.12
+  (with-input-from-string
+   (s (make-array 3 :element-type 'base-char :initial-contents "abc"))
+   (values
+    (notnot (typep s 'stream))
+    (notnot (typep s 'string-stream))
+    (notnot (open-stream-p s))
+    (notnot (input-stream-p s))
+    (output-stream-p s)
+    (read-line s)))
+  t t t t nil "abc")
+
+(deftest with-input-from-string.13
+  (with-input-from-string
+   (s "abcdef" :start 2)
+   (values
+    (notnot (typep s 'stream))
+    (notnot (typep s 'string-stream))
+    (notnot (open-stream-p s))
+    (notnot (input-stream-p s))
+    (output-stream-p s)
+    (read-line s)))
+  t t t t nil "cdef")
+
+(deftest with-input-from-string.14
+  (with-input-from-string
+   (s "abcdef" :end 3)
+   (values
+    (notnot (typep s 'stream))
+    (notnot (typep s 'string-stream))
+    (notnot (open-stream-p s))
+    (notnot (input-stream-p s))
+    (output-stream-p s)
+    (read-line s)))
+  t t t t nil "abc")
+
+(deftest with-input-from-string.15
+  (with-input-from-string
+   (s "abcdef" :start 1 :end 5)
+   (values
+    (notnot (typep s 'stream))
+    (notnot (typep s 'string-stream))
+    (notnot (open-stream-p s))
+    (notnot (input-stream-p s))
+    (output-stream-p s)
+    (read-line s)))
+  t t t t nil "bcde")
+
+(deftest with-input-from-string.16
+  (with-input-from-string
+   (s "abcdef" :start 1 :end nil)
+   (values
+    (notnot (typep s 'stream))
+    (notnot (typep s 'string-stream))
+    (notnot (open-stream-p s))
+    (notnot (input-stream-p s))
+    (output-stream-p s)
+    (read-line s)))
+  t t t t nil "bcdef")
+
+(deftest with-input-from-string.17
+  (let ((i 2))
+    (values
+     (with-input-from-string
+      (s "abcdef" :index i :start i)
+      (read-char s))
+     i))
+  #\c 3)
+
+;;; Test that there is no implicit tagbody
+
+(deftest with-input-from-string.18
+  (block done
+    (tagbody
+     (with-input-from-string
+      (s "abc")
+      (go 1)
+      1
+      (return-from done :bad))
+     1
+     (return-from done :good)))
+  :good)
+
+;;; Free declaration scope
+
+(deftest with-input-from-string.19
+  (block done
+    (let ((x :bad))
+      (declare (special x))
+      (let ((x :good))
+	(with-input-from-string (s (return-from done x))
+				(declare (special x))))))
+  :good)
+
+(deftest with-input-from-string.20
+  (block done
+    (let ((x :bad))
+      (declare (special x))
+      (let ((x :good))
+	(with-input-from-string (s "abc" :start (return-from done x))
+				(declare (special x))))))
+  :good)
+
+(deftest with-input-from-string.21
+  (block done
+    (let ((x :bad))
+      (declare (special x))
+      (let ((x :good))
+	(with-input-from-string (s "abc" :end (return-from done x))
+				(declare (special x))))))
+  :good)
+
+;;; index is not updated if the form exits abnormally
+
+(deftest with-input-from-string.22
+  (let ((i nil))
+    (values
+     (block done
+       (with-input-from-string (s "abcde" :index i) (return-from done (read-char s))))
+     i))
+  #\a nil)
+
+;;; Test that explicit calls to macroexpand in subforms
+;;; are done in the correct environment
+
+(deftest with-input-from-string.23
+  (macrolet
+   ((%m (z) z))
+   (with-input-from-string (s (expand-in-current-env (%m "123")))
+			  (read-char s)))
+  #\1)
+
+(deftest with-input-from-string.24
+  (macrolet
+   ((%m (z) z))
+   (with-input-from-string (s "123" :start (expand-in-current-env (%m 1)))
+			   (read-char s)))
+  #\2)
+
+(deftest with-input-from-string.25
+  (macrolet
+   ((%m (z) z))
+   (with-input-from-string (s "123" :start 0
+			      :end (expand-in-current-env (%m 0)))
+			   (read-char s nil nil)))
+  nil)
+
+
+;;; FIXME: Add more tests on specialized strings.
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/with-open-file.lsp
@@ -0,0 +1,98 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Jan 27 20:57:05 2004
+;;;; Contains: Tests of WITH-OPEN-FILE
+
+(in-package :cl-test)
+
+;;; For now, omit most of the options combinations, assuming they will
+;;; be tested in OPEN.  The tests of OPEN should be ported to here at some
+;;; point.
+
+(deftest with-open-file.1
+  (let ((pn #p"tmp.dat"))
+    (delete-all-versions pn)
+    (with-open-file (s pn :direction :output)))
+  nil)
+
+(deftest with-open-file.2
+  (let ((pn #p"tmp.dat"))
+    (delete-all-versions pn)
+    (with-open-file
+     (s pn :direction :output)
+     (notnot-mv (output-stream-p s))))
+  t)
+
+(deftest with-open-file.3
+  (let ((pn #p"tmp.dat"))
+    (delete-all-versions pn)
+    (with-open-file
+     (s pn :direction :output)
+     (values))))
+
+(deftest with-open-file.4
+  (let ((pn #p"tmp.dat"))
+    (delete-all-versions pn)
+    (with-open-file
+     (s pn :direction :output)
+     (values 1 2 3 4 5 6 7 8)))
+  1 2 3 4 5 6 7 8)
+
+(deftest with-open-file.5
+  (let ((pn #p"tmp.dat"))
+    (delete-all-versions pn)
+    (with-open-file
+     (s pn :direction :output)
+     (declare (ignore s))
+     (declare (optimize))))
+  nil)
+
+(deftest with-open-file.6
+  (let ((pn #p"tmp.dat"))
+    (delete-all-versions pn)
+    (with-open-file
+     (s pn (cdr '(nil . :direction)) (car '(:output)))
+     (format s "foo!~%"))
+    (with-open-file (s pn) (read-line s)))
+  "foo!" nil)
+
+;;; Free declaration scope tests
+
+(deftest with-open-file.7
+  (block done
+    (let ((x :bad))
+      (declare (special x))
+      (let ((x :good))
+	(with-open-file (s (return-from done x))
+			(declare (special x))))))
+  :good)
+
+(deftest with-open-file.8
+  (block done
+    (let ((x :bad))
+      (declare (special x))
+      (let ((x :good))
+	(with-open-file (s "with-open-file.lsp" (return-from done x) :input)
+			(declare (special x))))))
+  :good)
+
+(deftest with-open-file.9
+  (block done
+    (let ((x :bad))
+      (declare (special x))
+      (let ((x :good))
+	(with-open-file (s "with-open-file.lsp" :direction (return-from done x))
+			(declare (special x))))))
+  :good)
+
+;;; Test that explicit calls to macroexpand in subforms
+;;; are done in the correct environment
+
+(deftest with-open-file.10
+  (macrolet
+   ((%m (z) z))
+   (let ((pn #p"tmp.dat"))
+    (delete-all-versions pn)
+    (with-open-file (s (expand-in-current-env (%m pn)) 
+		       :direction :output))))
+  nil)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/with-open-stream.lsp
@@ -0,0 +1,77 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Mon Dec 13 01:42:59 2004
+;;;; Contains: Tests of WITH-OPEN-STREAM
+
+(in-package :cl-test)
+
+(deftest with-open-stream.1
+  (with-open-stream (os (make-string-output-stream)))
+  nil)
+
+(deftest with-open-stream.2
+  (with-open-stream (os (make-string-output-stream))
+		    (declare (ignore os)))
+  nil)
+
+(deftest with-open-stream.3
+  (with-open-stream (os (make-string-output-stream))
+		    (declare (ignore os))
+		    (declare (type string-stream os)))
+  nil)
+
+(deftest with-open-stream.4
+  (with-open-stream (os (make-string-output-stream))
+		    (declare (ignore os))
+		    (values)))
+
+(deftest with-open-stream.5
+  (with-open-stream (os (make-string-output-stream))
+		    (declare (ignore os))
+		    (values 'a 'b))
+  a b)
+
+(deftest with-open-stream.6
+  (let ((s (make-string-output-stream)))
+    (values
+     (with-open-stream (os s))
+     (notnot (typep s 'string-stream))
+     (open-stream-p s)))
+  nil t nil)
+
+(deftest with-open-stream.7
+  (let ((s (make-string-input-stream "123")))
+    (values
+     (with-open-stream (is s) (read-char s))
+     (notnot (typep s 'string-stream))
+     (open-stream-p s)))
+  #\1 t nil)
+
+(deftest with-open-stream.8
+  (let ((s (make-string-output-stream)))
+    (values
+     (block done
+      (with-open-stream (os s) (return-from done nil)))
+     (notnot (typep s 'string-stream))
+     (open-stream-p s)))
+  nil t nil)
+
+(deftest with-open-stream.9
+  (let ((s (make-string-output-stream)))
+    (values
+     (catch 'done
+      (with-open-stream (os s) (throw 'done nil)))
+     (notnot (typep s 'string-stream))
+     (open-stream-p s)))
+  nil t nil)
+
+;;; Free declaration scope
+
+(deftest with-open-stream.10
+  (block done
+    (let ((x :bad))
+      (declare (special x))
+      (let ((x :good))
+	(with-open-stream (s (return-from done x))
+			  (declare (special x))))))
+  :good)
--- /dev/null
+++ gcl-2.6.12/ansi-tests/with-output-to-string.lsp
@@ -0,0 +1,129 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Feb 14 20:33:51 2004
+;;;; Contains: Tests of WITH-OUTPUT-TO-STRING
+
+(in-package :cl-test)
+
+
+(deftest with-output-to-string.1
+  (with-output-to-string (s))
+  "")
+
+(deftest with-output-to-string.2
+  (with-output-to-string (s) (write-char #\3 s))
+  "3")
+
+(deftest with-output-to-string.3
+  (with-output-to-string (s (make-array 10 :fill-pointer 0
+					:element-type 'character)))
+  nil)
+
+(deftest with-output-to-string.4
+  :notes (:allow-nil-arrays :nil-vectors-are-strings)
+  (let ((str (make-array 10 :fill-pointer 0 :element-type 'character)))
+    (values
+     (with-output-to-string
+       (s str :element-type nil)
+       (write-string "abcdef" s))
+     str))
+  "abcdef" "abcdef")
+
+(deftest with-output-to-string.5
+  (with-output-to-string (s (make-array 10 :fill-pointer 0
+					:element-type 'character))
+			 (values)))
+
+(deftest with-output-to-string.6
+  (with-output-to-string (s (make-array 10 :fill-pointer 0
+					:element-type 'character))
+			 (values 'a 'b 'c 'd))
+  a b c d)
+
+(deftest with-output-to-string.7
+  (with-output-to-string (s nil :element-type 'character)
+			 (write-char #\& s))
+  "&")
+
+(deftest with-output-to-string.8
+  (let ((str (with-output-to-string (s nil :element-type 'base-char)
+				    (write-char #\8 s))))
+    (assert (typep str 'simple-base-string))
+    str)
+  "8")
+
+(deftest with-output-to-string.9
+  :notes (:allow-nil-arrays :nil-vectors-are-strings)
+  (with-output-to-string (s nil :element-type nil))
+  "")
+
+(deftest with-output-to-string.10
+  (let* ((s1 (make-array 20 :element-type 'character
+			 :initial-element #\.))
+	 (s2 (make-array 10 :element-type 'character
+			 :displaced-to s1
+			 :displaced-index-offset 5
+			 :fill-pointer 0)))
+
+    (values
+     (with-output-to-string
+       (s s2)
+       (write-string "0123456789" s))
+     s1
+     s2))
+  "0123456789"
+  ".....0123456789....."
+  "0123456789")
+
+(deftest with-output-to-string.11
+  (with-output-to-string (s) (declare (optimize safety)))
+  "")
+
+(deftest with-output-to-string.12
+  (with-output-to-string (s) (declare (optimize safety))
+			 (declare (optimize (speed 0))))
+  "")
+
+(deftest with-output-to-string.13
+  (with-output-to-string
+    (s)
+    (write-char #\0 s)
+    (write-char #\4 s)
+    (write-char #\9 s))
+  "049")
+
+(deftest with-output-to-string.14
+  (let* ((str1 (make-array '(256) :element-type 'base-char :fill-pointer 0))
+	 (str2 (with-output-to-string
+		 (s nil :element-type 'base-char)
+		 (loop for i below 256
+		       for c = (code-char i)
+		       when (typep c 'base-char)
+		       do (progn (write-char c s)
+				 (vector-push c str1))))))
+    (if (string= str1 str2) :good
+      (list str1 str2)))
+  :good)
+
+;;; Free declaration scope
+
+(deftest with-output-to-string.15
+  (block done
+    (let ((x :bad))
+      (declare (special x))
+      (let ((x :good))
+	(with-output-to-string (s (return-from done x))
+			       (declare (special x))))))
+  :good)
+
+(deftest with-output-to-string.16
+  (block done
+    (let ((x :bad))
+      (declare (special x))
+      (let ((x :good)
+	    (str (make-array '(10) :element-type 'character
+			     :fill-pointer 0)))
+	(with-output-to-string (s str :element-type (return-from done x))
+			       (declare (special x))))))
+  :good)
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/write-char.lsp
@@ -0,0 +1,51 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Jan 18 20:50:31 2004
+;;;; Contains: Tests of WRITE-CHAR
+
+(in-package :cl-test)
+
+(deftest write-char.1
+  (loop for i from 0 to 255
+	for c = (code-char i)
+	when c
+	unless (string= (with-output-to-string
+			  (*standard-output*)
+			  (write-char c))
+			(string c))
+	collect c)
+  nil)
+
+(deftest write-char.2
+  (with-input-from-string
+   (is "abcd")
+   (with-output-to-string
+     (os)
+     (let ((*terminal-io* (make-two-way-stream is os)))
+       (write-char #\$ t)
+       (close *terminal-io*))))
+  "$")
+
+(deftest write-char.3
+  (with-output-to-string
+    (*standard-output*)
+    (write-char #\: nil))
+  ":")
+
+;;; Error tests
+
+(deftest write-char.error.1
+  (signals-error (write-char) program-error)
+  t)
+
+(deftest write-char.error.2
+  (signals-error
+   (with-output-to-string
+     (s)
+     (write-char #\a s nil))
+   program-error)
+  t)
+
+;;; More tests in other files
+
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/write-line.lsp
@@ -0,0 +1,165 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Mon Jan 19 06:49:26 2004
+;;;; Contains: Tests of WRITE-LINE
+
+(in-package :cl-test)
+
+(deftest write-line.1
+  (let (result)
+    (values
+     (with-output-to-string
+       (*standard-output*)
+       (setq result (multiple-value-list (write-line ""))))
+     result))
+  #.(string #\Newline)
+  (""))
+
+(deftest write-line.2
+  :notes (:nil-vectors-are-strings)
+  (let (result)
+    (values
+     (with-output-to-string
+       (*standard-output*)
+       (setq result
+	     (multiple-value-list
+	      (write-line (make-array '(0) :element-type nil)))))
+     result))
+  #.(string #\Newline)
+  (""))
+
+(deftest write-line.3
+  (let (result)
+    (values
+     (with-output-to-string
+       (*standard-output*)
+       (setq result (multiple-value-list (write-line "abcde"))))
+     result))
+  #.(concatenate 'string "abcde" (string #\Newline))
+  ("abcde"))
+
+(deftest write-line.4
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (setq result (multiple-value-list (write-line "abcde" s :start 1))))
+     result))
+  #.(concatenate 'string "bcde" (string #\Newline))
+  ("abcde"))
+
+(deftest write-line.5
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (setq result (multiple-value-list
+		     (write-line "abcde" s :start 1 :end 3))))
+     result))
+  #.(concatenate 'string "bc" (string #\Newline))
+  ("abcde"))
+
+(deftest write-line.6
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (setq result (multiple-value-list
+		     (write-line "abcde" s :start 1 :end nil))))
+     result))
+  #.(concatenate 'string "bcde" (string #\Newline))
+  ("abcde"))
+
+(deftest write-line.7
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (setq result (multiple-value-list (write-line "abcde" s :end 3))))
+     result))
+  #.(concatenate 'string "abc" (string #\Newline))
+  ("abcde"))
+
+(deftest write-line.8
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (setq result (multiple-value-list
+		     (write-line "abcde" s :end 3 :allow-other-keys nil))))
+     result))
+  #.(concatenate 'string "abc" (string #\Newline))
+  ("abcde"))
+
+(deftest write-line.9
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (setq result
+	     (multiple-value-list
+	      (write-line "abcde" s :end 3 :allow-other-keys t :foo 'bar))))
+     result))
+  #.(concatenate 'string "abc" (string #\Newline))
+  ("abcde"))
+
+(deftest write-line.10
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (setq result (multiple-value-list
+		     (write-line "abcde" s :end 3 :end 2))))
+     result))
+  #.(concatenate 'string "abc" (string #\Newline))
+  ("abcde"))
+
+(deftest write-line.11
+  (with-input-from-string
+   (is "abcd")
+   (with-output-to-string
+     (os)
+     (let ((*terminal-io* (make-two-way-stream is os)))
+       (write-line "951" t)
+       (close *terminal-io*))))
+  #.(concatenate 'string "951" (string #\Newline)))
+
+(deftest write-line.12
+  (with-output-to-string
+    (*standard-output*)
+    (write-line "-=|!" nil))
+  #.(concatenate 'string "-=|!" (string #\Newline)))
+
+;;; Specialized string tests
+
+(deftest write-line.13
+  (do-special-strings
+   (s "abcde" nil)
+   (assert (equal
+	    (with-output-to-string
+	      (*standard-output*)
+	      (multiple-value-list (write-line "abcde")))
+	    #.(concatenate 'string "abcde" (string #\Newline)))))
+  nil)
+
+;;; Error tests
+
+(deftest write-line.error.1
+  (signals-error (write-line) program-error)
+  t)
+
+(deftest write-line.error.2
+  (signals-error (write-line "" *standard-output* :start) program-error)
+  t)
+
+(deftest write-line.error.3
+  (signals-error (write-line "" *standard-output* :foo nil) program-error)
+  t)
+
+(deftest write-line.error.4
+  (signals-error (write-line "" *standard-output*
+			       :allow-other-keys nil
+			       :foo nil)
+		 program-error)
+  t)
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/write-sequence.lsp
@@ -0,0 +1,225 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Wed Jan 21 04:07:58 2004
+;;;; Contains: Tests of WRITE-SEQUENCE
+
+(in-package :cl-test)
+
+(defmacro def-write-sequence-test (name input args &rest expected)
+  `(deftest ,name
+     (let ((s ,input))
+       (with-output-to-string
+	 (os)
+	 (assert (eq (write-sequence s os ,@args) s))))
+     ,@expected))
+
+;;; on strings
+
+(def-write-sequence-test write-sequence.string.1 "abcde" () "abcde")
+(def-write-sequence-test write-sequence.string.2 "abcde" (:start 1) "bcde")
+(def-write-sequence-test write-sequence.string.3 "abcde" (:end 3) "abc")
+(def-write-sequence-test write-sequence.string.4 "abcde"
+  (:start 1 :end 4) "bcd")
+(def-write-sequence-test write-sequence.string.5 "abcde" (:end nil) "abcde")
+(def-write-sequence-test write-sequence.string.6 "abcde" (:start 3 :end 3) "")
+(def-write-sequence-test write-sequence.string.7 "abcde"
+  (:end nil :start 1) "bcde")
+(def-write-sequence-test write-sequence.string.8 "abcde"
+  (:allow-other-keys nil) "abcde")
+(def-write-sequence-test write-sequence.string.9 "abcde"
+  (:allow-other-keys t :foo nil) "abcde")
+(def-write-sequence-test write-sequence.string.10 "abcde"
+  (:allow-other-keys t :allow-other-keys nil :foo nil) "abcde")
+(def-write-sequence-test write-sequence.string.11 "abcde"
+  (:bar 'x :allow-other-keys t) "abcde")
+(def-write-sequence-test write-sequence.string.12 "abcde"
+  (:start 1 :end 4 :start 2 :end 3) "bcd")
+(def-write-sequence-test write-sequence.string.13 "" () "")
+
+(defmacro def-write-sequence-special-test (name string args expected)
+  `(deftest ,name
+     (let ((str ,string)
+	   (expected ,expected))
+       (do-special-strings
+	(s str nil)
+	(let ((out (with-output-to-string
+		     (os)
+		     (assert (eq (write-sequence s os ,@args) s)))))
+	  (assert (equal out expected)))))
+     nil))
+
+(def-write-sequence-special-test write-sequence.string.14 "12345" () "12345")
+(def-write-sequence-special-test write-sequence.string.15 "12345" (:start 1 :end 3) "23")
+
+;;; on lists
+
+(def-write-sequence-test write-sequence.list.1 (coerce "abcde" 'list)
+  () "abcde")
+(def-write-sequence-test write-sequence.list.2 (coerce "abcde" 'list)
+  (:start 1) "bcde")
+(def-write-sequence-test write-sequence.list.3 (coerce "abcde" 'list)
+  (:end 3) "abc")
+(def-write-sequence-test write-sequence.list.4 (coerce "abcde" 'list)
+  (:start 1 :end 4) "bcd")
+(def-write-sequence-test write-sequence.list.5 (coerce "abcde" 'list)
+  (:end nil) "abcde")
+(def-write-sequence-test write-sequence.list.6 (coerce "abcde" 'list)
+  (:start 3 :end 3) "")
+(def-write-sequence-test write-sequence.list.7 (coerce "abcde" 'list)
+  (:end nil :start 1) "bcde")
+(def-write-sequence-test write-sequence.list.8 () () "")
+
+
+;;; on vectors
+
+(def-write-sequence-test write-sequence.simple-vector.1
+  (coerce "abcde" 'simple-vector) () "abcde")
+(def-write-sequence-test write-sequence.simple-vector.2
+  (coerce "abcde" 'simple-vector) (:start 1) "bcde")
+(def-write-sequence-test write-sequence.simple-vector.3
+  (coerce "abcde" 'simple-vector) (:end 3) "abc")
+(def-write-sequence-test write-sequence.simple-vector.4
+  (coerce "abcde" 'simple-vector) (:start 1 :end 4) "bcd")
+(def-write-sequence-test write-sequence.simple-vector.5
+  (coerce "abcde" 'simple-vector) (:end nil) "abcde")
+(def-write-sequence-test write-sequence.simple-vector.6
+  (coerce "abcde" 'simple-vector) (:start 3 :end 3) "")
+(def-write-sequence-test write-sequence.simple-vector.7
+  (coerce "abcde" 'simple-vector) (:end nil :start 1) "bcde")
+(def-write-sequence-test write-sequence.simple-vector.8 #() () "")
+
+;;; on vectors with fill pointers
+
+(def-write-sequence-test write-sequence.fill-vector.1
+  (make-array 10 :initial-contents "abcde     " :fill-pointer 5) () "abcde")
+(def-write-sequence-test write-sequence.fill-vector.2
+  (make-array 10 :initial-contents "abcde     " :fill-pointer 5)
+  (:start 1) "bcde")
+(def-write-sequence-test write-sequence.fill-vector.3
+  (make-array 10 :initial-contents "abcde     " :fill-pointer 5)
+  (:end 3) "abc")
+(def-write-sequence-test write-sequence.fill-vector.4
+  (make-array 10 :initial-contents "abcde     " :fill-pointer 5)
+  (:start 1 :end 4) "bcd")
+(def-write-sequence-test write-sequence.fill-vector.5
+  (make-array 10 :initial-contents "abcde     " :fill-pointer 5)
+  (:end nil) "abcde")
+(def-write-sequence-test write-sequence.fill-vector.6
+  (make-array 10 :initial-contents "abcde     " :fill-pointer 5)
+  (:start 3 :end 3) "")
+(def-write-sequence-test write-sequence.fill-vector.7
+  (make-array 10 :initial-contents "abcde     " :fill-pointer 5)
+  (:end nil :start 1) "bcde")
+
+;;; on bit vectors
+
+(defmacro def-write-sequence-bv-test (name input args expected)
+  `(deftest ,name
+     (let ((s ,input)
+	   (expected ,expected))
+       (with-open-file
+	(os "tmp.dat" :direction :output
+	    :element-type '(unsigned-byte 8)
+	    :if-exists :supersede)
+	 (assert (eq (write-sequence s os ,@args) s)))
+       (with-open-file
+	(is "tmp.dat" :direction :input
+	    :element-type '(unsigned-byte 8))
+	 (loop for i from 0 below (length expected)
+	       for e = (elt expected i)
+	       always (eql (read-byte is) e))))
+     t))
+
+(def-write-sequence-bv-test write-sequence.bv.1 #*00111010
+  () #*00111010)
+(def-write-sequence-bv-test write-sequence.bv.2 #*00111010
+  (:start 1) #*0111010)
+(def-write-sequence-bv-test write-sequence.bv.3 #*00111010
+  (:end 5) #*00111)
+(def-write-sequence-bv-test write-sequence.bv.4 #*00111010
+  (:start 1 :end 6) #*01110)
+(def-write-sequence-bv-test write-sequence.bv.5 #*00111010
+  (:start 1 :end nil) #*0111010)
+(def-write-sequence-bv-test write-sequence.bv.6 #*00111010
+  (:start 1 :end nil :end 4) #*0111010)
+
+
+;;; Error tests
+
+(deftest write-sequence.error.1
+  (signals-error (write-sequence) program-error)
+  t)
+
+(deftest write-sequence.error.2
+  (signals-error (write-sequence "abcde") program-error)
+  t)
+
+(deftest write-sequence.error.3
+  (signals-error (write-sequence '(#\a . #\b) *standard-output*) type-error)
+  t)
+
+(deftest write-sequence.error.4
+  (signals-error (write-sequence #\a *standard-output*) type-error)
+  t)
+
+(deftest write-sequence.error.5
+  (signals-error (write-sequence "ABC" *standard-output* :start -1) type-error)
+  t)
+
+(deftest write-sequence.error.6
+  (signals-error (write-sequence "ABC" *standard-output* :start 'x) type-error)
+  t)
+
+(deftest write-sequence.error.7
+  (signals-error (write-sequence "ABC" *standard-output* :start 0.0)
+		 type-error)
+  t)
+
+(deftest write-sequence.error.8
+  (signals-error (write-sequence "ABC" *standard-output* :end -1)
+		 type-error)
+  t)
+
+(deftest write-sequence.error.9
+  (signals-error (write-sequence "ABC" *standard-output* :end 'x)
+		 type-error)
+  t)
+
+(deftest write-sequence.error.10
+  (signals-error (write-sequence "ABC" *standard-output* :end 2.0)
+		 type-error)
+  t)
+
+(deftest write-sequence.error.11
+  (signals-error (write-sequence "abcde" *standard-output*
+				 :foo nil) program-error)
+  t)
+	 
+(deftest write-sequence.error.12
+  (signals-error (write-sequence "abcde" *standard-output*
+				 :allow-other-keys nil :foo t)
+		 program-error)
+  t)
+
+(deftest write-sequence.error.13
+  (signals-error (write-sequence "abcde" *standard-output* :start)
+		 program-error)
+  t)
+
+(deftest write-sequence.error.14
+  (check-type-error #'(lambda (x) (write-sequence x *standard-output*))
+		    #'sequencep)
+  nil)
+
+(deftest write-sequence.error.15
+  (check-type-error #'(lambda (x) (write-sequence "abcde" *standard-output*
+						  :start x))
+		    (typef 'unsigned-byte))
+  nil)
+
+(deftest write-sequence.error.16
+  (check-type-error #'(lambda (x) (write-sequence "abcde" *standard-output*
+						  :end x))
+		    (typef '(or null unsigned-byte)))
+  nil)
+
--- /dev/null
+++ gcl-2.6.12/ansi-tests/write-string.lsp
@@ -0,0 +1,156 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Jan 18 21:13:32 2004
+;;;; Contains: Tests of WRITE-STRING
+
+(in-package :cl-test)
+
+(deftest write-string.1
+  (let (result)
+    (values
+     (with-output-to-string
+       (*standard-output*)
+       (setq result (multiple-value-list (write-string ""))))
+     result))
+  "" (""))
+
+(deftest write-string.2
+  :notes (:nil-vectors-are-strings)
+  (let (result)
+    (values
+     (with-output-to-string
+       (*standard-output*)
+       (setq result
+	     (multiple-value-list
+	      (write-string (make-array '(0) :element-type nil)))))
+     result))
+  "" (""))
+
+(deftest write-string.3
+  (let (result)
+    (values
+     (with-output-to-string
+       (*standard-output*)
+       (setq result (multiple-value-list (write-string "abcde"))))
+     result))
+  "abcde" ("abcde"))
+
+(deftest write-string.4
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (setq result (multiple-value-list (write-string "abcde" s :start 1))))
+     result))
+  "bcde" ("abcde"))
+
+(deftest write-string.5
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (setq result (multiple-value-list
+		     (write-string "abcde" s :start 1 :end 3))))
+     result))
+  "bc" ("abcde"))
+
+(deftest write-string.6
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (setq result (multiple-value-list
+		     (write-string "abcde" s :start 1 :end nil))))
+     result))
+  "bcde" ("abcde"))
+
+(deftest write-string.7
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (setq result (multiple-value-list (write-string "abcde" s :end 3))))
+     result))
+  "abc" ("abcde"))
+
+(deftest write-string.8
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (setq result (multiple-value-list
+		     (write-string "abcde" s :end 3 :allow-other-keys nil))))
+     result))
+  "abc" ("abcde"))
+
+(deftest write-string.9
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (setq result
+	     (multiple-value-list
+	      (write-string "abcde" s :end 3 :allow-other-keys t :foo 'bar))))
+     result))
+  "abc" ("abcde"))
+
+(deftest write-string.10
+  (let (result)
+    (values
+     (with-output-to-string
+       (s)
+       (setq result (multiple-value-list
+		     (write-string "abcde" s :end 3 :end 2))))
+     result))
+  "abc" ("abcde"))
+
+(deftest write-string.11
+  (with-input-from-string
+   (is "abcd")
+   (with-output-to-string
+     (os)
+     (let ((*terminal-io* (make-two-way-stream is os)))
+       (write-string "951" t)
+       (close *terminal-io*))))
+  "951")
+
+(deftest write-string.12
+  (with-output-to-string
+    (*standard-output*)
+    (write-string "-=|!" nil))
+  "-=|!")
+
+;;; Specialized string tests
+
+(deftest write-string.13
+  (let (result)
+    (do-special-strings
+     (s "abcde" nil)
+     (assert (equal
+	      (with-output-to-string
+		(*standard-output*)
+		(setq result (multiple-value-list (write-string "abcde"))))
+	      "abcde"))
+     (assert (equal result '("abcde")))))
+  nil)
+
+;;; Error tests
+
+(deftest write-string.error.1
+  (signals-error (write-string) program-error)
+  t)
+
+(deftest write-string.error.2
+  (signals-error (write-string "" *standard-output* :start) program-error)
+  t)
+
+(deftest write-string.error.3
+  (signals-error (write-string "" *standard-output* :foo nil) program-error)
+  t)
+
+(deftest write-string.error.4
+  (signals-error (write-string "" *standard-output*
+			       :allow-other-keys nil
+			       :foo nil)
+		 program-error)
+  t)
--- gcl-2.6.12.orig/cmpnew/gcl_cmpfun.lsp
+++ gcl-2.6.12/cmpnew/gcl_cmpfun.lsp
@@ -556,6 +556,14 @@
 	   ((null type) nil)
 	   ((setq f (assoc type *type-alist* :test 'equal))
 	    (list (cdr f) x))
+	   ((setq f (when (symbolp type) (get type 'si::type-predicate)))
+	    (list f x))
+	   ((and (consp type) (eq (car type) 'or))
+	    `(or ,@(mapcar (lambda (y) `(typep ,x ',y)) (cdr type))))
+	   ((and (consp type) (eq (car type) 'member))
+	    `(or ,@(mapcar (lambda (y) `(eql ,x ',y)) (cdr type))))
+	   ((and (consp type) (eq (car type) 'eql))
+	    `(eql ,x ',(cadr type)))
 	   ((and (consp type)
 		 (or (and (eq (car type) 'vector)
 			  (null (cddr type)))
--- gcl-2.6.12.orig/cmpnew/gcl_cmplabel.lsp
+++ gcl-2.6.12/cmpnew/gcl_cmplabel.lsp
@@ -44,7 +44,7 @@
   `(when (cdr ,label) (wt-nl "goto T" (car ,label) ";")(wt-nl1 "T" (car ,label) ":;")))
 
 (defmacro wt-go (label)
-  `(progn (rplacd ,label t) (wt "goto T" (car ,label) ";")))
+  `(progn (rplacd ,label t) (wt "goto T" (car ,label) ";")(wt-nl)))
 
 
 (defvar *restore-avma* nil)
--- gcl-2.6.12.orig/cmpnew/gcl_cmplam.lsp
+++ gcl-2.6.12/cmpnew/gcl_cmplam.lsp
@@ -407,6 +407,12 @@
            (c2lambda-expr-without-key lambda-list body)))
   ))
 
+(defun decl-body-safety (body)
+  (case (car body)
+    (decl-body (or (cadr (assoc 'safety (caddr body))) 0))
+    ((let let*) (decl-body-safety (car (last body))))
+    (otherwise 0)))
+
 (defun c2lambda-expr-without-key
        (lambda-list body
         &aux (requireds (car lambda-list))
@@ -439,7 +445,7 @@
         (when rest (do-decl rest))
         )
   ;;; check arguments
-  (when (or *safe-compile* *compiler-check-args*)
+  (when (or *safe-compile* *compiler-check-args* (plusp (decl-body-safety body)));FIXME
     (cond ((or rest optionals)
            (when requireds
              (wt-nl "if(vs_top-vs_base<" (length requireds)
@@ -448,7 +454,7 @@
              (wt-nl "if(vs_top-vs_base>"
                     (+ (length requireds) (length optionals))
                     ") too_many_arguments();")))
-          (t (wt-nl "check_arg(" (length requireds) ");"))))
+          (t (when requireds (wt-nl "check_arg(" (length requireds) ");")))))
 
   ;;; Allocate the parameters.
   (dolist** (var requireds) (setf (var-ref var) (vs-push)))
@@ -562,7 +568,7 @@
                   (when (cadddr kwd) (do-decl (cadddr kwd))))
         )
   ;;; Check arguments.
-  (when (and (or *safe-compile* *compiler-check-args*) requireds)
+  (when (and (or *safe-compile* *compiler-check-args* (plusp (decl-body-safety body))) requireds);FIXME
         (when requireds
               (wt-nl "if(vs_top-vs_base<" (length requireds)
                      ") too_few_arguments();")))
--- gcl-2.6.12.orig/cmpnew/gcl_cmpmain.lsp
+++ gcl-2.6.12/cmpnew/gcl_cmpmain.lsp
@@ -52,7 +52,7 @@
 (defvar *cmpinclude-string* 
   (si::file-to-string 
    (namestring
-    (make-pathname :directory (append (pathname-directory si::*system-directory*) (list :parent "h"))
+    (make-pathname :directory (append (pathname-directory si::*system-directory*) (list :back "h"))
 		   :name "cmpinclude" :type "h"))))
 
 
@@ -160,7 +160,7 @@
 
 
 (defun compile-file1 (input-pathname
-                      &key (output-file (truename input-pathname))
+                      &key (output-file (merge-pathnames ".o" (truename input-pathname)))
                            (o-file t)
                            (c-file *default-c-file*)
                            (h-file *default-h-file*)
@@ -175,7 +175,7 @@
 			   (*c-debug* c-debug)
 			   (*compile-print* (or print *compile-print*))
                            (*package* *package*)
-			   (*DEFAULT-PATHNAME-DEFAULTS* #"")
+			   (*DEFAULT-PATHNAME-DEFAULTS* #p"")
 			   (*data* (list (make-array 50 :fill-pointer 0 :adjustable t) nil nil))
 			   *init-name* 	
 			   (*fasd-data* *fasd-data*)
@@ -186,25 +186,25 @@
   (cond (*compiler-in-use*
          (format t "~&The compiler was called recursively.~%~
 Cannot compile ~a.~%"
-                 (namestring (merge-pathnames input-pathname #".lsp")))
+                 (namestring (merge-pathnames input-pathname #p".lsp")))
          (setq *error-p* t)
          (return-from compile-file1 (values)))
         (t (setq *error-p* nil)
            (setq *compiler-in-use* t)))  
 
-  (unless (probe-file (merge-pathnames input-pathname #".lsp"))
+  (unless (probe-file (merge-pathnames input-pathname #p".lsp"))
     (format t "~&The source file ~a is not found.~%"
-            (namestring (merge-pathnames input-pathname #".lsp")))
+            (namestring (merge-pathnames input-pathname #p".lsp")))
     (setq *error-p* t)
     (return-from compile-file1 (values)))
 
   (when *compile-verbose*
-    (format t "~&Compiling ~a.~%" (namestring (merge-pathnames input-pathname #".lsp"))))
+    (format t "~&Compiling ~a.~%" (namestring (merge-pathnames input-pathname #p".lsp"))))
 
   (and *record-call-info* (clear-call-table))
 
   (with-open-file
-   (*compiler-input* (merge-pathnames input-pathname #".lsp"))
+   (*compiler-input* (merge-pathnames input-pathname #p".lsp"))
    
    
    (cond ((numberp *split-files*)
@@ -232,8 +232,11 @@ Cannot compile ~a.~%"
 	 (device (or (and (not (null output-file))
 			  (pathname-device output-file))
 		     (pathname-device input-pathname)))
+	 (typ (or (and (not (null output-file))
+		       (pathname-type output-file))
+		  "o"))
 	 
-         (o-pathname (get-output-pathname o-file "o" name dir device))
+         (o-pathname (get-output-pathname o-file typ name dir device))
          (c-pathname (get-output-pathname c-file "c" name dir device))
          (h-pathname (get-output-pathname h-file "h" name dir device))
          (data-pathname (get-output-pathname data-file "data" name dir device)))
@@ -351,7 +354,7 @@ Cannot compile ~a.~%"
     (wt-data1 form)  ;; this binds all the print stuff
     ))
 
-(defun compile (name &optional def &aux tem gaz (*default-pathname-defaults* #"."))
+(defun compile (name &optional def &aux tem gaz (*default-pathname-defaults* #p"."))
 
   (cond ((not(symbolp name)) (error "Must be a name"))
 	((and (consp def)
@@ -797,7 +800,7 @@ Cannot compile ~a.~%"
 
     (with-open-file (st (namestring map) :direction :output))
     (safe-system 
-     (let* ((par (namestring (make-pathname :directory '(:parent))))
+     (let* ((par (namestring (make-pathname :directory '(:back))))
 	    (i (concatenate 'string " " par))
 	    (j (concatenate 'string " " si::*system-directory* par)))
        (format nil "~a ~a ~a ~a -L~a ~a ~a ~a"
--- gcl-2.6.12.orig/cmpnew/gcl_cmpopt.lsp
+++ gcl-2.6.12/cmpnew/gcl_cmpopt.lsp
@@ -1170,6 +1170,14 @@ type_of(#0)==t_complex")
  (push '((t) t #.(flags ans)"coerce_to_string(#0)")
    (get 'string 'inline-always))
 
+;;PATHNAME-DESIGNATORP
+(push '((t) boolean #.(flags)"pathname_designatorp(#0)")
+      (get 'si::pathname-designatorp 'inline-always))
+
+;;PATHNAMEP
+(push '((t) boolean #.(flags)"pathnamep(#0)")
+      (get 'pathnamep 'inline-always))
+
 ;;STRINGP
  (push '((t) boolean #.(flags)"type_of(#0)==t_string")
    (get 'stringp 'inline-always))
--- gcl-2.6.12.orig/cmpnew/gcl_cmptop.lsp
+++ gcl-2.6.12/cmpnew/gcl_cmptop.lsp
@@ -209,7 +209,7 @@
 
   (cond ((not sp) "code")
 	((not (pathnamep p)) (init-name (pathname p) sp gp dc nt))
-	(gp (init-name (truename (merge-pathnames p #".lsp")) sp nil dc nt))
+	(gp (init-name (truename (merge-pathnames p #p".lsp")) sp nil dc nt))
 	((pathname-type p)
 	 (init-name (make-pathname
                      :host (pathname-host p)
--- gcl-2.6.12.orig/cmpnew/gcl_collectfn.lsp
+++ gcl-2.6.12/cmpnew/gcl_collectfn.lsp
@@ -240,22 +240,20 @@
 
 (defvar *warn-on-multiple-fn-definitions* t)
 
-(defun add-fn-data (lis &aux tem file)
-  (let ((file (and (setq file (si::fp-input-stream *standard-input*))
-		   (truename file))))
+(defun add-fn-data (lis &aux tem (file *load-truename*))
   (dolist (v lis)
-	  (cond ((eql (fn-name v) 'other-form)
-		 (setf (fn-name v) (intern
-				    (concatenate 'string "OTHER-FORM-"
-						 (namestring file))))
-		 (setf (get (fn-name v) 'other-form) t)))
-	  (setf (gethash (fn-name v) *call-table*) v)
-	  (when *warn-on-multiple-fn-definitions*
-	    (when (setq tem (gethash (fn-name v) *file-table*))
-	      (unless (equal tem file)
-		(warn 'simple-warning :format-control "~% ~a redefined in ~a. Originally in ~a."
-		      :format-arguments (list (fn-name v) file tem)))))
-	  (setf (gethash (fn-name v) *file-table*) file))))
+    (cond ((eql (fn-name v) 'other-form)
+	   (setf (fn-name v) (intern
+			      (concatenate 'string "OTHER-FORM-"
+					   (namestring file))))
+	   (setf (get (fn-name v) 'other-form) t)))
+    (setf (gethash (fn-name v) *call-table*) v)
+    (when *warn-on-multiple-fn-definitions*
+      (when (setq tem (gethash (fn-name v) *file-table*))
+	(unless (equal tem file)
+	  (warn 'simple-warning :format-control "~% ~a redefined in ~a. Originally in ~a."
+		:format-arguments (list (fn-name v) file tem)))))
+    (setf (gethash (fn-name v) *file-table*) file)))
 
 (defun dump-fn-data (&optional (file "fn-data.lsp")
 			       &aux (*package* (find-package "COMPILER"))
--- gcl-2.6.12.orig/cmpnew/gcl_lfun_list.lsp
+++ gcl-2.6.12/cmpnew/gcl_lfun_list.lsp
@@ -20,7 +20,6 @@
 (DEFSYSFUN 'CHAR-NAME "Lchar_name" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'RASSOC-IF "Lrassoc_if" '(T T) 'T NIL NIL) 
 (DEFSYSFUN 'MAKE-LIST "Lmake_list" '(T *) 'T NIL NIL) 
-(DEFSYSFUN 'HOST-NAMESTRING "Lhost_namestring" '(T) 'STRING NIL NIL) 
 (DEFSYSFUN 'MAKE-ECHO-STREAM "Lmake_echo_stream" '(T T) 'T NIL NIL) 
 ;(DEFSYSFUN 'NTH "Lnth" '(T T) 'T NIL NIL) 
 (DEFSYSFUN 'SIN "Lsin" '(T) 'T NIL NIL) 
@@ -31,8 +30,6 @@
 ;#-clcs (DEFSYSFUN 'OPEN "Lopen" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'BOTH-CASE-P "Lboth_case_p" '(T) 'T NIL T) 
 (DEFSYSFUN 'NULL "Lnull" '(T) 'T NIL T) 
-(DEFSYSFUN 'RENAME-FILE "Lrename_file" '(T T) 'T NIL NIL) 
-(DEFSYSFUN 'FILE-AUTHOR "Lfile_author" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'STRING-CAPITALIZE "Lstring_capitalize" '(T *) 'STRING NIL
     NIL) 
 (DEFSYSFUN 'MACROEXPAND "Lmacroexpand" '(T *) '(VALUES T T) NIL NIL) 
@@ -45,7 +42,6 @@
 (DEFSYSFUN 'LENGTH "Llength" '(T) 'FIXNUM T NIL) 
 (DEFSYSFUN 'RASSOC "Lrassoc" '(T T *) 'T NIL NIL) 
 (DEFSYSFUN 'PPRINT "Lpprint" '(T *) 'T NIL NIL) 
-(DEFSYSFUN 'PATHNAME-HOST "Lpathname_host" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'NSUBST-IF-NOT "Lnsubst_if_not" '(T T T *) 'T NIL NIL) 
 (DEFSYSFUN 'FILE-POSITION "Lfile_position" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'STRING< "Lstring_l" '(T T *) 'T NIL NIL) 
@@ -58,14 +54,11 @@
 (DEFSYSFUN 'STRING>= "Lstring_ge" '(T T *) 'T NIL NIL) 
 (DEFSYSFUN 'REALPART "Lrealpart" '(T) 'T NIL NIL) 
 ;;broken on suns..
-;(DEFSYSFUN 'USER-HOMEDIR-PATHNAME "Luser_homedir_pathname" '(*) 'T NIL
-;    NIL) 
 (DEFSYSFUN 'NBUTLAST "Lnbutlast" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'ARRAY-DIMENSION "Larray_dimension" '(T T) 'FIXNUM NIL NIL) 
 (DEFSYSFUN 'CDR "Lcdr" '(T) 'T NIL NIL) 
 ;(DEFSYSFUN 'EQL "Leql" '(T T) 'T NIL T) 
 (DEFSYSFUN 'LOG "Llog" '(T *) 'T NIL NIL) 
-(DEFSYSFUN 'DIRECTORY "Ldirectory" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'STRING-NOT-EQUAL "Lstring_not_equal" '(T T *) 'T NIL NIL) 
 (DEFSYSFUN 'SHADOWING-IMPORT "Lshadowing_import" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'MAPC "Lmapc" '(T T *) 'T NIL NIL) 
@@ -78,8 +71,6 @@
 (DEFSYSFUN 'MAKE-SYMBOL "Lmake_symbol" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'STRING-RIGHT-TRIM "Lstring_right_trim" '(T T) 'STRING NIL
     NIL) 
-(DEFSYSFUN 'ENOUGH-NAMESTRING "Lenough_namestring" '(T *) 'STRING NIL
-    NIL) 
 (DEFSYSFUN 'PRINT "Lprint" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'CDDAAR "Lcddaar" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'CDADAR "Lcdadar" '(T) 'T NIL NIL) 
@@ -187,7 +178,6 @@
     NIL) 
 (DEFSYSFUN 'COPY-ALIST "Lcopy_alist" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'ATAN "Latan" '(T *) 'T NIL NIL) 
-(DEFSYSFUN 'DELETE-FILE "Ldelete_file" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'FLOAT-RADIX "Lfloat_radix" '(T) 'FIXNUM NIL NIL) 
 (DEFSYSFUN 'SYMBOL-NAME "Lsymbol_name" '(T) 'STRING NIL NIL) 
 (DEFSYSFUN 'CLEAR-INPUT "Lclear_input" '(*) 'T NIL NIL) 
@@ -215,8 +205,6 @@
 (DEFSYSFUN 'SXHASH "Lsxhash" '(T) 'FIXNUM NIL NIL) 
 (DEFSYSFUN 'LISTEN "Llisten" '(*) 'T NIL NIL) 
 (DEFSYSFUN 'ARRAYP "Larrayp" '(T) 'T NIL T) 
-(DEFSYSFUN 'MAKE-PATHNAME "Lmake_pathname" '(*) 'T NIL NIL) 
-(DEFSYSFUN 'PATHNAME-TYPE "Lpathname_type" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'FUNCALL "Lfuncall" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'CLRHASH "Lclrhash" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'GRAPHIC-CHAR-P "Lgraphic_char_p" '(T) 'T NIL T) 
@@ -227,14 +215,12 @@
 (DEFSYSFUN 'SUBST-IF "Lsubst_if" '(T T T *) 'T NIL NIL) 
 (DEFSYSFUN 'COMPLEXP "Lcomplexp" '(T) 'T NIL T) 
 (DEFSYSFUN 'READ-LINE "Lread_line" '(*) '(VALUES T T) NIL NIL) 
-(DEFSYSFUN 'PATHNAMEP "Lpathnamep" '(T) 'T NIL T) 
 (DEFSYSFUN 'MAX "Lmax" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'IN-PACKAGE "Lin_package" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'READTABLEP "Lreadtablep" '(T) 'T NIL T) 
 (DEFSYSFUN 'FLOAT-SIGN "Lfloat_sign" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'CHARACTERP "Lcharacterp" '(T) 'T NIL T) 
 (DEFSYSFUN 'READ "Lread" '(*) 'T NIL NIL) 
-(DEFSYSFUN 'NAMESTRING "Lnamestring" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'UNREAD-CHAR "Lunread_char" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'CDAAR "Lcdaar" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'CADAR "Lcadar" '(T) 'T NIL NIL) 
@@ -267,10 +253,8 @@
 (DEFSYSFUN 'PACKAGEP "Lpackagep" '(T) 'T NIL T) 
 (DEFSYSFUN 'INPUT-STREAM-P "Linput_stream_p" '(T) 'T NIL T) 
 (DEFSYSFUN '>= "Lmonotonically_nonincreasing" '(T *) 'T NIL T) 
-(DEFSYSFUN 'PATHNAME "Lpathname" '(T) 'T NIL NIL) 
 ;(DEFSYSFUN 'EQ "Leq" '(T T) 'T NIL T) 
 (DEFSYSFUN 'MAKE-CHAR "Lmake_char" '(T *) 'CHARACTER NIL NIL) 
-(DEFSYSFUN 'FILE-NAMESTRING "Lfile_namestring" '(T) 'STRING NIL NIL) 
 (DEFSYSFUN 'CHARACTER "Lcharacter" '(T) 'CHARACTER NIL NIL) 
 (DEFSYSFUN 'SYMBOL-FUNCTION "Lsymbol_function" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'CONSTANTP "Lconstantp" '(T) 'T NIL T) 
@@ -307,13 +291,9 @@
 (DEFSYSFUN 'NUMBERP "Lnumberp" '(T) 'T NIL T) 
 (DEFSYSFUN 'COPY-READTABLE "Lcopy_readtable" '(*) 'T NIL NIL) 
 (DEFSYSFUN 'RANDOM-STATE-P "Lrandom_state_p" '(T) 'T NIL T) 
-(DEFSYSFUN 'DIRECTORY-NAMESTRING "Ldirectory_namestring" '(T) 'STRING
-    NIL NIL) 
 (DEFSYSFUN 'STANDARD-CHAR-P "Lstandard_char_p" '(T) 'T NIL T) 
-(DEFSYSFUN 'TRUENAME "Ltruename" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'IDENTITY "Lidentity" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'NREVERSE "Lnreverse" '(T) 'T NIL NIL) 
-(DEFSYSFUN 'PATHNAME-DEVICE "Lpathname_device" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'UNINTERN "Lunintern" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'UNEXPORT "Lunexport" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'FLOAT-PRECISION "Lfloat_precision" '(T) 'FIXNUM NIL NIL) 
@@ -324,7 +304,7 @@
 (DEFSYSFUN 'READ-CHAR-NO-HANG "Lread_char_no_hang" '(*) 'T NIL NIL) 
 (DEFSYSFUN 'FRESH-LINE "Lfresh_line" '(*) 'T NIL NIL) 
 (DEFSYSFUN 'WRITE-CHAR "Lwrite_char" '(T *) 'T NIL NIL) 
-(DEFSYSFUN 'PARSE-NAMESTRING "Lparse_namestring" '(T *) 'T NIL NIL) 
+;(DEFSYSFUN 'PARSE-NAMESTRING "Lparse_namestring" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'STRING-NOT-LESSP "Lstring_not_lessp" '(T T *) 'T NIL NIL) 
 (DEFSYSFUN 'CHAR "Lchar" '(T T) 'CHARACTER NIL NIL) 
 (DEFSYSFUN 'AREF "Laref" '(T *) 'T NIL NIL) 
@@ -338,7 +318,6 @@
 (DEFSYSFUN 'DIGIT-CHAR-P "Ldigit_char_p" '(T *) 'T NIL NIL) 
 ;; #-clcs (DEFSYSFUN 'ERROR "Lerror" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'CHAR/= "Lchar_neq" '(T *) 'T NIL T) 
-(DEFSYSFUN 'PATHNAME-DIRECTORY "Lpathname_directory" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'CDAAAR "Lcdaaar" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'CADAAR "Lcadaar" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'CAADAR "Lcaadar" '(T) 'T NIL NIL) 
@@ -349,7 +328,6 @@
 (DEFSYSFUN 'FORMAT "Lformat" '(T T *) 'T NIL NIL) 
 (DEFSYSFUN 'COMPILED-FUNCTION-P "Lcompiled_function_p" '(T) 'T NIL T) 
 (DEFSYSFUN 'SUBLIS "Lsublis" '(T T *) 'T NIL NIL) 
-(DEFSYSFUN 'PATHNAME-NAME "Lpathname_name" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'IMPORT "Limport" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'LOGXOR "Llogxor" '(*) 'T NIL NIL) 
 (DEFSYSFUN 'RASSOC-IF-NOT "Lrassoc_if_not" '(T T) 'T NIL NIL) 
@@ -366,9 +344,7 @@
 (DEFSYSFUN 'GET-PROPERTIES "Lget_properties" '(T T) '* NIL NIL) 
 (DEFSYSFUN 'STRING<= "Lstring_le" '(T T *) 'T NIL NIL) 
 (DEFSYSFUN 'EVALHOOK "siLevalhook" '(T T T *) 'T NIL NIL) 
-(DEFSYSFUN 'FILE-WRITE-DATE "Lfile_write_date" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'LOGCOUNT "Llogcount" '(T) 'T NIL NIL) 
-(DEFSYSFUN 'MERGE-PATHNAMES "Lmerge_pathnames" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'MEMBER-IF "Lmember_if" '(T T *) 'T NIL NIL) 
 (DEFSYSFUN 'READ-BYTE "Lread_byte" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'SIMPLE-VECTOR-P "Lsimple_vector_p" '(T) 'T NIL T) 
@@ -381,10 +357,8 @@
 (DEFSYSFUN 'GET "Lget" '(T T *) 'T NIL NIL) 
 (DEFSYSFUN 'MOD "Lmod" '(T T) 'T NIL NIL) 
 (DEFSYSFUN 'DIGIT-CHAR "Ldigit_char" '(T *) 'CHARACTER NIL NIL) 
-(DEFSYSFUN 'PROBE-FILE "Lprobe_file" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'STRING-LEFT-TRIM "Lstring_left_trim" '(T T) 'STRING NIL
     NIL) 
-(DEFSYSFUN 'PATHNAME-VERSION "Lpathname_version" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'WRITE-LINE "Lwrite_line" '(T *) 'T NIL NIL) 
 (DEFSYSFUN 'EVAL "Leval" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'ATOM "Latom" '(T) 'T NIL T) 
--- gcl-2.6.12.orig/configure
+++ gcl-2.6.12/configure
@@ -4183,7 +4183,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
 #fi
 # subst GCC not only under 386-linux, but where available -- CM
 
-TCFLAGS="-fsigned-char"
+TCFLAGS="-fsigned-char -fno-builtin-malloc -fno-builtin-free"
 
 if test "$GCC" = "yes" ; then
 
--- gcl-2.6.12.orig/configure.in
+++ gcl-2.6.12/configure.in
@@ -483,7 +483,7 @@ AC_SUBST(CC)
 #fi
 # subst GCC not only under 386-linux, but where available -- CM
 
-TCFLAGS="-fsigned-char"
+TCFLAGS="-fsigned-char -fno-builtin-malloc -fno-builtin-free"
 
 if test "$GCC" = "yes" ; then
 
--- gcl-2.6.12.orig/h/att_ext.h
+++ gcl-2.6.12/h/att_ext.h
@@ -116,25 +116,14 @@ float object_to_float();
 double object_to_double();
 
 /*  error.c  */
-EXTER object sKerror;
-EXTER object sKwrong_type_argument;
 EXTER object sKcatch;
 EXTER object sKprotect;
 EXTER object sKcatchall;
-EXTER object sKtoo_few_arguments;
-EXTER object sKtoo_many_arguments;
-EXTER object sKunexpected_keyword;
-EXTER object sKinvalid_form;
-EXTER object sKunbound_variable;
-EXTER object sKinvalid_variable;
-EXTER object sKundefined_function;
-EXTER object sKinvalid_function;
 EXTER object sKdatum;
 EXTER object sKexpected_type;
 EXTER object sKpackage;
 EXTER object sKformat_control;
 EXTER object sKformat_arguments;
-EXTER object sKpackage_error;
 object wrong_type_argument();
 EXTER object sSuniversal_error_handler;
 
@@ -394,10 +383,11 @@ EXTER object sKname;
 EXTER object sKtype;
 EXTER object sKversion;
 EXTER object sKdefaults;
-EXTER object sKroot;
-EXTER object sKcurrent;
-EXTER object sKparent;
-EXTER object sKper;
+
+EXTER object sKabsolute;
+EXTER object sKrelative;
+EXTER object sKup;
+
 /* object parse_namestring(); */
 object coerce_to_pathname();
 /* object default_device(); */
--- gcl-2.6.12.orig/h/compdefs.h
+++ gcl-2.6.12/h/compdefs.h
@@ -115,3 +115,5 @@ SIGNED_CHAR(x)
 FEerror(x,y...)
 FEwrong_type_argument(x,y)
 BIT_ENDIAN(x)
+pathname_designatorp(x)
+pathnamep(x)
--- gcl-2.6.12.orig/h/error.h
+++ gcl-2.6.12/h/error.h
@@ -22,6 +22,7 @@ PFN(numberp)
 PFN(characterp)
 PFN(symbolp)
 PFN(stringp)
+PFN(pathnamep)
 PFN(string_symbolp)
 PFN(packagep)
 PFN(consp)
@@ -52,6 +53,7 @@ PFN(functionp)
 #define check_type_character(a_)                        TPE(a_,characterp_fn,sLcharacter)
 #define check_type_sym(a_)                              TPE(a_,symbolp_fn,sLsymbol)
 #define check_type_string(a_)                           TPE(a_,stringp_fn,sLstring)
+#define check_type_pathname(a_)                         TPE(a_,pathnamep_fn,sLpathname)
 #define check_type_or_string_symbol(a_)                 TPE(a_,string_symbolp_fn,TSor_symbol_string)
 #define check_type_or_symbol_string(a_)                 TPE(a_,string_symbolp_fn,TSor_symbol_string)
 #define check_type_or_pathname_string_symbol_stream(a_) TPE(a_,pathname_string_symbol_streamp_fn,TSor_pathname_string_symbol_stream)
@@ -79,12 +81,6 @@ PFN(functionp)
                             set_type_of((a_),t_fixnum);\
                             (a_)->FIX.FIXVAL=(b_);}
 
-/*FIXME the stack stuff is dangerous It works for error handling, but
-  simple errors may evan pass the format tring up the stack as a slot
-  in ansi*/
-/* #define TYPE_ERROR(a_,b_) {stack_string(tp_err,"~S is not of type ~S.");\ */
-/*                            Icall_error_handler(sKwrong_type_argument,tp_err,2,(a_),(b_));} */
-
 object ihs_top_function_name(ihs_ptr h);
 #define FEerror(a_,b_...)   Icall_error_handler(sLerror,null_string,\
                             4,sKformat_control,make_simple_string(a_),sKformat_arguments,list(b_))
--- gcl-2.6.12.orig/h/lu.h
+++ gcl-2.6.12/h/lu.h
@@ -301,7 +301,7 @@ struct pathname {
   object pn_name;
   object pn_type;
   object pn_version;
-  SPAD;
+  object pn_namestring;
 };
 
 struct cfun {
--- gcl-2.6.12.orig/h/notcomp.h
+++ gcl-2.6.12/h/notcomp.h
@@ -47,12 +47,6 @@ EXTER object user_package;
 			 else *__p++ = va_arg(ap,object);} \
   va_end(ap)
 
-/*  #undef endp */
-
-/*  #define	endp(obje)	((enum type)((endp_temp = (obje))->d.t) == t_cons ? \ */
-/*  			 FALSE : endp_temp == Cnil ? TRUE : \ */
-/*  			 endp1(endp_temp)) */
-
 #ifndef NO_DEFUN
 #undef DEFUN
 #define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,doc) ret fname
@@ -234,7 +228,7 @@ EXTER  bool left_trim;
 EXTER bool right_trim;
 int  (*casefun)();
 
-#define	Q_SIZE		128
+#define	Q_SIZE		256
 #define IS_SIZE		256
 
 struct printStruct {
@@ -300,6 +294,8 @@ gcl_init_cmp_anon(void);
 
 #include "gmp_wrappers.h"
 
+char FN1[PATH_MAX],FN2[PATH_MAX],FN3[PATH_MAX],FN4[PATH_MAX],FN5[PATH_MAX];
+
 #include <errno.h>
 #define massert(a_) ({errno=0;if (!(a_)||errno) assert_error(#a_,__LINE__,__FILE__,__FUNCTION__);})
 
--- gcl-2.6.12.orig/h/object.h
+++ gcl-2.6.12/h/object.h
@@ -163,24 +163,6 @@ enum aelttype {			/*  array element type
 #define STREF(type,x,i) (*((type *)(((char *)((x)->str.str_self))+(i))))
 #define STSET(type,x,i,val)  do{SGC_TOUCH(x);STREF(type,x,i) = (val);} while(0)
 
-
-
-enum smmode {			/*  stream mode  */
-	smm_input,		/*  input  */
-	smm_output,		/*  output  */
-	smm_io,			/*  input-output  */
-	smm_probe,		/*  probe  */
-	smm_synonym,		/*  synonym  */
-	smm_broadcast,		/*  broadcast  */
-	smm_concatenated,	/*  concatenated  */
-	smm_two_way,		/*  two way  */
-	smm_echo,		/*  echo  */
-	smm_string_input,	/*  string input  */
-	smm_string_output,	/*  string output  */
-	smm_user_defined,        /*  for user defined */
-	smm_socket		/*  Socket stream  */
-};
-
 /* for any stream that takes writec_char, directly (not two_way or echo)
    ie. 	 smm_output,smm_io, smm_string_output, smm_socket
  */
@@ -217,9 +199,9 @@ enum gcl_sm_flags {
   gcl_sm_tcp_async,
   gcl_sm_input,
   gcl_sm_output,
+  gcl_sm_closed,
   gcl_sm_had_error
   
-  
 };
 
 enum chattrib {			/*  character attribute  */
@@ -496,8 +478,11 @@ object make_si_sfun();
  Used by the C function to set optionals */
 
 #define  VFUN_NARGS fcall.argd
+#define RETURN4(x,y,z,w) do{/*  object _x = (void *) x;  */   \
+			  fcall.values[1]=y;fcall.values[2]=z;fcall.values[3]=w;fcall.nvalues=4; \
+			  return (x) ;} while(0)
 #define RETURN2(x,y) do{/*  object _x = (void *) x;  */\
-			  fcall.values[2]=y;fcall.nvalues=2; \
+			  fcall.values[1]=y;fcall.nvalues=2; \
 			  return (x) ;} while(0)
 #define RETURN1(x) do{fcall.nvalues=1; return (x) ;} while(0)
 #define RETURN0  do{fcall.nvalues=0; return Cnil ;} while(0)
--- gcl-2.6.12.orig/h/protoize.h
+++ gcl-2.6.12/h/protoize.h
@@ -88,7 +88,7 @@
 /* big.c:85:OF */ extern void zero_big (object x); /* (x) object x; */
 /* bind.c:74:OF */ extern void lambda_bind (object *arg_top); /* (arg_top) object *arg_top; */
 /* bind.c:564:OF */ extern void bind_var (object var, object val, object spp); /* (var, val, spp) object var; object val; object spp; */
-/* bind.c:610:OF */ extern object find_special (object body, struct bind_temp *start, struct bind_temp *end); /* (body, start, end) object body; struct bind_temp *start; struct bind_temp *end; */
+/* bind.c:610:OF */ extern object find_special (object body, struct bind_temp *start, struct bind_temp *end,object *s); /* (body, start, end) object body; struct bind_temp *start; struct bind_temp *end; */
 /* bind.c:670:OF */ extern object let_bind (object body, struct bind_temp *start, struct bind_temp *end); /* (body, start, end) object body; struct bind_temp *start; struct bind_temp *end; */
 /* bind.c:688:OF */ extern object letA_bind (object body, struct bind_temp *start, struct bind_temp *end); /* (body, start, end) object body; struct bind_temp *start; struct bind_temp *end; */
 /* bind.c:712:OF */ extern void parse_key (object *base, bool rest, bool allow_other_keys, register int n, ... ); 
--- gcl-2.6.12.orig/h/type.h
+++ gcl-2.6.12/h/type.h
@@ -7,6 +7,7 @@ enum type {
   t_shortfloat,
   t_longfloat,
   t_complex,
+  t_stream,
   t_pathname,
   t_string,
   t_bitvector,
@@ -17,7 +18,6 @@ enum type {
   t_character,
   t_symbol,
   t_package,
-  t_stream,
   t_random,
   t_readtable,
   t_cfun,
@@ -36,6 +36,23 @@ enum type {
 };
 
 
+enum smmode {			/*  stream mode  */
+	smm_input,		/*  input  */
+	smm_output,		/*  output  */
+	smm_io,			/*  input-output  */
+	smm_probe,		/*  probe  */
+	smm_file_synonym,	/*  synonym stream to file_stream  */
+	smm_synonym,		/*  synonym  */
+	smm_broadcast,		/*  broadcast  */
+	smm_concatenated,	/*  concatenated  */
+	smm_two_way,		/*  two way  */
+	smm_echo,		/*  echo  */
+	smm_string_input,	/*  string input  */
+	smm_string_output,	/*  string output  */
+	smm_user_defined,        /*  for user defined */
+	smm_socket		/*  Socket stream  */
+};
+
 #define Zcdr(a_)                 (*(object *)(a_))/* ((a_)->c.c_cdr) */ /*FIXME*/
 
 #ifndef WIDE_CONS
@@ -82,7 +99,7 @@ enum type {
 #else
 #define TYPEWORD_TYPE_P(y_) (y_!=t_cons)
 #endif
-  
+
 /*Note preserve sgc flag here                                         VVV*/
 #define set_type_of(x,y) ({object _x=(object)(x);enum type _y=(y);_x->d.f=0;\
     if (TYPEWORD_TYPE_P(_y)) {_x->d.e=1;_x->d.t=_y;_x->fw|=(fixnum)OBJNULL;}})
@@ -113,6 +130,7 @@ enum type {
 #define randomp(a_)    SPP(a_,random)
 #define characterp(a_) SPP(a_,character)
 #define symbolp(a_)    SPP(a_,symbol)
+#define pathnamep(a_)  SPP(a_,pathname)
 #define stringp(a_)    SPP(a_,string)
 #define fixnump(a_)    SPP(a_,fixnum)
 #define readtablep(a_) SPP(a_,readtable)
@@ -133,3 +151,6 @@ enum type {
                                                                      || _tp == t_symbol;})
 #define pathname_string_symbol_streamp(a_) ({enum type _tp=type_of(a_); _tp==t_pathname || _tp == t_string\
                                                                      || _tp == t_symbol || _tp==t_stream;})
+
+#define pathname_designatorp(a_) ({object _a=(a_);enum type _tp=type_of(a_);\
+      _tp==t_pathname||_tp==t_string||(_tp==t_stream && _a->sm.sm_mode>=smm_input && _a->sm.sm_mode<=smm_file_synonym);})
--- gcl-2.6.12.orig/lsp/gcl_autoload.lsp
+++ gcl-2.6.12/lsp/gcl_autoload.lsp
@@ -410,10 +410,3 @@ Good luck!				 The GCL Development Team"
 (setf (get 'with-open-file 'si:pretty-print-format) 1)
 (setf (get 'with-open-stream 'si:pretty-print-format) 1)
 (setf (get 'with-output-to-string 'si:pretty-print-format) 1)
-
-
-(in-package :si)
-
-(defvar *lib-directory* (namestring (truename "../")))
-
-(import '(*lib-directory* *load-path* *system-directory*) :user) 
--- /dev/null
+++ gcl-2.6.12/lsp/gcl_directory.lsp
@@ -0,0 +1,67 @@
+(in-package :si)
+
+(defconstant +d-type-alist+ (d-type-list))
+
+(defun ?push (x tp)
+  (when (and x (eq tp :directory)) (vector-push-extend #\/ x))
+  x)
+
+(defun wreaddir (x s &optional y (ls (length s) lsp) &aux (y (if (rassoc y +d-type-alist+) y :unknown)))
+  (when lsp (setf (fill-pointer s) ls))
+  (let ((r (readdir x (car (rassoc y +d-type-alist+)) s)))
+    (typecase r
+      (fixnum (wreaddir x (adjust-array s (+ 100 (ash (array-dimension s 0) 1))) y))
+      (cons (let ((tp (cdr (assoc (cdr r) +d-type-alist+)))) (cons (?push (car r) tp) tp)))
+      (otherwise (?push r y)))))
+
+(defun dot-dir-p (r l) (member-if (lambda (x) (string= x r :start2 l)) '("./" "../")))
+
+(defun vector-push-string (x s &optional (ss 0) (lx (length x)) &aux (ls (- (length s) ss)))
+  (let ((x (if (> ls (- (array-dimension x 0) lx)) (adjust-array x (+ ls (ash lx 1))) x)))
+    (setf (fill-pointer x) (+ lx ls))
+    (replace x s :start1 lx :start2 ss)))
+
+(defun walk-dir (s e f &optional (y :unknown) (d (opendir s)) (l (length s)) (le (length e))
+		   &aux (r (wreaddir d s y l)))
+  (cond (r (unless (dot-dir-p r l) (funcall f r (vector-push-string e r l le) l))
+	   (walk-dir s e f y d l le))
+	((setf (fill-pointer s) l (fill-pointer e) le) (closedir d))))
+
+(defun recurse-dir (x y f)
+  (funcall f x y)
+  (walk-dir x y (lambda (x y l) (declare (ignore l)) (recurse-dir x y f)) :directory))
+
+(defun make-frame (s &aux (l (length s)))
+  (replace (make-array l :element-type 'character :adjustable t :fill-pointer l) s))
+
+(defun expand-wild-directory (l f zz &optional (yy (make-frame zz)))
+  (let* ((x (member-if 'wild-dir-element-p l))
+	 (s (namestring (make-pathname :directory (ldiff l x))))
+	 (z (vector-push-string zz s))
+	 (l (length yy))
+	 (y (link-expand (vector-push-string yy s) l))
+	 (y (if (eq y yy) y (make-frame y))))
+    (when (or (eq (stat z) :directory) (zerop (length z)))
+      (cond ((eq (car x) :wild-inferiors) (recurse-dir z y f))
+	    (x (walk-dir z y (lambda (q e l)
+			       (declare (ignore l))
+			       (expand-wild-directory (cons :relative (cdr x)) f q e)) :directory));FIXME
+	    ((funcall f z y))))))
+
+(defun directory (p &key &aux (p (translate-logical-pathname p))(d (pathname-directory p))
+		    (c (unless (eq (car d) :absolute) (make-frame (concatenate 'string (getcwd) "/"))))
+		    (lc (when c (length c)))
+		    (filesp (or (pathname-name p) (pathname-type p)))
+		    (v (compile-regexp (to-regexp p)))(*up-key* :back) r)
+  (expand-wild-directory d
+   (lambda (dir exp &aux (pexp (pathname (if c (vector-push-string c exp 0 lc) exp))))
+     (if filesp
+	 (walk-dir dir exp
+		   (lambda (dir exp pos)
+		     (declare (ignore exp))
+		     (when (pathname-match-p dir v)
+		       (push (merge-pathnames (parse-namestring dir nil *default-pathname-defaults* :start pos) pexp nil) r)))
+		   :file)
+       (when (pathname-match-p dir v) (push pexp r))))
+   (make-frame (if c "./" "")))
+  r)
--- gcl-2.6.12.orig/lsp/gcl_fpe.lsp
+++ gcl-2.6.12/lsp/gcl_fpe.lsp
@@ -60,7 +60,7 @@
 
 
 (defun rf (addr w)
-  (ecase w (4 (*float addr)) (8 (*double addr))))
+  (ecase w (4 (*float addr 0 nil nil)) (8 (*double addr 0 nil nil))))
 
 (defun ref (addr p w &aux (i -1)) 
   (if p 
@@ -71,7 +71,7 @@
 		  (f (eql #\F (aref z 0))))
   (ref addr (unless f (eql (aref z (- lz 2)) #\P)) (if (or f (eql (aref z (1- lz)) #\D)) 8 4)))
 
-(defun reg-lookup (x) (*fixnum (+ (car *context*) (symbol-value x))))
+(defun reg-lookup (x) (*fixnum (+ (car *context*) (symbol-value x)) 0 nil nil))
 
 (defun st-lookup (x) (fld (+ (cadr *context*) (symbol-value x))))
 (defun xmm-lookup (x) (gref (+ (caddr *context*) (symbol-value x))))
--- gcl-2.6.12.orig/lsp/gcl_fpe_test.lsp
+++ gcl-2.6.12/lsp/gcl_fpe_test.lsp
@@ -1,6 +1,6 @@
-#.`(defun test-fpe (f a r &optional chk &aux cc (o (mapcan (lambda (x) (list x t)) (si::break-on-floating-point-exceptions))))
+#.`(defun test-fpe (f a r &optional chk &aux cc (o (mapcan (lambda (x) (list x t)) (break-on-floating-point-exceptions))))
      (flet ((set-break (x) (when (keywordp r)
-			     (apply 'si::break-on-floating-point-exceptions (append (unless x o) (list r x))))))
+			     (apply 'break-on-floating-point-exceptions (append (unless x o) (list r x))))))
        (let* ((rr (handler-case (unwind-protect (progn (set-break t) (apply f a)) (set-break nil))
 				,@(mapcar (lambda (x &aux (x (car x))) `(,x (c) (setq cc c) ,(intern (symbol-name x) :keyword)))
 					  (append si::+fe-list+ '((arithmetic-error)(error)))))))
--- gcl-2.6.12.orig/lsp/gcl_info.lsp
+++ gcl-2.6.12/lsp/gcl_info.lsp
@@ -8,28 +8,6 @@
 	 (,op (the fixnum ,x) (the fixnum ,y))))
 (defmacro fcr (x) `(load-time-value (compile-regexp ,x))))
 
-(eval-when (compile eval load)
-(defun sharp-u-reader (stream subchar arg)
-  subchar arg
-  (let ((tem (make-array 10 :element-type 'character :fill-pointer 0)))
-    (or (eql (read-char stream) #\")
-	(error "sharp-u-reader reader needs a \" right after it"))
-    (loop
-     (let ((ch (read-char stream)))
-       (cond ((eql ch #\") (return tem))
-	     ((eql ch #\\)
-	      (setq ch (read-char stream))
-	      (setq ch (or (cdr (assoc ch '((#\n . #\newline)
-					    (#\t . #\tab)
-					    (#\r . #\return))))
-			   ch))))
-       (vector-push-extend ch tem)))
-    tem))
-
-(set-dispatch-macro-character #\# #\u 'sharp-u-reader)
-
-)
-
 (defconstant +crlu+ (compile-regexp #u""))
 (defconstant +crnp+ (compile-regexp #u"[]"))
 
--- gcl-2.6.12.orig/lsp/gcl_iolib.lsp
+++ gcl-2.6.12/lsp/gcl_iolib.lsp
@@ -1,3 +1,4 @@
+;; -*-Lisp-*-
 ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
 
 ;; This file is part of GNU Common Lisp, herein referred to as GCL
@@ -24,130 +25,229 @@
 
 (in-package :si)
 
-(proclaim '(optimize (safety 2) (space 3)))
+(defun concatenated-stream-streams (stream)
+  (declare (optimize (safety 2)))
+  (check-type stream concatenated-stream)
+  (c-stream-object0 stream))
+(defun broadcast-stream-streams (stream)
+  (declare (optimize (safety 2)))
+  (check-type stream broadcast-stream)
+  (c-stream-object0 stream))
+(defun two-way-stream-input-stream (stream)
+  (declare (optimize (safety 2)))
+  (check-type stream two-way-stream)
+  (c-stream-object0 stream))
+(defun echo-stream-input-stream (stream)
+  (declare (optimize (safety 2)))
+  (check-type stream echo-stream)
+  (c-stream-object0 stream))
+(defun two-way-stream-output-stream (stream)
+  (declare (optimize (safety 2)))
+  (check-type stream two-way-stream)
+  (c-stream-object1 stream))
+(defun echo-stream-output-stream (stream)
+  (declare (optimize (safety 2)))
+  (check-type stream echo-stream)
+  (c-stream-object1 stream))
+(defun synonym-stream-symbol (stream)
+  (declare (optimize (safety 2)))
+  (check-type stream synonym-stream)
+  (c-stream-object0 stream))
 
+(defun maybe-clear-input (&optional (x *standard-input*))
+  (typecase x
+    (synonym-stream (maybe-clear-input (symbol-value (synonym-stream-symbol x))))
+    (two-way-stream (maybe-clear-input (two-way-stream-input-stream x)))
+    (stream (when (terminal-input-stream-p x) (clear-input t)))))
 
 (defmacro with-open-stream ((var stream) . body)
-  (multiple-value-bind (ds b)
-      (find-declarations body)
+  (declare (optimize (safety 1)))
+  (multiple-value-bind (ds b) (find-declarations body)
     `(let ((,var ,stream))
        ,@ds
        (unwind-protect
-         (progn ,@b)
+	   (progn ,@b)
          (close ,var)))))
 
-
 (defmacro with-input-from-string ((var string &key index start end) . body)
-  (let ((x (sgen "X")))
-    (multiple-value-bind (ds b)
-	(find-declarations body)
-      `(let ((,var (make-string-input-stream ,string ,start ,end)))
-	 ,@ds
-	 (unwind-protect
-	     ,(let ((f `(progn ,@b)))
-		(if index
-		    `(let ((,x (multiple-value-list ,f))) (setf ,index (get-string-input-stream-index ,var)) (values-list ,x))
-		  f))
-	 (close ,var))))))
+  (declare (optimize (safety 1)))
+  (multiple-value-bind (ds b) (find-declarations body)
+    `(let ((,var (make-string-input-stream ,string ,start ,end)))
+       ,@ds
+       (unwind-protect
+	   (multiple-value-prog1
+	    (progn ,@b)
+	    ,@(when index `((setf ,index (get-string-input-stream-index ,var)))))
+	 (close ,var)))))
   
 (defmacro with-output-to-string ((var &optional string &key element-type) . body)
-  (let ((s (sgen "STRING"))(bl (sgen "BLOCK"))(e (sgen "ELEMENT-TYPE"))(x (sgen "X")))
-    (multiple-value-bind (ds b)
-	(find-declarations body)
-      `(let* ((,s ,string)(,e ,element-type)
-	      (,var (if ,s (make-string-output-stream-from-string ,s) (make-string-output-stream :element-type ,e))))
+  (declare (optimize (safety 1)))
+  (let ((s (sgen "STRING")))
+    (multiple-value-bind (ds b) (find-declarations body)
+      `(let* ((,s ,string)
+	      (,var (if ,s (make-string-output-stream-from-string ,s) (make-string-output-stream :element-type ,element-type))))
 	 ,@ds
 	 (unwind-protect
-	     (let ((,x (multiple-value-list (progn ,@b)))) (if ,s (values-list ,x) (get-output-stream-string ,var)))
+	     (block nil
+	       (multiple-value-prog1
+		(progn ,@b)
+	      (unless ,s (return (get-output-stream-string ,var)))))
 	   (close ,var))))))
 
 
-(defun read-from-string (string
-                         &optional (eof-error-p t) eof-value
-                         &key (start 0) (end (length string))
-                              preserve-whitespace)
-  (let ((stream (make-string-input-stream string start end)))
-    (if preserve-whitespace
-        (values (read-preserving-whitespace stream eof-error-p eof-value)
-                (si:get-string-input-stream-index stream))
-        (values (read stream eof-error-p eof-value)
-                (si:get-string-input-stream-index stream)))))
-
+(defun read-from-string (string &optional (eof-error-p t) eof-value
+                         &key (start 0) end preserve-whitespace)
+  (declare (optimize (safety 1)))
+  (check-type string string)
+  (check-type start seqind)
+  (check-type end (or null seqind))
+  (let ((stream (make-string-input-stream string start (or end (length string)))))
+    (values (if preserve-whitespace
+		(read-preserving-whitespace stream eof-error-p eof-value)
+	      (read stream eof-error-p eof-value))
+	    (get-string-input-stream-index stream))))
+
+;; (defun write (x &key stream
+;; 		(array            *print-array*)
+;; 		(base             *print-base*)
+;; 		(case             *print-case*)
+;; 		(circle           *print-circle*)
+;; 		(escape           *print-escape*)
+;; 		(gensym           *print-gensym*)
+;; 		(length           *print-length*)
+;; 		(level            *print-level*)
+;; 		(lines            *print-lines*)
+;; 		(miser-width      *print-miser-width*)
+;; 		(pprint-dispatch  *print-pprint-dispatch*)
+;; 		(pretty           *print-pretty*)
+;; 		(radix            *print-radix*)
+;; 		(readably         *print-readably*)
+;; 		(right-margin     *print-right-margin*))
+;;   (write-int x stream array base case circle escape gensym
+;; 	     length level lines miser-width pprint-dispatch
+;; 	     pretty radix readably right-margin))
 
 (defun write-to-string (object &rest rest
-                        &key escape radix base
-                             circle pretty level length
-                             case gensym array
-                        &aux (stream (make-string-output-stream)))
-  (declare (ignore escape radix base
-                   circle pretty level length
-                   case gensym array))
+			       &key (escape *print-escape*)(radix *print-radix*)(base *print-base*)
+			       (circle *print-circle*)(pretty *print-pretty*)(level *print-level*)
+			       (length *print-length*)(case *print-case*)(gensym *print-gensym*)
+			       (array *print-array*)(lines *print-lines*)(miser-width *print-miser-width*)
+			       (pprint-dispatch *print-pprint-dispatch*)(readably *print-readably*)
+			       (right-margin *print-right-margin*)
+			       &aux (stream (make-string-output-stream))
+			       (*print-escape* escape)(*print-radix* radix)(*print-base* base)
+			       (*print-circle* circle)(*print-pretty* pretty)(*print-level* level)
+			       (*print-length* length)(*print-case* case)(*print-gensym* gensym)
+			       (*print-array* array)(*print-lines* lines)(*print-miser-width* miser-width)
+			       (*print-pprint-dispatch* pprint-dispatch)(*print-readably* readably )
+			       (*print-right-margin* right-margin))
+  (declare (optimize (safety 1))(dynamic-extent rest))
   (apply #'write object :stream stream rest)
   (get-output-stream-string stream))
 
+(defun prin1-to-string (object &aux (stream (make-string-output-stream)))
+  (declare (optimize (safety 1)))
+  (prin1 object stream)
+  (get-output-stream-string stream))
 
-(defun prin1-to-string (object
-                        &aux (stream (make-string-output-stream)))
-   (prin1 object stream)
-   (get-output-stream-string stream))
-
-
-(defun princ-to-string (object
-                        &aux (stream (make-string-output-stream)))
+(defun princ-to-string (object &aux (stream (make-string-output-stream)))
+  (declare (optimize (safety 1)))
   (princ object stream)
   (get-output-stream-string stream))
 
+;; (defun file-string-length (ostream object)
+;;   (declare (optimize (safety 2)))
+;;   (let ((ostream (if (typep ostream 'broadcast-stream)
+;; 		     (car (last (broadcast-stream-streams ostream)))
+;; 		   ostream)))
+;;     (cond ((not ostream) 1)
+;; 	  ((subtypep1 (stream-element-type ostream) 'character)
+;; 	   (length (let ((*print-escape* nil)) (write-to-string object)))))))
+
+;; (defmacro with-temp-file ((s pn) (tmp ext) &rest body)
+;;   (multiple-value-bind
+;;    (doc decls ctps body)
+;;    (parse-body-header body)
+;;    (declare (ignore doc))
+;;    `(let* ((,s (temp-stream ,tmp ,ext))
+;; 	   (,pn (stream-object1 ,s)))
+;;       ,@decls
+;;       ,@ctps
+;;       (unwind-protect (progn ,@body) (progn (close ,s) (delete-file ,s))))))
+
 
 (defmacro with-open-file ((stream . filespec) . body)
-  (multiple-value-bind (ds b)
-      (find-declarations body)
+  (declare (optimize (safety 1)))
+  (multiple-value-bind (ds b) (find-declarations body)
     `(let ((,stream (open ,@filespec)))
        ,@ds
        (unwind-protect
-         (progn ,@b)
-         (if ,stream (close ,stream))))))
+	   (progn ,@b)
+         (when ,stream (close ,stream))))))
 
+;; (defun pprint-dispatch (obj &optional (table *print-pprint-dispatch*))
+;;   (declare (optimize (safety 2)))
+;;   (let ((fun (si:get-pprint-dispatch obj table)))
+;;     (if fun (values fun t) (values 'si:default-pprint-object nil))))
+
+;; (setq *print-pprint-dispatch* '(pprint-dispatch . nil))
+
+;; (defun set-pprint-dispatch (type-spec function &optional
+;; 			    (priority 0)
+;; 			    (table *print-pprint-dispatch*))
+;;   (declare (optimize (safety 2)))
+;;   (unless (typep priority 'real)
+;;     (error 'type-error :datum priority :expected-type 'real))
+;;   (let ((a (assoc type-spec (cdr table) :test 'equal)))
+;;     (if a (setf (cdr a) (list function priority))
+;; 	(rplacd (last table) `((,type-spec ,function ,priority)))))
+;;   nil)
+
+;; (defun copy-pprint-dispatch (&optional table)
+;;   (declare (optimize (safety 2)))
+;;   (unless table
+;;     (setq table *print-pprint-dispatch*))
+;;   (unless (and (eq (type-of table) 'cons)
+;;   	(eq (car table) 'pprint-dispatch))
+;;     (error 'type-error :datum table :expected-type 'pprint-dispatch))
+;;   (copy-seq table ))
 
-(defun y-or-n-p (&optional string &rest args)
-  (do ((reply))
-      (nil)
-    (when string (format *query-io* "~&~?  (Y or N) " string args))
-    (setq reply (read *query-io*))
-    (cond ((string-equal (symbol-name reply) "Y")
-           (return-from y-or-n-p t))
-          ((string-equal (symbol-name reply) "N")
-           (return-from y-or-n-p nil)))))
 
+(defun y-or-n-p (&optional string &rest args)
+  (declare (optimize (safety 1)))
+  (when string (format *query-io* "~&~?  (Y or N) " string args))
+  (let ((reply (symbol-name (read *query-io*))))
+    (cond ((string-equal reply "Y") t)
+	  ((string-equal reply "N") nil)
+	  ((apply 'y-or-n-p string args)))))
 
 (defun yes-or-no-p (&optional string &rest args)
-  (do ((reply))
-      (nil)
-    (when string (format *query-io* "~&~?  (Yes or No) " string args))
-    (setq reply (read *query-io*))
-    (cond ((string-equal (symbol-name reply) "YES")
-           (return-from yes-or-no-p t))
-          ((string-equal (symbol-name reply) "NO")
-           (return-from yes-or-no-p nil)))))
-
+  (declare (optimize (safety 1)))
+  (when string (format *query-io* "~&~?  (Yes or No) " string args))
+  (let ((reply (symbol-name (read *query-io*))))
+    (cond ((string-equal reply "YES") t)
+	  ((string-equal reply "NO") nil)
+	  ((apply 'yes-or-no-p string args)))))
 
 (defun sharp-a-reader (stream subchar arg)
   (declare (ignore subchar))
   (let ((initial-contents (read stream nil nil t)))
-    (if *read-suppress*
-        nil
-        (do ((i 0 (1+ i))
-             (d nil (cons (length ic) d))
-             (ic initial-contents (if (zerop (length ic)) ic (elt ic 0))))
-            ((>= i arg)
-             (make-array (nreverse d)
-                         :initial-contents initial-contents))))))
+    (unless *read-suppress*
+      (do ((i 0 (1+ i))
+	   (d nil (cons (length ic) d))
+	   (ic initial-contents (if (zerop (length ic)) ic (elt ic 0))))
+	  ((>= i arg) (make-array (nreverse d) :initial-contents initial-contents))))))
 
 (set-dispatch-macro-character #\# #\a 'sharp-a-reader)
+(set-dispatch-macro-character #\# #\a 'sharp-a-reader (standard-readtable))
 (set-dispatch-macro-character #\# #\A 'sharp-a-reader)
+(set-dispatch-macro-character #\# #\A 'sharp-a-reader (standard-readtable))
 
 ;; defined in defstruct.lsp
 (set-dispatch-macro-character #\# #\s 'sharp-s-reader)
+(set-dispatch-macro-character #\# #\s 'sharp-s-reader (standard-readtable))
 (set-dispatch-macro-character #\# #\S 'sharp-s-reader)
+(set-dispatch-macro-character #\# #\S 'sharp-s-reader (standard-readtable))
 
 (defvar *dribble-stream* nil)
 (defvar *dribble-io* nil)
@@ -155,6 +255,7 @@
 (defvar *dribble-saved-terminal-io* nil)
 
 (defun dribble (&optional (pathname "DRIBBLE.LOG" psp) (f :supersede))
+  (declare (optimize (safety 1)))
   (cond ((not psp)
          (when (null *dribble-stream*) (error "Not in dribble."))
          (if (eq *dribble-io* *terminal-io*)
@@ -183,73 +284,18 @@
              (format t "~&Starts dribbling to ~A (~d/~d/~d, ~d:~d:~d)."
                      namestring year month day hour min sec))))))
 
-(defconstant char-length 8)
-
-(defun get-byte-stream-nchars (s)
-  (check-type s stream)
-  (let* ((tp (stream-element-type s))
-	 (tp (if (consp tp) (cadr tp) char-length))
-	 (nc (ceiling tp char-length)))
-    nc))
-
-(defun write-byte (j s)
-  (declare (optimize (safety 1)))
-  (let ((nc (get-byte-stream-nchars s))
-	(ff (1- (expt 2 char-length))))
-    (do ((k 0 (1+ k))(i j (ash i (- char-length)))) ((>= k nc) j)
-	(write-char (code-char (logand i ff)) s))))
-
-(defun read-byte (s &optional (eof-error-p t) eof-value)
-  (declare (optimize (safety 1)))
-  (let ((nc (get-byte-stream-nchars s)))
-    (do ((j 0 (1+ j)) 
-	 (i 0 (logior i
-	       (ash (char-code (let ((ch (read-char s eof-error-p eof-value)))
-				 (if (and (not eof-error-p) (eq ch eof-value))
-				     (return-from read-byte ch)
-				   ch))) (* j char-length)))))
-	((>= j nc) i))))
-
-
-(defun read-sequence (seq strm &key (start 0) end)
-  (declare (optimize (safety 1)))
-  (check-type seq sequence)
-  (check-type start (integer 0))
-  (check-type end (or null (integer 0)))
-  (let* ((start (min start array-dimension-limit))
-	 (end   (if end (min end array-dimension-limit) (length seq)))
-	 (l (listp seq))
-	 (seq (if (and l (> start 0)) (nthcdr start seq) seq))
-	 (tp (subtypep (stream-element-type strm) 'character)))
-    (do ((i start (1+ i))(seq seq (if l (cdr seq) seq)))
-	((or (>= i end) (when l (endp seq))) i)
-	(declare (fixnum i))
-	(let ((el (if tp (read-char strm nil 'eof) (read-byte strm nil 'eof))))
-	  (when (eq el 'eof) (return i))
-	  (if l (setf (car seq) el) (setf (aref seq i) el))))))
-
+;; (defmacro formatter ( control-string )
+;;   (declare (optimize (safety 2)))
+;;   `(progn
+;;      (lambda (*standard-output* &rest arguments)
+;;        (let ((*format-unused-args* nil))
+;; 	 (apply 'format t ,control-string arguments)
+;; 	 *format-unused-args*))))
 
-(defun write-sequence (seq strm &key (start 0) end)
+(defun stream-external-format (s)
   (declare (optimize (safety 1)))
-  (check-type seq sequence)
-  (check-type start (integer 0))
-  (check-type end (or null (integer 0)))
-  (let* ((start (min start array-dimension-limit))
-	 (end   (if end (min end array-dimension-limit) (length seq)))
-	 (l (listp seq))
-	 (tp (subtypep (stream-element-type strm) 'character)))
-    (do ((i start (1+ i))
-	 (seq (if (and l (> start 0)) (nthcdr start seq) seq) (if l (cdr seq) seq))) 
-	((or (>= i end) (when l (endp seq)))) 
-	(declare (fixnum i))
-	(let ((el (if l (car seq) (aref seq i))))
-	  (if tp (write-char el strm) (write-byte el strm))))
-    seq))
-
-(defmacro with-compilation-unit (opt &rest body)   
-  (declare (optimize (safety 2)))
-  (declare (ignore opt)) 
-  `(progn ,@body))
+  (check-type s stream)
+  :default)
 
 (defvar *print-lines* nil)
 (defvar *print-miser-width* nil)
@@ -257,7 +303,7 @@
 (defvar *print-right-margin* nil)
 
 (defmacro with-standard-io-syntax (&body body)
-  (declare (optimize (safety 2)))
+  (declare (optimize (safety 1)))
   `(let* ((*package* (find-package :cl-user))
 	  (*print-array* t)
 	  (*print-base* 10)
@@ -269,7 +315,7 @@
 	  (*print-level* nil)
 	  (*print-lines* nil)
 	  (*print-miser-width* nil)
-	  (*print-pprint-dispatch* *print-pprint-dispatch*)
+	  (*print-pprint-dispatch* *print-pprint-dispatch*);FIXME
 	  (*print-pretty* nil)
 	  (*print-radix* nil)
 	  (*print-readably* t)
@@ -278,37 +324,163 @@
 	  (*read-default-float-format* 'single-float)
 	  (*read-eval* t)
 	  (*read-suppress* nil)
-	  (*readtable* (copy-readtable (si::standard-readtable))));FIXME copy?
+	  (*readtable* (copy-readtable (standard-readtable))))
      ,@body))
 
+;; (defmacro print-unreadable-object
+;; 	  ((object stream &key type identity) &body body)
+;;   (declare (optimize (safety 2)))
+;;   (let ((q `(princ " " ,stream)))
+;;     `(if *print-readably*
+;; 	 (error 'print-not-readable :object ,object)
+;;        (progn
+;; 	 (princ "#<" ,stream)
+;; 	 ,@(when type `((prin1 (type-of ,object) ,stream) ,q))
+;; 	 ,@body
+;; 	 ,@(when identity
+;; 	     (let ((z `(princ (address ,object) ,stream)))
+;; 	       (if (and (not body) type) (list z) (list q z))))
+;; 	 (princ ">" ,stream)
+;; 	 nil))))
+
+;; (defmacro with-compile-file-syntax (&body body)
+;;   `(let ((*print-radix* nil)
+;; 	 (*print-base* 10)
+;; 	 (*print-circle* t)
+;; 	 (*print-pretty* nil)
+;; 	 (*print-level* nil)
+;; 	 (*print-length* nil)
+;; 	 (*print-case* :downcase)
+;; 	 (*print-gensym* t)
+;; 	 (*print-array* t)
+;; 	 (*print-package* t)
+;; 	 (*print-structure* t))
+;;      ,@body))
+
+(defmacro with-compilation-unit (opt &rest body)
+  (declare (optimize (safety 1)))
+  (declare (ignore opt))
+  `(progn ,@body))
+
+(defconstant char-length 8)
+
+(defun get-byte-stream-nchars (s)
+  (let* ((tp (stream-element-type s)))
+    (ceiling (if (consp tp) (cadr tp) char-length) char-length)))
+
+;; (defun parse-integer (s &key start end (radix 10) junk-allowed)
+;;   (declare (optimize (safety 1)))
+;;   (parse-integer-int s start end radix junk-allowed))
+
+(defun write-byte (j s &aux (i j))
+  (declare (optimize (safety 1)))
+  (check-type j integer)
+  (check-type s stream)
+  (dotimes (k (get-byte-stream-nchars s) j)
+    (write-char (code-char (logand i #.(1- (ash 1 char-length)))) s)
+    (setq i (ash i #.(- char-length)))))
+
+
+(defun read-byte (s &optional (eof-error-p t) eof-value &aux (i 0))
+  (declare (optimize (safety 1)))
+  (check-type s stream)
+  (dotimes (k (get-byte-stream-nchars s) i)
+    (setq i (logior i (ash (let ((ch (read-char s eof-error-p eof-value)))
+			     (if (eq ch eof-value) (return ch) (char-code ch)))
+			   (* k char-length))))))
+
+
+(defun read-sequence (seq strm &rest r &key (start 0) end
+			  &aux (l (listp seq))(seqp (when l (nthcdr start seq)))
+			  (cp (eq (stream-element-type strm) 'character)))
+  (declare (optimize (safety 1))(dynamic-extent r))
+  (check-type seq sequence)
+  (check-type strm stream)
+  (check-type start (integer 0))
+  (check-type end (or null (integer 0)))
+  (apply 'reduce (lambda (y x &aux (z (if cp (read-char strm nil 'eof) (read-byte strm nil 'eof))))
+		   (declare (seqind y)(ignorable x))
+		   (when (eq z 'eof) (return-from read-sequence y))
+		   (if l (setf (car seqp) z seqp (cdr seqp)) (setf (aref seq y) z))
+		   (1+ y)) seq :initial-value start r))
+
+
+(defun write-sequence (seq strm &rest r &key (start 0) end
+			   &aux (l (listp seq))(cp (eq (stream-element-type strm) 'character)))
+  (declare (optimize (safety 1))(dynamic-extent r))
+  (check-type seq sequence)
+  (check-type strm stream)
+  (check-type start (integer 0))
+  (check-type end (or null (integer 0)))
+  (apply 'reduce (lambda (y x)
+		   (declare (seqind y))
+		   (if cp (write-char x strm) (write-byte x strm))
+		   (1+ y)) seq :initial-value start r)
+  seq)
+
+(defun restrict-stream-element-type (tp)
+  (cond ((or (member tp '(character :default)) (subtypep tp 'character)) 'character)
+	((subtypep tp 'integer)
+	 (let* ((ntp (car (expand-ranges (normalize-type tp))))
+		(min (or (cadr ntp) '*))(max (or (caddr ntp) '*))
+		(s (if (or (eq min '*) (< min 0)) 'signed-byte 'unsigned-byte))
+		(lim (unless (or (eq min '*) (eq max '*)) (max (integer-length min) (integer-length max))))
+		(lim (if (and lim (eq s 'signed-byte)) (1+ lim) lim)))
+	   (if lim `(,s ,lim) s)))
+	((check-type tp (member character integer)))))
+
+(defun open (f &key (direction :input)
+	       (element-type 'character)
+	       (if-exists nil iesp)
+	       (if-does-not-exist nil idnesp)
+	       (external-format :default) &aux (pf (pathname f)))
+  (declare (optimize (safety 1)))
+  (check-type f pathname-designator)
+  (when (wild-pathname-p pf)
+    (error 'file-error :pathname pf :format-control "Pathname is wild."))
+  (let* ((s (open-int (namestring (translate-logical-pathname pf)) direction
+		      (restrict-stream-element-type element-type)
+		      if-exists iesp if-does-not-exist idnesp external-format)))
+    (when (typep s 'stream) (c-set-stream-object1 s pf) s)))
+
+(defun load-pathname (p print if-does-not-exist external-format
+			&aux (pp (merge-pathnames p))
+			(epp (reduce (lambda (y x) (or y (probe-file (translate-pathname x "" p))))
+				     '(#P".o" #P".lsp" #P".lisp" #P"") :initial-value nil)));FIXME newest?
+  (if epp
+      (let* ((*load-pathname* pp)(*load-truename* epp))
+	(with-open-file
+	 (s epp :external-format external-format)
+	 (if (member (peek-char nil s nil 'eof) '#.(mapcar 'code-char (list 127 #xfe #xff #x4c)))
+	     (load-fasl s print)
+	   (let ((*standard-input* s)) (load-stream s print)))))
+    (when if-does-not-exist
+      (error 'file-error :pathname pp :format-control "File does not exist."))))
+
+(defun load (p &key (verbose *load-verbose*) (print *load-print*) (if-does-not-exist :error)
+	       (external-format :default) &aux (*readtable* *readtable*)(*package* *package*))
+  (declare (optimize (safety 1)))
+  (check-type p (or stream pathname-designator))
+  (when verbose (format t ";; Loading ~s~%" p))
+  (prog1
+      (typecase p
+	(pathname-designator (load-pathname (pathname p) print if-does-not-exist external-format))
+	(stream (load-stream p print)))
+    (when verbose (format t ";; Finished loading ~s~%" p))))
+
 (defun ensure-directories-exist (ps &key verbose &aux created)
+  (declare (optimize (safety 1)))
+  (check-type ps pathname-designator)
   (when (wild-pathname-p ps)
     (error 'file-error :pathname ps :format-control "Pathname is wild"))
-  (labels ((d (x y &aux (z (ldiff x y)) (p (make-pathname :directory z)))
+  (labels ((d (x y &aux (z (ldiff x y)) (n (namestring (make-pathname :directory z))))
 	      (when (when z (stringp (car (last z))))
-		(unless (eq :directory (car (stat p)))
-		  (mkdir (namestring p))
+		(unless (eq :directory (stat n))
+		  (mkdir n)
 		  (setq created t)
-		  (when verbose (format *standard-output* "Creating directory ~s~%" p))))
+		  (when verbose (format *standard-output* "Creating directory ~s~%" n))))
 	      (when y (d x (cdr y)))))
     (let ((pd (pathname-directory ps)))
       (d pd (cdr pd)))
     (values ps created)))
 
-#.(let ((g '(:host :device :directory :name :type :version)))
-     `(defun wild-pathname-p (pd &optional f &aux (p (pathname pd)))
-       (declare (optimize (safety 1)))
-       (check-type f (or null (member ,@g)))
-       (labels ((w-f (x)
-		     (case x
-		       ,@(mapcar (lambda (x &aux (f (intern (string-concatenate "PATHNAME-" (string-upcase x)))))
-				   `(,x ,(if (eq x :directory) `(when (member :wild (,f p)) t) `(eq :wild (,f p))))) g))))
-	 (if f 
-	     (w-f f)
-	   (reduce (lambda (z x) (or z (w-f x))) ',g :initial-value nil)))))
-
-(defun maybe-clear-input (&optional (x *standard-input*))
-  (cond ((not (typep x 'stream)) nil)
-	((typep x 'synonym-stream) (maybe-clear-input (symbol-value (synonym-stream-symbol x))))
-	((typep x 'two-way-stream) (maybe-clear-input (two-way-stream-input-stream x)))
-	((terminal-input-stream-p x) (clear-input t))))
--- /dev/null
+++ gcl-2.6.12/lsp/gcl_logical_pathname_translations.lsp
@@ -0,0 +1,28 @@
+(in-package :si)
+
+(defvar *pathname-logical* nil)
+
+(defun setf-logical-pathname-translations (v k)
+  (declare (optimize (safety 1)))
+  (check-type v list)
+  (check-type k string)
+  (setf (cdr (or (assoc k *pathname-logical* :test 'string-equal) (car (push (cons k t) *pathname-logical*)))) ;(cons k nil)
+	(mapcar (lambda (x) (list (parse-namestring (car x) k) (parse-namestring (cadr x)))) v)))
+
+(defsetf logical-pathname-translations (x) (y) `(setf-logical-pathname-translations ,y ,x))
+(remprop 'logical-pathname-translations 'si::setf-update-fn)
+
+(defun logical-pathname-translations (k)
+  (declare (optimize (safety 1)))
+  (check-type k string)
+  (cdr (assoc k *pathname-logical* :test 'string-equal)))
+
+
+(defun load-logical-pathname-translations (k)
+  (declare (optimize (safety 1)))
+  (unless (logical-pathname-translations k)
+    (error "No translations found for ~s" k)))
+
+(defun logical-pathname-host-p (host)
+  (when host
+    (logical-pathname-translations host)))
--- /dev/null
+++ gcl-2.6.12/lsp/gcl_make_pathname.lsp
@@ -0,0 +1,155 @@
+(in-package :si)
+
+;; (defun pathnamep (x)
+;;   (declare (optimize (safety 1)))
+;;   (when (typep x 'pathname) t))
+
+(defun msub (a x) (if a (msub (cdr a) (substitute (caar a) (cdar a) x)) x))
+
+(defvar *glob-to-regexp-alist* (list (cons #v"{[^}]*}" (lambda (x) (msub '((#\| . #\,)(#\( . #\{)(#\) . #\})) x)))
+				     (cons #v"\\[[^\\]*\\]" (lambda (x)
+							      (concatenate 'string "("
+									   (substitute #\^ #\! (subseq x 0 2))
+									   (subseq x 2) ")")))
+				     (cons #v"\\*" (lambda (x) "([^/.]*)"))
+				     (cons #v"\\?" (lambda (x) "([^/.])"))
+				     (cons #v"\\." (lambda (x) "\\."))))
+
+(defun mglist (x &optional (b 0))
+  (let* ((y (mapcan (lambda (z &aux (w (string-match (car z) x b)))
+		      (unless (eql w -1)
+			(list (list w (match-end 0) z))))
+		    *glob-to-regexp-alist*))
+	 (z (when y (reduce (lambda (y x) (if (< (car x) (car y)) x y)) y))))
+    (when z
+      (cons z (mglist x (cadr z))))))
+
+(defun mgsub (x &optional (l (mglist x)) (b 0) &aux (w (pop l)))
+  (if w
+      (concatenate 'string
+		   (subseq x b (car w))
+		   (funcall (cdaddr w) (subseq x (car w) (cadr w)))
+		   (mgsub x l (cadr w)))
+    (subseq x b)))
+
+
+(defun elsub (el x rp lp &aux (y x) (pref (pop y))(dflt (pop y))(post (pop y)))
+;  (destructuring-bind (pref dflt post &rest y) x
+    (etypecase el
+      (string (let ((x (list pref el post))) (unless (zerop (length dflt)) (if rp (mapcar 'mgsub x) x))))
+      (integer (elsub (write-to-string el) x rp lp))
+      ((eql :wild-inferiors) (if rp (list "(" dflt "*)") (elsub "**" x rp lp)))
+      ((eql :wild) (if rp (list dflt) (elsub "*" x rp lp)))
+      ((eql :newest) (elsub (if rp "(newest|NEWEST)" "NEWEST") x rp lp))
+      ((member :up :back) (elsub ".." x rp lp))
+      ((member nil :unspecific) (when rp (list dflt)))
+      (cons (cons
+	     (if (eq (car el) :absolute) (if lp "" "/") (if lp ";" ""))
+	     (mapcan (lambda (z) (elsub z y rp lp)) (cdr el)))))
+;    )
+)
+
+(defconstant +physical-pathname-defaults+ '(("" "" "")
+					    ("" "" "")
+					    ("" "(/?([^/]+/)*)" "" "" "([^/]+/)" "/")
+					    ("" "([^/.]*)" "")
+					    ("." "(\\.[^/]*)?" "")
+					    ("" "" "")))
+(defconstant +logical-pathname-defaults+  '(("" "([-0-9A-Z]+:)?" ":")
+					    ("" "" "")
+					    ("" "(;?((\\*?([-0-9A-Z]+\\*?)+|\\*|\\*\\*);)*)" "" "" "((\\*?([-0-9A-Z]+\\*?)+|\\*);)" ";")
+					    ("" "(\\*?([-0-9A-Z]+\\*?)+|\\*)?" "")
+					    ("." "(\\.(\\*?([-0-9A-Z]+\\*?)+|\\*))?" "")
+					    ("." "(\\.([1-9][0-9]*|newest|NEWEST|\\*))?" "")))
+
+(defun to-regexp-or-namestring (x rp lp)
+  (apply 'concatenate 'string
+	 (mapcan (lambda (x y) (elsub x y rp lp))
+		 x (if lp +logical-pathname-defaults+ +physical-pathname-defaults+))))
+
+(defun directory-list-check (l)
+  (when (listp l)
+    (when (member (car l) '(:absolute :relative))
+      (mapl (lambda (x &aux (c (car x))(d (cadr x)))
+	      (when (and (member d '(:up :back)) (member c '(:absolute :wild-inferiors)))
+		(return-from directory-list-check nil))) l))))
+    
+(defun canonicalize-pathname-directory (l)
+  (cond ((eq l :wild) (canonicalize-pathname-directory '(:absolute :wild-inferiors)))
+	((stringp l) (canonicalize-pathname-directory (list :absolute l)))
+	((mapl (lambda (x &aux (c (car x)))
+		 (when (and (or (stringp c) (eq c :wild)) (eq (cadr x) :back))
+		   (return-from canonicalize-pathname-directory
+		     (canonicalize-pathname-directory (nconc (ldiff l x) (cddr x)))))) l))))
+
+(defvar *default-pathname-defaults* (init-pathname nil nil nil nil nil nil ""))
+(declaim (type pathname *default-pathname-defaults*))
+
+(defun toggle-case (x)
+  (cond ((symbolp x) x)
+	((listp x) (mapcar 'toggle-case x))
+	((find-if 'upper-case-p x) (if (find-if 'lower-case-p x) x (string-downcase x)))
+	((find-if 'lower-case-p x) (string-upcase x))
+	(x)))
+
+(defun logical-pathname (spec &aux (p (pathname spec)))
+  (declare (optimize (safety 1)))
+  (check-type spec pathname-designator)
+  (check-type p logical-pathname)
+  p)
+  
+(eval-when (compile eval)
+  (defun strsym (p &rest r)
+    (declare (:dynamic-extent r))
+    (intern (apply 'concatenate 'string (mapcar 'string-upcase r)) p)))
+
+#.`(defun make-pathname (&key (host nil hostp) (device nil devicep) (directory nil directoryp)
+			      (name nil namep) (type nil typep) (version nil versionp)
+			      defaults (case :local) namestring &aux defaulted (def (when defaults (pathname defaults))))
+     (declare (optimize (safety 1)))
+     (check-type host (or (member nil :unspecific) string))
+     (check-type device (member nil :unspecific))
+     (check-type directory (or (member nil :unspecific :wild) string list))
+     (check-type name (or string (member nil :unspecific :wild)))
+     (check-type type (or string (member nil :unspecific :wild)))
+     (check-type version (or (integer 1) (member nil :unspecific :wild :newest)))
+     (check-type defaults (or null pathname-designator))
+     (check-type case (member :common :local))
+     ,(flet ((def? (k) `(let* (,@(when (eq k 'host) `((def (or def *default-pathname-defaults*))))
+			       (nk (if ,(strsym :si k "P") ,k (progn (setq defaulted t) (when def (,(strsym :si "C-PATHNAME-" k) def)))))
+			       (nk (if (eq case :local) nk (progn (setq defaulted t) (toggle-case nk)))))
+			nk)))
+	`(let* ((h ,(def? 'host))
+		(h (let ((h1 (when (logical-pathname-host-p h) h))) (unless (eq h h1) (setq defaulted t)) h1))
+		(dev ,(def? 'device))
+		(d ,(def? 'directory))
+		(d (let ((d1 (canonicalize-pathname-directory d))) (unless (eq d d1) (setq defaulted t)) d1))
+		(n ,(def? 'name))
+		(typ ,(def? 'type))
+		(v ,(def? 'version))
+		(p (init-pathname h dev d n typ v
+				  (or (unless defaulted namestring) (to-regexp-or-namestring (list h dev d n typ v) nil h)))))
+	   (when h (c-set-t-tt p 1))
+	   (unless (eq d (directory-list-check d))
+	     (error 'file-error :pathname p :format-control "Bad directory list"))
+	   p)))
+
+(macrolet ((pn-accessor (k &aux (f (strsym :si "PATHNAME-" k)) (c (strsym :si "C-PATHNAME-" k)))
+	      `(defun ,f (p &key (case :local) &aux (pn (pathname p)))
+		 (declare (optimize (safety 1)))
+		 (check-type p pathname-designator)
+		 (let ((x (,c pn))) (if (eq case :local) x (toggle-case x))))))
+  (pn-accessor host)
+  (pn-accessor device)
+  (pn-accessor directory)
+  (pn-accessor name)
+  (pn-accessor type)
+  (pn-accessor version))
+
+(defconstant +pathname-keys+ '(:host :device :directory :name :type :version))
+
+#.`(defun mlp (p)
+     (list ,@(mapcar (lambda (x) `(,(strsym :si "C-PATHNAME-" x) p)) +pathname-keys+)))
+
+(defun pnl1 (x) (list* (pop x) (pop x) (append (pop x) x)))
+(defun lnp (x) (list* (pop x) (pop x) (let ((q (last x 3))) (cons (ldiff x q) q))))
--- /dev/null
+++ gcl-2.6.12/lsp/gcl_merge_pathnames.lsp
@@ -0,0 +1,18 @@
+(in-package :si)
+
+(defun merge-pathnames (p &optional (def *default-pathname-defaults*) (def-v :newest)
+			  &aux dflt (pn (pathname p))(def-pn (pathname def)))
+  (declare (optimize (safety 1)))
+  (check-type p pathname-designator)
+  (check-type def pathname-designator)
+  (check-type def-v (or null (eql :newest) seqind))
+  (labels ((def (x) (when x (setq dflt t) x)))
+    (make-pathname
+     :host (or (pathname-host pn) (def (pathname-host def-pn)))
+     :device (or (pathname-device pn) (def (pathname-device def-pn)))
+     :directory (let ((d (pathname-directory pn))(defd (pathname-directory def-pn)))
+		  (or (def (when (and defd (eq (car d) :relative)) (append defd (cdr d)))) d (def defd)))
+     :name (or (pathname-name pn) (def (pathname-name def-pn)))
+     :type (or (pathname-type pn) (def (pathname-type def-pn)))
+     :version (or (pathname-version pn) (def (unless (pathname-name pn) (pathname-version def-pn))) (def def-v))
+     :version (unless dflt (return-from merge-pathnames pn)))))
--- gcl-2.6.12.orig/lsp/gcl_mislib.lsp
+++ gcl-2.6.12/lsp/gcl_mislib.lsp
@@ -114,13 +114,15 @@
      (* (+ h tz) 3600) (* min 60) sec))
 
 (defun compile-file-pathname (pathname)
-(make-pathname :defaults pathname :type "o"))
+  (make-pathname :defaults pathname :type "o"))
+
 (defun constantly (x)
-#'(lambda (&rest args)
+  (lambda (&rest args)
     (declare (ignore args) (:dynamic-extent args))
-x))
+    x))
+
 (defun complement (fn)
-#'(lambda (&rest args) (not (apply fn args))))
+  (lambda (&rest args) (not (apply fn args))))
 
 (defun default-system-banner ()
   (let (gpled-modules)
--- gcl-2.6.12.orig/lsp/gcl_module.lsp
+++ gcl-2.6.12/lsp/gcl_module.lsp
@@ -40,13 +40,13 @@
 
 (defun require (module-name
                 &optional (pathname (string-downcase (string module-name))))
-  (let ((*default-pathname-defaults* #""))
+  (let ((*default-pathname-defaults* (make-pathname)))
     (unless (member (string module-name)
                     *modules*
                     :test #'string=)
             (if (atom pathname)
                 (load pathname)
-                (do ((p pathname (cdr p)))
+	      (do ((p pathname (cdr p)))
                     ((endp p))
                   (load (car p)))))))
           
--- /dev/null
+++ gcl-2.6.12/lsp/gcl_namestring.lsp
@@ -0,0 +1,39 @@
+(in-package :si)
+
+(defun namestring (x)
+  (declare (optimize (safety 1)))
+  (check-type x pathname-designator)
+  (typecase x
+    (string x)
+    (pathname (c-pathname-namestring x))
+    (stream (namestring (c-stream-object1 x)))))
+
+(defun file-namestring (x &aux (px (pathname x)))
+  (declare (optimize (safety 1)))
+  (check-type x pathname-designator)
+  (namestring (make-pathname :name (pathname-name px) :type (pathname-type px) :version (pathname-version px))))
+
+(defun directory-namestring (x &aux (px (pathname x)))
+  (declare (optimize (safety 1)))
+  (check-type x pathname-designator)
+  (namestring (make-pathname :directory (pathname-directory px))))
+
+(defun host-namestring (x &aux (px (pathname x)))
+  (declare (optimize (safety 1)))
+  (check-type x pathname-designator)
+  (or (pathname-host px) ""))
+
+#.`(defun enough-namestring (x &optional (def *default-pathname-defaults*) &aux (px (pathname x))(pdef (pathname def)))
+     (declare (optimize (safety 1)))
+     (check-type x pathname-designator)
+     (check-type def pathname-designator)
+     ,(labels ((new? (k &aux (f (intern (concatenate 'string "PATHNAME-" (string k)) :si)))
+		     `(let ((k (,f px))) (unless (equal k (,f pdef)) k))))
+	`(namestring (make-pathname
+	  ,@(mapcan (lambda (x) (list x (new? x))) +pathname-keys+)))))
+
+(defun faslink (file name &aux (pfile (namestring (merge-pathnames (make-pathname :type "o") (pathname file))))(*package* *package*));FIXME
+  (declare (optimize (safety 1)))
+  (check-type file pathname-designator)
+  (check-type name string)
+  (faslink-int pfile name))
--- /dev/null
+++ gcl-2.6.12/lsp/gcl_parse_namestring.lsp
@@ -0,0 +1,139 @@
+(in-package :si)
+
+(deftype seqind nil `fixnum)
+
+(defun match-beginning (i &aux (v *match-data*))
+  (declare ((vector fixnum) v)(seqind i))
+  (the (or (integer -1 -1 ) seqind) (aref v i)))
+(defun match-end (i &aux (v *match-data*))
+  (declare ((vector fixnum) v)(seqind i))
+  (the (or (integer -1 -1 ) seqind) (aref v (+ i (ash (length v) -1)))))
+
+(declaim (inline match-beginning match-end))
+
+(defun dir-conj (x) (if (eq x :relative) :absolute :relative))
+
+(defvar *up-key* :up)
+
+(defun mfr (x b i) (subseq x b i));  (make-array (- i b) :element-type 'character :displaced-to x :displaced-index-offset b)
+
+(defvar *sym-sub-alist* '((:host . nil)
+			  (:device . nil)
+			  (:directory . (("." . nil)(".." . :up)("*" . :wild)("**" . :wild-inferiors)))
+			  (:name . (("*" . :wild)))
+			  (:type . (("*" . :wild)))
+			  (:version . (("*" . :wild)("NEWEST" . :newest)))))
+
+(defun element (x b i key)
+  (let* ((z (when (> i b) (mfr x b i)))
+	 (w (assoc z (cdr (assoc key *sym-sub-alist*)) :test 'string-equal))
+	 (z (if w (cdr w) z)))
+    (if (eq z :up) *up-key* z)))
+
+(defun dir-parse (x sep sepfirst &optional (b 0))
+  (when (stringp x)
+    (let ((i (search sep x :start2 b)));string-match spoils outer match results
+      (when i
+	(let* ((y (dir-parse x sep sepfirst (1+ i)))
+	       (z (element x b i :directory))
+	       (y (if z (cons z y) y)))
+	  (if (zerop b)
+	      (cons (if (zerop i) sepfirst (dir-conj sepfirst)) y)
+	    y))))))
+
+(defun match-component (x i k &optional (boff 0) (eoff 0))
+  (element x (+ (match-beginning i) boff) (+ (match-end i) eoff) k))
+
+(defun version-parse (x)
+  (typecase x
+    (string (version-parse (parse-integer x)))
+;    (integer (locally (check-type x (integer 1)) x))
+    (otherwise x)))
+
+(defconstant +generic-logical-pathname-regexp+ (compile-regexp (to-regexp-or-namestring (make-list (length +logical-pathname-defaults+)) t t)))
+
+(defun expand-home-dir (dir)
+  (cond ((and (eq (car dir) :relative) (stringp (cadr dir)) (eql #\~ (aref (cadr dir) 0)))
+	 (append (dir-parse (home-namestring (cadr dir)) "/" :absolute) (cddr dir)))
+	(dir)))
+
+(defun logical-pathname-parse (x &optional host def (b 0) (e (length x)))
+  (when (and (eql b (string-match +generic-logical-pathname-regexp+ x b e)) (eql (match-end 0) e))
+    (let ((mhost (match-component x 1 :host 0 -1)))
+      (when (and host mhost)
+	(unless (string-equal host mhost)
+	    (error 'error :format-control "Host part of ~s does not match ~s" :format-arguments (list x host))))
+      (let ((host (or host mhost (pathname-host def))))
+	(when (logical-pathname-host-p host)
+	  (let* ((dir (dir-parse (match-component x 2 :none) ";" :relative))
+		 (edir (expand-home-dir dir)))
+	  (make-pathname :host host
+			 :device :unspecific
+			 :directory edir
+			 :name (match-component x 6 :name)
+			 :type (match-component x 8 :type 1)
+			 :version (version-parse (match-component x 11 :version 1))
+			 :namestring (when (and mhost (eql b 0) (eql e (length x)) (eq dir edir)) x))))))))
+  
+(defconstant +generic-physical-pathname-regexp+ (compile-regexp (to-regexp-or-namestring (make-list (length +physical-pathname-defaults+)) t nil)))
+
+(defun pathname-parse (x b e)
+  (when (and (eql b (string-match +generic-physical-pathname-regexp+ x b e)) (eql (match-end 0) e))
+    (let* ((dir (dir-parse (match-component x 1 :none) "/" :absolute))
+	   (edir (expand-home-dir dir)))
+      (make-pathname :directory edir
+		     :name (match-component x 3 :name)
+		     :type (match-component x 4 :type 1)
+		     :namestring (when (and (eql b 0) (eql e (length x)) (eq dir edir)) x)))))
+
+
+(defun path-stream-name (x)
+  (check-type x pathname-designator)
+  (typecase x
+    (synonym-stream (path-stream-name (symbol-value (synonym-stream-symbol x))))
+    (stream (path-stream-name (c-stream-object1 x)))
+    (otherwise x)))
+
+(defun parse-namestring (thing &optional host (default-pathname *default-pathname-defaults*) &rest r &key (start 0) end junk-allowed)
+  (declare (optimize (safety 1))(dynamic-extent r))
+  (check-type thing pathname-designator)
+  (check-type host (or null (satisfies logical-pathname-translations)))
+  (check-type default-pathname pathname-designator)
+  (check-type start seqind)
+  (check-type end (or null seqind))
+  
+  (typecase thing
+    (string (let* ((e (or end (length thing)))
+		   (l (logical-pathname-parse thing host default-pathname start e))
+		   (l (or l (unless host (pathname-parse thing start e)))))
+	      (cond (junk-allowed (values l (max 0 (match-end 0))))
+		    (l (values l e))
+		    ((error 'parse-error :format-control "~s is not a valid pathname on host ~s" :format-arguments (list thing host))))))
+    (stream (apply 'parse-namestring (path-stream-name thing) host default-pathname r))
+    (pathname
+     (when host
+       (unless (string-equal host (pathname-host thing))
+	 (error 'file-error :pathname thing :format-control "Host does not match ~s" :format-arguments (list host))))
+     (values thing start))))
+
+(defun pathname (spec)
+  (declare (optimize (safety 1)))
+  (check-type spec pathname-designator)
+  (if (typep spec 'pathname) spec (values (parse-namestring spec))))
+
+(defun sharp-p-reader (stream subchar arg)
+  (declare (ignore subchar arg))
+  (let ((x (parse-namestring (read stream)))) x))
+
+(defun sharp-dq-reader (stream subchar arg);FIXME arg && read-suppress
+  (declare (ignore subchar arg))
+  (unread-char #\" stream)
+  (let ((x (parse-namestring (read stream)))) x))
+
+(set-dispatch-macro-character #\# #\p 'sharp-p-reader)
+(set-dispatch-macro-character #\# #\p 'sharp-p-reader (standard-readtable))
+(set-dispatch-macro-character #\# #\P 'sharp-p-reader)
+(set-dispatch-macro-character #\# #\P 'sharp-p-reader (standard-readtable))
+(set-dispatch-macro-character #\# #\" 'sharp-dq-reader)
+(set-dispatch-macro-character #\# #\" 'sharp-dq-reader (standard-readtable))
+
--- /dev/null
+++ gcl-2.6.12/lsp/gcl_pathname_match_p.lsp
@@ -0,0 +1,14 @@
+(in-package :si)
+
+(defun to-regexp (x &optional (rp t) &aux (px (pathname x))(lp (typep px 'logical-pathname)))
+  (to-regexp-or-namestring (mlp px) rp lp))
+
+(deftype compiled-regexp nil `(vector unsigned-char))
+
+(defun pathname-match-p (p w &aux (s (namestring p)))
+  (declare (optimize (safety 1)))
+  (check-type p pathname-designator)
+  (check-type w (or compiled-regexp pathname-designator))
+  (and (zerop (string-match (if (typep w 'compiled-regexp) w (to-regexp w)) s))
+       (eql (match-end 0) (length s))))
+
--- gcl-2.6.12.orig/lsp/gcl_predlib.lsp
+++ gcl-2.6.12/lsp/gcl_predlib.lsp
@@ -110,6 +110,7 @@
        (not (array-has-fill-pointer-p x))
        (not (si:displaced-array-p x))))
 
+(defun logical-pathnamep (x) (when (pathnamep x) (eql (c-t-tt x) 1)))
 
 (do ((l '((null . null)
           (symbol . symbolp)
@@ -124,7 +125,15 @@
           (character . characterp)
           (package . packagep)
           (stream . streamp)
+          (file-stream . file-stream-p)
+          (synonym-stream . synonym-stream-p)
+          (broadcast-stream . broadcast-stream-p)
+          (concatenated-stream . concatenated-stream-p)
+          (two-way-stream . two-way-stream-p)
+          (echo-stream . echo-stream-p)
           (pathname . pathnamep)
+          (pathname-designator . pathname-designatorp)
+          (logical-pathname . logical-pathnamep)
           (readtable . readtablep)
           (hash-table . hash-table-p)
           (random-state . random-state-p)
@@ -196,6 +205,8 @@
          ((null l) t)
        (unless (typep object (car l)) (return nil))))
     (satisfies (funcall (car i) object))
+    (eql (eql (car i) object))
+    (member (member object i))
     ((t) t)
     ((nil) nil)
     (boolean (or (eq object 't) (eq object 'nil)))
@@ -280,6 +291,40 @@
 	      (typep object (apply tem i)))))))
 
 
+
+(defun minmax (i1 i2 low-p e &aux (fn (if low-p (if e '< '>) (if e '> '<))))
+  (cond ((eq i1 '*) (if e i1 i2))
+	((eq i2 '*) (if e i2 i1))
+	((funcall fn i1 i2) i1)
+	(i2)))
+
+(defun expand-range (low high bottom top)
+  (let ((low (minmax low bottom t t))(high (minmax high top nil t)))
+    (when (or (eq low '*) (eq high '*) (<= low high)) (list low high))))
+
+(defun nc (tp)
+  (when (consp tp)
+    (case (car tp)
+	  ;; (immfix (let ((m (cadr tp))(x (caddr tp))
+	  ;; 	    (list (list 'integer (if (eq m '*) most-negative-immfix m) (if (eq x '*) most-positive-immfix x)))))
+	  ;; (bfix (let* ((m (cadr tp))(x (caddr tp))(m (if (eq m '*) most-negative-fixnum m))(x (if (eq x '*) most-positive-fixnum x)))
+	  ;; 	  (if (< (* m x) 0)
+	  ;; 	      `((integer ,m ,(1- most-negative-immfix))(integer ,(1+ most-positive-immfix) ,x))
+	  ;; 	    `((integer ,m ,x)))))
+	  ;; (bignum (let* ((m (cadr tp))(x (caddr tp))(sm (or (eq m '*) (< m 0)))(sx (or (eq x '*) (>= x 0))))
+	  ;; 	    (if (and sm sx)
+	  ;; 		`((integer ,m ,(1- most-negative-fixnum))(integer ,(1+ most-positive-fixnum) ,x))
+	  ;; 	      `((integer ,m ,x)))))
+	  ((integer ratio short-float long-float) (list tp))
+	  (otherwise (append (nc (car tp)) (nc (cdr tp)))))))
+
+
+(defun expand-ranges (type)
+  (reduce (lambda (y x &aux (z (assoc (car x) y)))
+	     (if z (subst (cons (car z) (apply 'expand-range (cadr x) (caddr x) (cdr z))) z y)
+	       (cons x y))) (nc type) :initial-value nil))
+
+
 ;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions.
 ;;; The result is always a list.
 (defun normalize-type (type &aux tp i )
--- /dev/null
+++ gcl-2.6.12/lsp/gcl_rename_file.lsp
@@ -0,0 +1,47 @@
+(in-package :si)
+
+(defun set-path-stream-name (x y)
+  (check-type x pathname-designator)
+  (typecase x
+    (synonym-stream (set-path-stream-name (symbol-value (synonym-stream-symbol x)) y))
+    (stream (c-set-stream-object1 x y))))
+
+(defun rename-file (f n &aux (pf (pathname f))(pn (merge-pathnames n pf nil))
+		      (tpf (truename pf))(nf (namestring tpf))
+		      (tpn (translate-logical-pathname pn))(nn (namestring tpn)))
+  (declare (optimize (safety 1)))
+  (check-type f pathname-designator)
+  (check-type n (and pathname-designator (not stream)))
+  (unless (rename nf nn)
+    (error 'file-error :pathname pf :format-control "Cannot rename ~s to ~s." :format-arguments (list nf nn)))
+  (set-path-stream-name f pn)
+  (values pn tpf (truename tpn)))
+
+(defun user-homedir-pathname (&optional (host :unspecific hostp))
+  (declare (optimize (safety 1)))
+  (check-type host (or string list (eql :unspecific)))
+  (unless hostp
+    (pathname (home-namestring "~"))))
+
+(defun delete-file (f &aux (pf (truename f))(nf (namestring pf)))
+  (declare (optimize (safety 1)))
+  (check-type f pathname-designator)
+  (unless (if (eq :directory (stat nf)) (rmdir nf) (unlink nf))
+    (error 'file-error :pathname (pathname nf) :format-control "Cannot delete pathname."))
+  t)
+
+(defun file-write-date (spec)
+  (declare (optimize (safety 1)))
+  (check-type spec pathname-designator)
+  (multiple-value-bind
+      (tp sz tm) (stat (namestring (truename spec)))
+    (+ tm (* (+ 17 (* 70 365)) (* 24 60 60)))))
+
+  
+(defun file-author (spec)
+  (declare (optimize (safety 1)))
+  (check-type spec pathname-designator)
+  (multiple-value-bind
+      (tp sz tm uid) (stat (namestring (truename spec)))
+    (uid-to-name uid)))
+
--- gcl-2.6.12.orig/lsp/gcl_sharp.lsp
+++ gcl-2.6.12/lsp/gcl_sharp.lsp
@@ -61,4 +61,6 @@
    (otherwise x)))
 
 (set-dispatch-macro-character #\# #\= #'sharp-eq-reader)
+(set-dispatch-macro-character #\# #\= #'sharp-eq-reader (standard-readtable))
 (set-dispatch-macro-character #\# #\# #'sharp-sharp-reader)
+(set-dispatch-macro-character #\# #\# #'sharp-sharp-reader (standard-readtable))
--- /dev/null
+++ gcl-2.6.12/lsp/gcl_sharp_uv.lsp
@@ -0,0 +1,29 @@
+(in-package :si)
+
+(defun regexp-conv (stream)
+
+  (let ((tem (make-array 10 :element-type 'character :fill-pointer 0)))
+    (or (eql (read-char stream) #\")
+	(error "sharp-u-reader reader needs a \" right after it"))
+    (loop
+     (let ((ch (read-char stream)))
+       (cond ((eql ch #\") (return tem))
+	     ((eql ch #\\)
+	      (setq ch (read-char stream))
+	      (setq ch (or (cdr (assoc ch '((#\n . #\newline)
+					    (#\t . #\tab)
+					    (#\r . #\return))))
+			   ch))))
+       (vector-push-extend ch tem)))
+    tem))
+
+(defun sharp-u-reader (stream subchar arg)
+  (declare (ignore subchar arg))
+  (regexp-conv stream))
+
+(defun sharp-v-reader (stream subchar arg)
+  (declare (ignore subchar arg))
+  `(load-time-value (compile-regexp ,(regexp-conv stream))))
+
+(set-dispatch-macro-character #\# #\u 'sharp-u-reader)
+(set-dispatch-macro-character #\# #\v 'sharp-v-reader)
--- gcl-2.6.12.orig/lsp/gcl_top.lsp
+++ gcl-2.6.12/lsp/gcl_top.lsp
@@ -83,7 +83,7 @@
       (progn 
 	(cond
 	 (*multiply-stacks* (setq *multiply-stacks* nil))
-	 ((probe-file "init.lsp") (load "init.lsp"))))
+	 ((when (fboundp 'probe-file) (probe-file "init.lsp")) (load "init.lsp"))))
       (when (if (symbolp *top-level-hook*) (fboundp *top-level-hook*) (functionp *top-level-hook*))
 	(funcall *top-level-hook*)))
 
@@ -122,6 +122,8 @@
 
 (defvar *error-p* nil)
 
+(defvar *lib-directory* nil)
+
 (defun process-some-args (args &optional compile &aux *load-verbose*)
   (when args
     (let ((x (pop args)))
@@ -148,7 +150,7 @@
 	   (file (cdr (assoc :compile compile)))
 	   (o (cdr (assoc :o compile)))
 	   (compile (remove :o (remove :compile compile :key 'car) :key 'car))
-	   (compile (cons (cons :output-file (or o file)) compile))
++	   (compile (cons (cons :output-file (or o (merge-pathnames ".o" file))) compile))
 	   (result (system:error-set `(apply 'compile-file ,file ',(mapcan (lambda (x) (list (car x) (cdr x))) compile)))))
       (bye (if (or *error-p* (equal result '(nil))) 1 0)))))
 
@@ -520,15 +522,12 @@ add a new one, add a 'si::break-command
 
 ;;make sure '/' terminated
 
-(defun coerce-slash-terminated (v )
-  (declare (string v))
-  (or (stringp v) (error "not a string ~a" v))
+(defun coerce-slash-terminated (v)
   (let ((n (length v)))
-    (declare (fixnum n))
-    (unless (and (> n 0) (eql
-			  (the character(aref v (the fixnum (- n 1)))) #\/))
-	    (setf v (format nil "~a/" v))))
-  v)
+    (if (and (> n 0) (eql (aref v (1- n)) #\/))
+	v
+      (string-concatenate v "/"))))
+
 (defun fix-load-path (l)
   (when (not (equal l *fixed-load-path*))
       (do ((x l (cdr x)) )
@@ -587,19 +586,17 @@ First directory is checked for first nam
     (when (and s (symbol-value s))
       (list *system-directory*))))
 	 
-
-(defun get-temp-dir nil
- (dolist (x `(,@(wine-tmp-redirect) ,@(mapcar 'getenv '("TMPDIR" "TMP" "TEMP")) "/tmp" ""))
-   (when (or (stringp x) (pathnamep x))
-     (let* ((x (truename (pathname x)))
-	    (y (namestring (make-pathname :name (pathname-name x) :type (pathname-type x) :version (pathname-version x))))
-	    (y (unless (zerop (length y)) (list y))))
-       (when (eq :directory (car (stat x)))
-	 (return-from get-temp-dir 
-	   (namestring 
-	    (make-pathname 
-	     :device (pathname-device x)
-	     :directory (append (pathname-directory x) y)))))))))
+(defun ensure-dir-string (str)
+  (if (eq (stat str) :directory)
+      (coerce-slash-terminated str)
+    str))
+
+(defun get-temp-dir ()
+  (dolist (x `(,@(wine-tmp-redirect) ,@(mapcar 'si::getenv '("TMPDIR" "TMP" "TEMP")) "/tmp" ""))
+    (when x
+      (let ((x (coerce-slash-terminated x)))
+	(when (eq (stat x) :directory)
+	  (return-from get-temp-dir x))))))
 
 (defun get-path (s &aux (m (string-match "([^/ ]*)( |$)" s))(b (match-beginning 1))(e (match-end 1))
 		   (r (with-open-file (s (concatenate 'string "|which " (subseq s b e))) (read s nil 'eof))))
--- /dev/null
+++ gcl-2.6.12/lsp/gcl_translate_pathname.lsp
@@ -0,0 +1,90 @@
+(in-package :si)
+
+(defun lenel (x lp)
+  (case x (:wild 1)(:wild-inferiors 2)(:absolute (if lp -1 0))(:relative (if lp 0 -1))
+	((:unspecific nil :newest) -1)(otherwise (length x))))
+
+(defun next-match (&optional (i 1) (k -1) (m (1- (ash (length *match-data*) -1))))
+  (cond ((< k (match-beginning i) (match-end i)) i)
+	((< i m) (next-match (1+ i) k m))
+	(i)))
+
+(defun mme2 (s lel lp &optional (b 0) (i (next-match)) r el
+	       &aux (e (+ b (lenel (car lel) lp)))(j (match-beginning i))(k (match-end i)))
+  (cond
+   ((< (- b 2) j k (+ e 2))
+    (let* ((z (car lel))(b1 (max b j))(e1 (min k e))
+	   (z (if (or (< b b1) (< e1 e)) (subseq z (- b1 b) (- e1 b)) z))
+	   (r (if el r (cons nil r))))
+      (mme2 s lel lp b (next-match i k) (cons (cons z (car r)) (cdr r)) (or el (car lel)))))
+   ((< (1- j) b e (1+ k))
+    (let ((r (if el r (cons nil r))))
+      (mme2 s (cdr lel) lp (1+ e) i (cons (cons (car lel) (car r)) (cdr r)) (or el (list (car lel))))))
+   ((consp el)
+    (let* ((cr (nreverse (car r))))
+      (mme2 s lel lp b (next-match i k) (cons (cons (car el) (list cr)) (cdr r)))))
+   (el
+    (let* ((cr (nreverse (car r))))
+      (mme2 s (cdr lel) lp (1+ e) i (cons (cons el cr) (cdr r)))))
+   (lel (mme2 s (cdr lel) lp (1+ e) i (cons (car lel) r)))
+   ((nreverse r))))
+
+(defun do-repl (x y)
+  (labels ((r (x l &optional (b 0) &aux (f (string-match #v"\\*" x b)))
+	      (if (eql f -1) (if (eql b 0) x (subseq x b))
+		(concatenate 'string (subseq x b f) (or (car l) "") (r x (cdr l) (1+ f))))))
+    (r y x)))
+
+(defun dir-p (x) (when (consp x) (member (car x) '(:absolute :relative))))
+
+(defun source-portion (x y)
+  (cond
+   ((or (dir-p x) (dir-p y))
+    (mapcan (lambda (z &aux (w (source-portion
+				(if y (when (wild-dir-element-p z) (setf x (member-if 'listp x)) (pop x)) z)
+				(when y z))))
+   	      (if (listp w) w (list w))) (or y x)))
+   ((if y (eq y :wild-inferiors) t) (if (listp x) (if (listp (cadr x)) (cadr x) (car x)) x));(or  y)
+   ((eq y :wild) (if (listp x) (car x) x));(or  y)
+   ((stringp y) (do-repl (when (listp x) (unless (listp (cadr x)) (cdr x))) y))
+   (y)))
+
+(defun list-toggle-case (x f)
+  (typecase x
+    (string (funcall f x))
+    (cons (mapcar (lambda (x) (list-toggle-case x f)) x))
+    (otherwise x)))
+
+(defun mme3 (sx px flp tlp)
+  (list-toggle-case
+   (lnp (mme2 sx (pnl1 (mlp px)) flp))
+   (cond ((eq flp tlp) 'identity)
+	 (flp 'string-downcase)
+	 (tlp 'string-upcase))))
+
+(defun translate-pathname (source from to &key
+				  &aux (psource (pathname source))
+				  (pto (pathname to))
+				  (match (pathname-match-p source from)))
+  (declare (optimize (safety 1)))
+  (check-type source pathname-designator)
+  (check-type from pathname-designator)
+  (check-type to pathname-designator)
+  (check-type match (not null))
+  (apply 'make-pathname :host (pathname-host pto) :device (pathname-device pto)
+	 (mapcan 'list +pathname-keys+
+		 (mapcar 'source-portion
+			 (mme3 (namestring source) psource (typep psource 'logical-pathname) (typep pto 'logical-pathname))
+			 (mlp pto)))))
+
+(defun translate-logical-pathname (spec &key &aux (p (pathname spec)))
+  (declare (optimize (safety 1)))
+  (check-type spec pathname-designator)
+  (typecase p
+    (logical-pathname
+     (let ((rules (assoc p (logical-pathname-translations (pathname-host p)) :test 'pathname-match-p)))
+       (unless rules
+	 (error 'file-error :pathname p :format-control "No matching translations"))
+       (translate-logical-pathname (apply 'translate-pathname p rules))))
+    (otherwise p)))
+    
--- /dev/null
+++ gcl-2.6.12/lsp/gcl_truename.lsp
@@ -0,0 +1,43 @@
+(in-package :si)
+
+(defun link-expand (str &optional (b 0)	(n (length str)) fr)
+  (labels ((frame (b e) (make-array (- n b) :element-type 'character
+				    :displaced-to str :displaced-index-offset b :fill-pointer (- e b)))
+	   (set-fr (fr e &aux (fr (or fr (frame 0 b)))) (setf (fill-pointer fr) e) fr))
+    (let* ((i (string-match #v"/" str b))
+	   (fr (set-fr fr (if (eql i -1) n i)))
+	   (l (when (eq (stat fr) :link) (readlinkat 0 fr))))
+      (cond (l (let ((b (if (eql #\/ (aref l 0)) 0 b)))
+		 (link-expand (concatenate 'string (set-fr fr b) l (frame (if (eql i -1) n i) n)) b)))
+	    ((eql i -1) str)
+	    ((link-expand str (1+ i) n fr))))))
+
+(defun logical-pathname-designator-p (x)
+  (typecase x
+    (string (logical-pathname-parse x))
+    (pathname (typep x 'logical-pathname))
+    (stream (logical-pathname-designator-p (pathname x)))))
+
+;(defvar *current-dir* (pathname (concatenate 'string (getcwd) "/"))) FIXME sync with chdir
+
+(defun truename (pd &aux (ppd (translate-logical-pathname pd))(ns (namestring ppd)))
+  (declare (optimize (safety 1)))
+  (check-type pd pathname-designator)
+  (when (wild-pathname-p ns)
+    (error 'file-error :pathname pd :format-control "Pathname is wild"))
+  (let* ((ns (ensure-dir-string (link-expand ns))))
+    (unless (or (zerop (length ns)) (stat ns))
+      (error 'file-error :pathname ns :format-control "Pathname does not exist"))
+    (let* ((d (pathname-directory ppd))
+	   (d1 (subst :back :up d))
+	   (ppd (if (eq d d1) ppd (make-pathname :directory d1 :defaults ppd))))
+      (if (eq (car d) :absolute) ppd (merge-pathnames ppd (concatenate 'string (getcwd) "/") nil)))))
+
+
+(defun probe-file (pd &aux (pn (translate-logical-pathname pd)))
+  (declare (optimize (safety 1)))
+  (check-type pd pathname-designator)
+  (when (wild-pathname-p pn)
+    (error 'file-error :pathname pn :format-control "Pathname is wild"))
+  (when (eq (stat (namestring pn)) :file)
+    (truename pn)))
--- /dev/null
+++ gcl-2.6.12/lsp/gcl_wild_pathname_p.lsp
@@ -0,0 +1,28 @@
+(in-package :si)
+
+(defun wild-namestring-p (x)
+  (when (stringp x) (>= (string-match #v"(\\*|\\?|\\[|\\{)" x) 0)))
+
+(defun wild-dir-element-p (x)
+  (or (eq x :wild) (eq x :wild-inferiors) (wild-namestring-p x)))
+
+(defun wild-path-element-p (x)
+  (or (eq x :wild) (wild-namestring-p x)))
+
+#.`(defun wild-pathname-p (pd &optional f)
+     (declare (optimize (safety 1)))
+     (check-type pd pathname-designator)
+     (check-type f (or null (member ,@+pathname-keys+)))
+     (case f
+       ((nil) (or (wild-namestring-p (namestring pd))
+		  (when (typep pd 'pathname);FIXME stream
+		    (eq :wild (pathname-version pd)))))
+       ;; ((nil) (if (stringp pd) (wild-namestring-p pd)
+       ;; 		(let ((p (pathname pd)))
+       ;; 		  (when (member-if (lambda (x) (wild-pathname-p p x)) +pathname-keys+) t))))
+       ((:host :device) nil)
+       (:directory (when (member-if 'wild-dir-element-p (pathname-directory pd)) t))
+       (:name (wild-path-element-p (pathname-name pd)))
+       (:type (wild-path-element-p (pathname-type pd)))
+       (:version (wild-path-element-p (pathname-version pd)))))
+    
--- gcl-2.6.12.orig/lsp/makefile
+++ gcl-2.6.12/lsp/makefile
@@ -13,9 +13,12 @@ OBJS	= gcl_sharp.o gcl_arraylib.o gcl_as
 	  gcl_describe.o gcl_evalmacros.o gcl_fpe.o \
 	  gcl_iolib.o gcl_listlib.o gcl_mislib.o gcl_module.o gcl_numlib.o \
 	  gcl_packlib.o gcl_predlib.o \
+	  gcl_parse_namestring.o gcl_make_pathname.o gcl_namestring.o gcl_translate_pathname.o\
+	  gcl_logical_pathname_translations.o gcl_directory.o gcl_merge_pathnames.o gcl_truename.o gcl_sharp_uv.o\
 	  gcl_seq.o gcl_seqlib.o gcl_setf.o gcl_top.o gcl_trace.o gcl_sloop.o \
           gcl_debug.o gcl_info.o gcl_serror.o gcl_restart.o \
-	  gcl_destructuring_bind.o gcl_defpackage.o gcl_make_defpackage.o gcl_loop.o $(EXTRA_LOBJS)
+          gcl_rename_file.o gcl_pathname_match_p.o gcl_wild_pathname_p.o \
+          gcl_destructuring_bind.o gcl_defpackage.o gcl_make_defpackage.o gcl_loop.o $(EXTRA_LOBJS)
 # export.o autoload.o auto_new.o
 
 LISP=$(PORTDIR)/saved_pre_gcl$(EXE)
--- gcl-2.6.12.orig/lsp/sys-proclaim.lisp
+++ gcl-2.6.12/lsp/sys-proclaim.lisp
@@ -2,361 +2,223 @@
 (COMMON-LISP::IN-PACKAGE "SYSTEM") 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
-         (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::T)
-         ANSI-LOOP::LOOP-EMIT-FINAL-VALUE SYSTEM::INSPECT-CHARACTER
-         SYSTEM::INSPECT-STRUCTURE SYSTEM::PRINT-IHS SYSTEM::DBL-RPL-LOOP
-         SYSTEM::RESTART-FUNCTION COMMON-LISP::TANH COMMON-LISP::FIFTH
-         SLOOP::PARSE-LOOP-INITIALLY SYSTEM::NEXT-STACK-FRAME
-         SYSTEM::IDESCRIBE SYSTEM::PROCESS-ARGS SYSTEM::LEAP-YEAR-P
-         SLOOP::AVERAGING-SLOOP-MACRO SYSTEM::FIX-LOAD-PATH
-         SLOOP::SUBSTITUTE-SLOOP-BODY SYSTEM::RESTART-REPORT-FUNCTION
-         COMMON-LISP::NINTH SLOOP::SLOOP-SLOOP-MACRO
-         SYSTEM::S-DATA-CONSTRUCTORS SYSTEM::FREEZE-DEFSTRUCT
-         COMMON-LISP::EIGHTH SYSTEM::FIND-DOCUMENTATION
-         ANSI-LOOP::LOOP-PSEUDO-BODY COMMON-LISP::RATIONAL
-         ANSI-LOOP::LOOP-EMIT-BODY COMMON-LISP::ASIN
-         COMMON-LISP::COMPILE-FILE-PATHNAME SYSTEM::S-DATA-P
-         SYSTEM::BKPT-FUNCTION SYSTEM::TRACE-ONE-PREPROCESS
-         COMMON-LISP::LOGNOT SYSTEM::SIMPLE-ARRAY-P SYSTEM::BKPT-FILE
-         SYSTEM::S-DATA-STATICP COMMON-LISP::ISQRT SYSTEM::INSTREAM-P
-         COMMON-LISP::SEVENTH SYSTEM::S-DATA-NAMED
-         ANSI-LOOP::LOOP-PATH-PREPOSITION-GROUPS SYSTEM::INSPECT-NUMBER
-         COMMON-LISP::ATANH SYSTEM::RESTART-TEST-FUNCTION
-         SYSTEM::S-DATA-INCLUDES SYSTEM::S-DATA-HAS-HOLES
-         SYSTEM::CONTEXT-VEC FPE::XMM-LOOKUP SYSTEM::S-DATA-RAW
-         ANSI-LOOP::LOOP-UNIVERSE-KEYWORDS
-         SYSTEM::RESTART-INTERACTIVE-FUNCTION
-         ANSI-LOOP::LOOP-UNIVERSE-ITERATION-KEYWORDS
-         ANSI-LOOP::LOOP-COLLECTOR-NAME ANSI-LOOP::LOOP-PATH-NAMES
-         ANSI-LOOP::LOOP-MINIMAX-ANSWER-VARIABLE
-         SYSTEM::S-DATA-INCLUDED SYSTEM::S-DATA-SLOT-DESCRIPTIONS
-         SYSTEM::S-DATA-OFFSET SLOOP::REPEAT-SLOOP-MACRO
-         SYSTEM::S-DATA-PRINT-FUNCTION ANSI-LOOP::LOOP-PATH-USER-DATA
-         COMMON-LISP::FIND-ALL-SYMBOLS COMMON-LISP::FIRST
-         SYSTEM::GET-BYTE-STREAM-NCHARS SYSTEM::BKPT-FORM
-         SYSTEM::NODES-FROM-INDEX SYSTEM::INSPECT-SYMBOL
-         SYSTEM::KNOWN-TYPE-P ANSI-LOOP::LOOP-MINIMAX-TEMP-VARIABLE
-         SYSTEM::MAKE-DEFPACKAGE-FORM COMMON-LISP::ARRAY-DIMENSIONS
-         SYSTEM::INSERT-BREAK-POINT SLOOP::PARSE-LOOP
-         ANSI-LOOP::LOOP-PATH-INCLUSIVE-PERMITTED
-         ANSI-LOOP::LOOP-UNIVERSE-PATH-KEYWORDS SYSTEM::SHORT-NAME
-         SYSTEM::CHECK-TRACE-SPEC ANSI-LOOP::DESTRUCTURING-SIZE
-         SYSTEM::BEST-ARRAY-ELEMENT-TYPE SYSTEM::CONTEXT-HASH
-         COMMON-LISP::SIXTH SYSTEM::IHS-VISIBLE SYSTEM::INSPECT-ARRAY
-         COMMON-LISP::BYTE-SIZE ANSI-LOOP::LOOP-COLLECTOR-CLASS
-         ANSI-LOOP::LOOP-HACK-ITERATION
-         ANSI-LOOP::LOOP-CONSTRUCT-RETURN SYSTEM::S-DATA-SLOT-POSITION
-         ANSI-LOOP::LOOP-MINIMAX-FLAG-VARIABLE SYSTEM::INSPECT-STRING
-         COMMON-LISP::PROVIDE COMMON-LISP::CIS
-         ANSI-LOOP::LOOP-MINIMAX-OPERATIONS
-         SYSTEM::BREAK-BACKWARD-SEARCH-STACK
-         ANSI-LOOP::LOOP-COLLECTOR-DTYPE
-         SYSTEM::IHS-NOT-INTERPRETED-ENV SYSTEM::SEARCH-STACK
-         COMMON-LISP::TENTH ANSI-LOOP::LOOP-DO-THEREIS
-         ANSI-LOOP::LOOP-MAXMIN-COLLECTION
-         ANSI-LOOP::LOOP-MINIMAX-INFINITY-DATA
-         ANSI-LOOP::LOOP-MAKE-PSETQ SYSTEM::ADD-TO-HOTLIST
-         SYSTEM::INSPECT-CONS ANSI-LOOP::LOOP-UNIVERSE-TYPE-SYMBOLS
-         SYSTEM::INSPECT-VECTOR COMMON-LISP::CONSTANTLY
-         SYSTEM::REWRITE-RESTART-CASE-CLAUSE SYSTEM::DM-BAD-KEY
-         SYSTEM::PRINT-SYMBOL-APROPOS SYSTEM::FRS-KIND FPE::ST-LOOKUP
-         COMMON-LISP::FOURTH SYSTEM::TERMINAL-INTERRUPT
-         SYSTEM::DM-KEY-NOT-ALLOWED SYSTEM::UNIQUE-ID
-         SYSTEM::S-DATA-FROZEN SLOOP::POINTER-FOR-COLLECT
-         SYSTEM::INSPECT-PACKAGE SYSTEM::DBL-EVAL
-         ANSI-LOOP::LOOP-MINIMAX-TYPE ANSI-LOOP::LOOP-UNIVERSE-ANSI
-         ANSI-LOOP::LOOP-UNIVERSE-TYPE-KEYWORDS SYSTEM::DWIM
-         SYSTEM::INSTREAM-STREAM-NAME SLOOP::RETURN-SLOOP-MACRO
-         SYSTEM::PATCH-SHARP SYSTEM::CONTEXT-P SYSTEM::INFO-GET-FILE
-         SYSTEM::RESTART-P COMMON-LISP::COSH COMMON-LISP::SINH
-         SYSTEM::GET-NEXT-VISIBLE-FUN SYSTEM::CHECK-DECLARATIONS
-         SYSTEM::GET-INSTREAM
-         ANSI-LOOP::LOOP-CODE-DUPLICATION-THRESHOLD SYSTEM::S-DATA-NAME
-         ANSI-LOOP::LOOP-UNIVERSE-FOR-KEYWORDS
-         SYSTEM::S-DATA-DOCUMENTATION SYSTEM::SHOW-BREAK-POINT
-         COMMON-LISP::ACOS COMMON-LISP::INVOKE-DEBUGGER
-         SYSTEM::BKPT-FILE-LINE ANSI-LOOP::LOOP-COLLECTOR-DATA
-         COMMON-LISP::THIRD SYSTEM::S-DATA-CONC-NAME
-         COMMON-LISP::SIGNUM
-         ANSI-LOOP::LOOP-UNIVERSE-IMPLICIT-FOR-REQUIRED
-         SYSTEM::NORMALIZE-TYPE ANSI-LOOP::LOOP-TYPED-INIT
-         ANSI-LOOP::LOOP-PATH-FUNCTION SYSTEM::INFO-NODE-FROM-POSITION
-         COMMON-LISP::ASINH SYSTEM::RE-QUOTE-STRING
-         SLOOP::LOOP-COLLECT-KEYWORD-P SYSTEM::PRINT-FRS
-         SYSTEM::EVAL-FEATURE ANSI-LOOP::LOOP-COLLECTOR-P
-         ANSI-LOOP::LOOP-COLLECTOR-HISTORY
-         ANSI-LOOP::LOOP-LIST-COLLECTION
-         SYSTEM::BREAK-FORWARD-SEARCH-STACK COMMON-LISP::RESTART-NAME
-         SLOOP::PARSE-NO-BODY ANSI-LOOP::LOOP-UNIVERSE-P
-         SYSTEM::NUMBER-OF-DAYS-FROM-1900 SYSTEM::NODE-OFFSET
-         ANSI-LOOP::LOOP-MINIMAX-P SYSTEM::IHS-FNAME FPE::LOOKUP
-         SLOOP::LOOP-LET-BINDINGS FPE::GREF COMMON-LISP::PHASE
-         COMMON-LISP::BYTE-POSITION SYSTEM::INSTREAM-STREAM
-         ANSI-LOOP::LOOP-PATH-P SYSTEM::SEQTYPE COMMON-LISP::ACOSH
-         COMMON-LISP::ABS COMMON-LISP::COMPLEMENT
-         ANSI-LOOP::LOOP-CONSTANTP SYSTEM::WALK-THROUGH
-         SYSTEM::SETUP-INFO SYSTEM::COMPUTING-ARGS-P
-         SYSTEM::CONTEXT-SPICE SYSTEM::MAKE-KCL-TOP-RESTART
-         COMMON-LISP::COMPILER-MACRO-FUNCTION
-         ANSI-LOOP::LOOP-MAKE-DESETQ SYSTEM::SHOW-ENVIRONMENT
-         SLOOP::TRANSLATE-NAME SYSTEM::INFO-GET-TAGS
-         COMMON-LISP::SECOND SYSTEM::RESET-TRACE-DECLARATIONS
-         SYSTEM::S-DATA-TYPE SYSTEM::FIND-KCL-TOP-RESTART
-         ANSI-LOOP::MAKE-ANSI-LOOP-UNIVERSE SYSTEM::DO-F
-         ANSI-LOOP::LOOP-COLLECTOR-TEMPVARS COMMON-LISP::VECTOR-POP)) 
+         (COMMON-LISP::FUNCTION
+             ((COMMON-LISP::VECTOR COMMON-LISP::CHARACTER
+                  COMMON-LISP::*)
+              (COMMON-LISP::INTEGER -9223372036854775808
+                  9223372036854775807))
+             COMMON-LISP::FIXNUM)
+         SYSTEM::ATOI)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
-         (COMMON-LISP::FUNCTION (COMMON-LISP::*) COMMON-LISP::*)
-         SYSTEM::IHS-BACKTRACE SYSTEM::BREAK-NEXT SYSTEM::BREAK-QUIT
-         SYSTEM::SHOW-BREAK-VARIABLES SYSTEM::BREAK-BDS
-         COMMON-LISP::MUFFLE-WARNING SYSTEM::BREAK-PREVIOUS
-         SYSTEM::INFO-ERROR ANSI-LOOP::LOOP-OPTIONAL-TYPE
-         SYSTEM::DBL-BACKTRACE SYSTEM::BREAK-LOCAL SYSTEM::BREAK-VS
-         COMMON-LISP::CONTINUE)) 
+         (COMMON-LISP::FUNCTION (COMMON-LISP::T)
+             (COMMON-LISP::OR COMMON-LISP::NULL
+                 COMMON-LISP::HASH-TABLE))
+         SYSTEM::CONTEXT-HASH)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
-         (COMMON-LISP::FUNCTION (COMMON-LISP::FIXNUM)
-             COMMON-LISP::FIXNUM)
-         SYSTEM::DBL-WHAT-FRAME FPE::FE-ENABLE)) 
+         (COMMON-LISP::FUNCTION
+             (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
+                 COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*)
+             COMMON-LISP::*)
+         SYSTEM::PARSE-DEFMACRO-LAMBDA-LIST SYSTEM::PARSE-DEFMACRO)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
              (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*)
              COMMON-LISP::*)
-         COMMON-LISP::SUBTYPEP COMMON-LISP::REDUCE SYSTEM::PARSE-BODY
-         COMMON-LISP::STABLE-SORT COMMON-LISP::SORT
-         SLOOP::FIND-IN-ORDERED-LIST)) 
+         COMMON-LISP::SUBTYPEP COMMON-LISP::REDUCE
+         SLOOP::FIND-IN-ORDERED-LIST SYSTEM::PARSE-BODY
+         COMMON-LISP::STABLE-SORT COMMON-LISP::SORT)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
              (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T)
              COMMON-LISP::*)
-         SYSTEM::VERIFY-KEYWORDS SYSTEM::RESTART-PRINT
-         ANSI-LOOP::LOOP-GET-COLLECTION-INFO SYSTEM::LIST-MERGE-SORT
-         SYSTEM::READ-INSPECT-COMMAND SYSTEM::SHARP---READER
-         SYSTEM::SHARP-+-READER SYSTEM::SHARP-S-READER)) 
+         SYSTEM::SHARP-+-READER SYSTEM::SHARP---READER
+         SYSTEM::SHARP-S-READER ANSI-LOOP::LOOP-GET-COLLECTION-INFO
+         SYSTEM::VERIFY-KEYWORDS SYSTEM::LIST-MERGE-SORT
+         SYSTEM::RESTART-PRINT SYSTEM::READ-INSPECT-COMMAND)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
              (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
                  COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
-                 COMMON-LISP::T COMMON-LISP::T)
+                 COMMON-LISP::T)
              COMMON-LISP::*)
-         SYSTEM::PUSH-OPTIONAL-BINDING)) 
+         SYSTEM::TRACE-CALL)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
              (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
-                 COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*)
+                 COMMON-LISP::*)
              COMMON-LISP::*)
-         SYSTEM::PARSE-DEFMACRO-LAMBDA-LIST SYSTEM::PARSE-DEFMACRO)) 
+         SYSTEM::EXPAND-WILD-DIRECTORY SYSTEM::MASET)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
              (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
-                 COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
                  COMMON-LISP::T)
              COMMON-LISP::*)
-         SYSTEM::TRACE-CALL)) 
+         SYSTEM::MME3)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
              (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
-                 COMMON-LISP::*)
-             COMMON-LISP::*)
-         SYSTEM::MASET)) 
-(COMMON-LISP::PROCLAIM
-    '(COMMON-LISP::FTYPE
-         (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::FIXNUM)
-         FPE::REG-LOOKUP SYSTEM::INSTREAM-LINE SYSTEM::THE-START
-         SYSTEM::S-DATA-LENGTH SYSTEM::S-DATA-SIZE)) 
-(COMMON-LISP::PROCLAIM
-    '(COMMON-LISP::FTYPE
-         (COMMON-LISP::FUNCTION (COMMON-LISP::FIXNUM) COMMON-LISP::T)
-         SYSTEM::PUSH-CONTEXT SYSTEM::GET-CONTEXT)) 
-(COMMON-LISP::PROCLAIM
-    '(COMMON-LISP::FTYPE
-         (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::*)
-         SYSTEM::BREAK-CURRENT SYSTEM::GCL-TOP-LEVEL
-         SYSTEM::BREAK-MESSAGE SYSTEM::BREAK-RESUME
-         ANSI-LOOP::LOOP-DO-FOR SYSTEM::SIMPLE-BACKTRACE
-         SYSTEM::BREAK-HELP)) 
-(COMMON-LISP::PROCLAIM
-    '(COMMON-LISP::FTYPE
-         (COMMON-LISP::FUNCTION (COMMON-LISP::STRING) COMMON-LISP::T)
-         SYSTEM::COERCE-SLASH-TERMINATED SYSTEM::RESET-SYS-PATHS)) 
-(COMMON-LISP::PROCLAIM
-    '(COMMON-LISP::FTYPE
-         (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*)
-             COMMON-LISP::T)
-         COMMON-LISP::BIT COMMON-LISP::READ-BYTE
-         COMMON-LISP::CONCATENATE SYSTEM::INFO-SEARCH
-         COMMON-LISP::ARRAY-IN-BOUNDS-P ANSI-LOOP::LOOP-ERROR
-         ANSI-LOOP::LOOP-WARN COMMON-LISP::REMOVE-DUPLICATES
-         SYSTEM::BAD-SEQ-LIMIT SYSTEM::PROCESS-SOME-ARGS
-         ANSI-LOOP::LOOP-COLLECT-PREPOSITIONAL-PHRASES
-         SLOOP::LOOP-ADD-TEMPS COMMON-LISP::BIT-NOT COMMON-LISP::SIGNAL
-         SYSTEM::NTH-STACK-FRAME COMMON-LISP::ARRAY-ROW-MAJOR-INDEX
-         COMMON-LISP::MAKE-ARRAY SYSTEM::FILE-SEARCH
-         SYSTEM::LIST-MATCHES COMMON-LISP::FIND-RESTART
-         SYSTEM::BREAK-LEVEL COMMON-LISP::DELETE-DUPLICATES
-         SLOOP::ADD-FROM-DATA COMMON-LISP::ERROR COMMON-LISP::WARN
-         SYSTEM::FILE-TO-STRING
-         COMMON-LISP::UPGRADED-ARRAY-ELEMENT-TYPE COMMON-LISP::SBIT)) 
-(COMMON-LISP::PROCLAIM
-    '(COMMON-LISP::FTYPE
-         (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T)
+                 COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
+                 COMMON-LISP::T COMMON-LISP::T)
              COMMON-LISP::*)
-         SYSTEM::FIND-DOC SYSTEM::RESTART-REPORT
-         ANSI-LOOP::ESTIMATE-CODE-SIZE-1 SYSTEM::NEWLINE
-         ANSI-LOOP::ESTIMATE-CODE-SIZE SYSTEM::NEW-SEMI-COLON-READER)) 
+         SYSTEM::PUSH-OPTIONAL-BINDING)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION (COMMON-LISP::T)
              (COMMON-LISP::VALUES COMMON-LISP::T COMMON-LISP::T))
          SYSTEM::MAKE-KEYWORD)) 
-(COMMON-LISP::MAPC
-    (COMMON-LISP::LAMBDA (COMPILER::X)
-      (COMMON-LISP::SETF
-          (COMMON-LISP::GET COMPILER::X 'SYSTEM::PROCLAIMED-CLOSURE)
-          COMMON-LISP::T))
-    '(SYSTEM::SI-CLASS-PRECEDENCE-LIST SYSTEM::SI-CLASSP
-         SYSTEM::SIMPLE-CONDITION-CLASS-P SYSTEM::UNTRACE-ONE
-         SYSTEM::CONDITIONP SYSTEM::CONDITION-CLASS-P
-         SYSTEM::MAKE-ACCESS-FUNCTION SYSTEM::SI-CLASS-NAME
-         SYSTEM::AUTOLOAD-MACRO SYSTEM::AUTOLOAD SYSTEM::SI-CLASS-OF
-         SYSTEM::WARNINGP SYSTEM::DEFINE-STRUCTURE
-         FPE::BREAK-ON-FLOATING-POINT-EXCEPTIONS SYSTEM::SI-FIND-CLASS
-         SYSTEM::TRACE-ONE)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
-             (COMMON-LISP::T COMMON-LISP::FIXNUM COMMON-LISP::FIXNUM
+             (COMMON-LISP::T
+                 (COMMON-LISP::INTEGER -9223372036854775808
+                     9223372036854775807)
+                 (COMMON-LISP::INTEGER -9223372036854775808
+                     9223372036854775807)
                  COMMON-LISP::T COMMON-LISP::T)
              COMMON-LISP::T)
          SYSTEM::QUICK-SORT)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
-             (COMMON-LISP::T COMMON-LISP::FIXNUM COMMON-LISP::T
-                 COMMON-LISP::T)
+             (COMMON-LISP::T
+                 (COMMON-LISP::INTEGER -9223372036854775808
+                     9223372036854775807)
+                 COMMON-LISP::T COMMON-LISP::T)
              COMMON-LISP::T)
          SYSTEM::BIGNTHCDR)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
+             (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*)
+             COMMON-LISP::T)
+         COMMON-LISP::EVERY COMMON-LISP::SET-DIFFERENCE
+         SYSTEM::VECTOR-PUSH-STRING SYSTEM::PROCESS-ERROR
+         COMMON-LISP::POSITION-IF-NOT COMMON-LISP::FIND-IF
+         SLOOP::LOOP-ADD-BINDING COMMON-LISP::BIT-ORC1
+         COMMON-LISP::READ-SEQUENCE SYSTEM::INTERNAL-COUNT-IF
+         COMMON-LISP::COUNT COMMON-LISP::MISMATCH
+         COMMON-LISP::ADJUST-ARRAY COMMON-LISP::INTERSECTION
+         COMMON-LISP::UNION COMMON-LISP::DELETE-IF-NOT
+         COMMON-LISP::NINTERSECTION COMMON-LISP::BIT-ANDC1
+         COMMON-LISP::REMOVE-IF-NOT COMMON-LISP::TYPEP
+         COMMON-LISP::NUNION COMMON-LISP::WRITE-SEQUENCE
+         COMMON-LISP::VECTOR-PUSH-EXTEND COMMON-LISP::REMOVE
+         COMMON-LISP::BIT-IOR SLOOP::PARSE-LOOP-MACRO
+         COMMON-LISP::SEARCH COMMON-LISP::SUBSETP
+         COMMON-LISP::SET-EXCLUSIVE-OR SYSTEM::WREADDIR
+         COMMON-LISP::POSITION-IF COMMON-LISP::DELETE
+         COMMON-LISP::BIT-EQV COMMON-LISP::BIT-ANDC2
+         COMMON-LISP::BIT-AND COMMON-LISP::NSET-EXCLUSIVE-OR
+         SLOOP::IN-ARRAY-SLOOP-FOR ANSI-LOOP::LOOP-CHECK-DATA-TYPE
+         COMMON-LISP::POSITION COMMON-LISP::MAKE-SEQUENCE
+         COMMON-LISP::NOTEVERY COMMON-LISP::MAP-INTO
+         COMMON-LISP::REPLACE COMMON-LISP::NSET-DIFFERENCE
+         COMMON-LISP::FIND-IF-NOT COMMON-LISP::BIT-ORC2
+         COMMON-LISP::DELETE-IF COMMON-LISP::CERROR
+         COMMON-LISP::BIT-XOR COMMON-LISP::FIND COMMON-LISP::FILL
+         SYSTEM::INTERNAL-COUNT-IF-NOT COMMON-LISP::REMOVE-IF
+         COMMON-LISP::BIT-NAND COMMON-LISP::BIT-NOR COMMON-LISP::SOME
+         COMMON-LISP::COUNT-IF SYSTEM::BREAK-CALL
+         COMMON-LISP::COUNT-IF-NOT SYSTEM::FIND-IHS COMMON-LISP::NOTANY
+         SYSTEM::INTERNAL-COUNT)) 
+(COMMON-LISP::PROCLAIM
+    '(COMMON-LISP::FTYPE
+         (COMMON-LISP::FUNCTION
              (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T)
              COMMON-LISP::T)
-         ANSI-LOOP::LOOP-MAKE-ITERATION-VARIABLE ANSI-LOOP::LOOP-FOR-IN
-         SYSTEM::DEFMACRO* SYSTEM::APPLY-DISPLAY-FUN
-         SYSTEM::WARN-VERSION ANSI-LOOP::HIDE-VARIABLE-REFERENCE
-         SYSTEM::SHARP-U-READER ANSI-LOOP::LOOP-FOR-ACROSS
-         SYSTEM::DM-VL SYSTEM::GET-SLOT-POS
+         SYSTEM::PATHNAME-PARSE ANSI-LOOP::LOOP-TRANSLATE
+         SYSTEM::CHECK-S-DATA SYSTEM::MFR FPE::REF
+         ANSI-LOOP::LOOP-STANDARD-EXPANSION ANSI-LOOP::LOOP-FOR-ON
+         ANSI-LOOP::LOOP-SUM-COLLECTION SYSTEM::SHARP-DQ-READER
+         COMMON-LISP::DPB SYSTEM::CHECK-TRACE-ARGS
+         SLOOP::LOOP-PARSE-ADDITIONAL-COLLECTIONS SYSTEM::RECURSE-DIR
+         SYSTEM::SHARP-U-READER SYSTEM::FLOATING-POINT-ERROR
+         ANSI-LOOP::LOOP-FOR-IN ANSI-LOOP::HIDE-VARIABLE-REFERENCE
+         SYSTEM::GET-SLOT-POS SYSTEM::APPLY-DISPLAY-FUN
          SYSTEM::RESTART-CASE-EXPRESSION-CONDITION
-         SYSTEM::CHECK-TRACE-ARGS ANSI-LOOP::LOOP-FOR-ON FPE::REF
-         ANSI-LOOP::PRINT-LOOP-UNIVERSE ANSI-LOOP::LOOP-ANSI-FOR-EQUALS
-         SYSTEM::SETF-EXPAND-1 ANSI-LOOP::LOOP-SUM-COLLECTION
-         ANSI-LOOP::LOOP-STANDARD-EXPANSION SYSTEM::MAKE-T-TYPE
-         COMMON-LISP::DEPOSIT-FIELD SYSTEM::MAKE-BREAK-POINT
-         ANSI-LOOP::LOOP-FOR-BEING ANSI-LOOP::LOOP-TRANSLATE
-         SYSTEM::SHARP-A-READER COMMON-LISP::DPB
-         SYSTEM::FLOATING-POINT-ERROR SYSTEM::CHECK-S-DATA
-         SLOOP::LOOP-PARSE-ADDITIONAL-COLLECTIONS)) 
+         SYSTEM::MAKE-BREAK-POINT SYSTEM::TO-REGEXP-OR-NAMESTRING
+         COMMON-LISP::DEPOSIT-FIELD SYSTEM::SHARP-V-READER
+         SYSTEM::MAKE-T-TYPE ANSI-LOOP::LOOP-FOR-ACROSS
+         ANSI-LOOP::LOOP-ANSI-FOR-EQUALS ANSI-LOOP::PRINT-LOOP-UNIVERSE
+         ANSI-LOOP::LOOP-FOR-BEING SYSTEM::SHARP-P-READER SYSTEM::DM-VL
+         SYSTEM::SHARP-A-READER ANSI-LOOP::LOOP-MAKE-ITERATION-VARIABLE
+         SYSTEM::DEFMACRO* SYSTEM::SETF-EXPAND-1 SYSTEM::WARN-VERSION)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
              (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
-                 COMMON-LISP::T)
+                 COMMON-LISP::*)
              COMMON-LISP::T)
-         SLOOP::FIRST-USE-SLOOP-FOR SYSTEM::COERCE-TO-CONDITION SYSTEM::DO-BREAK-LEVEL
-         SLOOP::FIRST-SLOOP-FOR ANSI-LOOP::LOOP-FOR-ARITHMETIC
-         SYSTEM::MAYBE-BREAK SYSTEM::SETF-STRUCTURE-ACCESS
-         SYSTEM::CALL-TEST SYSTEM::FIND-LINE-IN-FUN)) 
+         SYSTEM::MME2 COMMON-LISP::NSUBSTITUTE SYSTEM::MATCH-COMPONENT
+         SYSTEM::COMPLETE-PROP SYSTEM::WALK-DIR
+         COMMON-LISP::TRANSLATE-PATHNAME ANSI-LOOP::ADD-LOOP-PATH
+         SYSTEM::DIR-PARSE ANSI-LOOP::LOOP-MAKE-VARIABLE
+         COMMON-LISP::SUBSTITUTE-IF COMMON-LISP::NSUBSTITUTE-IF
+         SYSTEM::PUSH-LET-BINDING COMMON-LISP::SUBSTITUTE
+         ANSI-LOOP::LOOP-HASH-TABLE-ITERATION-PATH COMMON-LISP::MAP
+         COMMON-LISP::SUBSTITUTE-IF-NOT COMMON-LISP::NSUBSTITUTE-IF-NOT
+         ANSI-LOOP::LOOP-PACKAGE-SYMBOLS-ITERATION-PATH
+         SLOOP::LOOP-DECLARE-BINDING
+         ANSI-LOOP::LOOP-SEQUENCE-ELEMENTS-PATH
+         SYSTEM::CHECK-TYPE-SYMBOL)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
-             (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*)
+             (COMMON-LISP::T COMMON-LISP::T
+                 (COMMON-LISP::INTEGER -9223372036854775808
+                     9223372036854775807))
              COMMON-LISP::T)
-         COMMON-LISP::COUNT-IF COMMON-LISP::BIT-ANDC2
-         COMMON-LISP::REMOVE SYSTEM::INTERNAL-COUNT-IF
-         SLOOP::LOOP-ADD-BINDING COMMON-LISP::MAP-INTO
-         COMMON-LISP::FIND-IF COMMON-LISP::NSET-DIFFERENCE
-         COMMON-LISP::UNION COMMON-LISP::NUNION
-         COMMON-LISP::MAKE-SEQUENCE COMMON-LISP::NOTANY
-         COMMON-LISP::POSITION COMMON-LISP::DELETE-IF
-         COMMON-LISP::BIT-ORC2 COMMON-LISP::REPLACE COMMON-LISP::DELETE
-         SYSTEM::BREAK-CALL COMMON-LISP::NINTERSECTION
-         COMMON-LISP::POSITION-IF SYSTEM::FIND-IHS COMMON-LISP::BIT-AND
-         COMMON-LISP::DELETE-IF-NOT ANSI-LOOP::LOOP-CHECK-DATA-TYPE
-         COMMON-LISP::REMOVE-IF COMMON-LISP::READ-SEQUENCE
-         SLOOP::PARSE-LOOP-MACRO COMMON-LISP::BIT-NAND
-         SYSTEM::INTERNAL-COUNT-IF-NOT COMMON-LISP::SUBSETP
-         COMMON-LISP::VECTOR-PUSH-EXTEND COMMON-LISP::EVERY
-         COMMON-LISP::SOME COMMON-LISP::WRITE-SEQUENCE
-         COMMON-LISP::MISMATCH COMMON-LISP::SET-EXCLUSIVE-OR
-         COMMON-LISP::REMOVE-IF-NOT COMMON-LISP::BIT-NOR
-         COMMON-LISP::BIT-XOR COMMON-LISP::BIT-EQV COMMON-LISP::SEARCH
-         COMMON-LISP::SET-DIFFERENCE COMMON-LISP::FILL
-         COMMON-LISP::CERROR COMMON-LISP::ADJUST-ARRAY
-         COMMON-LISP::BIT-ORC1 SYSTEM::INTERNAL-COUNT
-         COMMON-LISP::TYPEP SYSTEM::PROCESS-ERROR
-         COMMON-LISP::COUNT-IF-NOT COMMON-LISP::INTERSECTION
-         SLOOP::IN-ARRAY-SLOOP-FOR COMMON-LISP::FIND-IF-NOT
-         COMMON-LISP::BIT-ANDC1 COMMON-LISP::POSITION-IF-NOT
-         COMMON-LISP::NOTEVERY COMMON-LISP::NSET-EXCLUSIVE-OR
-         COMMON-LISP::FIND COMMON-LISP::COUNT COMMON-LISP::BIT-IOR)) 
+         SYSTEM::SHARP-EQ-READER SYSTEM::SHARP-SHARP-READER)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
              (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
-                 COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T)
+                 COMMON-LISP::T)
              COMMON-LISP::T)
-         SYSTEM::PUSH-SUB-LIST-BINDING SYSTEM::DO-ARG-COUNT-ERROR)) 
+         SYSTEM::ELSUB SLOOP::FIRST-USE-SLOOP-FOR
+         SLOOP::FIRST-SLOOP-FOR SYSTEM::SETF-STRUCTURE-ACCESS
+         SYSTEM::FIND-LINE-IN-FUN SYSTEM::COERCE-TO-CONDITION
+         ANSI-LOOP::LOOP-FOR-ARITHMETIC SYSTEM::MAYBE-BREAK
+         SYSTEM::ELEMENT SYSTEM::DO-BREAK-LEVEL SYSTEM::CALL-TEST)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
              (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
-                 COMMON-LISP::*)
+                 COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
+                 COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
+                 COMMON-LISP::T)
              COMMON-LISP::T)
-         ANSI-LOOP::ADD-LOOP-PATH COMMON-LISP::MAP
-         ANSI-LOOP::LOOP-HASH-TABLE-ITERATION-PATH
-         ANSI-LOOP::LOOP-PACKAGE-SYMBOLS-ITERATION-PATH
-         COMMON-LISP::SUBSTITUTE COMMON-LISP::NSUBSTITUTE
-         COMMON-LISP::NSUBSTITUTE-IF-NOT ANSI-LOOP::LOOP-MAKE-VARIABLE
-         COMMON-LISP::SUBSTITUTE-IF-NOT
-         ANSI-LOOP::LOOP-SEQUENCE-ELEMENTS-PATH
-         SYSTEM::PUSH-LET-BINDING COMMON-LISP::SUBSTITUTE-IF
-         SYSTEM::CHECK-TYPE-SYMBOL SLOOP::LOOP-DECLARE-BINDING
-         SYSTEM::COMPLETE-PROP COMMON-LISP::NSUBSTITUTE-IF)) 
+         ANSI-LOOP::LOOP-SEQUENCER)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
              (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
                  COMMON-LISP::T COMMON-LISP::T)
              COMMON-LISP::T)
-         SYSTEM::MAKE-PREDICATE
-         SYSTEM::MAKE-CONSTRUCTOR)) 
+         SYSTEM::MAKE-CONSTRUCTOR SYSTEM::MAKE-PREDICATE)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
              (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
-                 COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*)
-             COMMON-LISP::T)
-         SYSTEM::UNIVERSAL-ERROR-HANDLER)) 
-(COMMON-LISP::PROCLAIM
-    '(COMMON-LISP::FTYPE
-         (COMMON-LISP::FUNCTION
-             (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::FIXNUM)
+                 COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T)
              COMMON-LISP::T)
-         SYSTEM::SHARP-SHARP-READER SYSTEM::SHARP-EQ-READER)) 
+         SYSTEM::PUSH-SUB-LIST-BINDING SYSTEM::DO-ARG-COUNT-ERROR)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
              (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
                  COMMON-LISP::T COMMON-LISP::*)
              COMMON-LISP::T)
-         SLOOP::DEF-LOOP-INTERNAL SYSTEM::PRINT-STACK-FRAME
-         COMMON-LISP::MERGE)) 
+         SLOOP::DEF-LOOP-INTERNAL COMMON-LISP::MERGE
+         SYSTEM::PRINT-STACK-FRAME)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
@@ -369,154 +231,389 @@
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
              (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
-                 COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
-                 COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T
-                 COMMON-LISP::T)
+                 COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*)
              COMMON-LISP::T)
-         ANSI-LOOP::LOOP-SEQUENCER)) 
+         SYSTEM::UNIVERSAL-ERROR-HANDLER)) 
+(COMMON-LISP::PROCLAIM
+    '(COMMON-LISP::FTYPE
+         (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*)
+             COMMON-LISP::T)
+         COMMON-LISP::MERGE-PATHNAMES
+         COMMON-LISP::TRANSLATE-LOGICAL-PATHNAME ANSI-LOOP::LOOP-ERROR
+         COMMON-LISP::WILD-PATHNAME-P SLOOP::LOOP-ADD-TEMPS
+         SYSTEM::FILE-SEARCH SYSTEM::INFO-SEARCH
+         COMMON-LISP::PATHNAME-VERSION COMMON-LISP::WARN SYSTEM::MGSUB
+         COMMON-LISP::ARRAY-ROW-MAJOR-INDEX
+         COMMON-LISP::REMOVE-DUPLICATES COMMON-LISP::PATHNAME-NAME
+         COMMON-LISP::BIT COMMON-LISP::FIND-RESTART SYSTEM::TO-REGEXP
+         SYSTEM::PROCESS-SOME-ARGS COMMON-LISP::ERROR
+         COMMON-LISP::REQUIRE COMMON-LISP::OPEN
+         COMMON-LISP::UPGRADED-ARRAY-ELEMENT-TYPE SLOOP::ADD-FROM-DATA
+         SYSTEM::BREAK-LEVEL SYSTEM::LIST-MATCHES
+         COMMON-LISP::DELETE-DUPLICATES ANSI-LOOP::LOOP-WARN
+         COMMON-LISP::PATHNAME-DEVICE COMMON-LISP::LOAD
+         COMMON-LISP::PATHNAME-HOST COMMON-LISP::SBIT SYSTEM::NLOAD
+         COMMON-LISP::BIT-NOT COMMON-LISP::ENOUGH-NAMESTRING
+         COMMON-LISP::SIGNAL COMMON-LISP::ARRAY-IN-BOUNDS-P
+         COMMON-LISP::PATHNAME-TYPE SYSTEM::FILE-TO-STRING
+         SYSTEM::LOGICAL-PATHNAME-PARSE SYSTEM::NTH-STACK-FRAME
+         ANSI-LOOP::LOOP-COLLECT-PREPOSITIONAL-PHRASES SYSTEM::MGLIST
+         COMMON-LISP::DIRECTORY SYSTEM::BAD-SEQ-LIMIT
+         COMMON-LISP::PATHNAME-DIRECTORY COMMON-LISP::READ-BYTE
+         SYSTEM::LINK-EXPAND COMMON-LISP::CONCATENATE
+         COMMON-LISP::MAKE-ARRAY)) 
+(COMMON-LISP::PROCLAIM
+    '(COMMON-LISP::FTYPE
+         (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T)
+             COMMON-LISP::*)
+         SYSTEM::NEWLINE SYSTEM::LIST-TOGGLE-CASE
+         COMMON-LISP::RENAME-FILE ANSI-LOOP::ESTIMATE-CODE-SIZE
+         SYSTEM::SOURCE-PORTION SYSTEM::RESTART-REPORT SYSTEM::DO-REPL
+         SYSTEM::FIND-DOC ANSI-LOOP::ESTIMATE-CODE-SIZE-1
+         SYSTEM::NEW-SEMI-COLON-READER)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
-             (COMMON-LISP::STRING COMMON-LISP::FIXNUM)
+             ((COMMON-LISP::INTEGER -9223372036854775808
+                  9223372036854775807))
              COMMON-LISP::FIXNUM)
-         SYSTEM::ATOI)) 
+         FPE::FE-ENABLE SYSTEM::DBL-WHAT-FRAME)) 
+(COMMON-LISP::PROCLAIM
+    '(COMMON-LISP::FTYPE
+         (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*)
+             COMMON-LISP::*)
+         SYSTEM::INFO SYSTEM::GET-SETF-METHOD-MULTIPLE-VALUE
+         COMMON-LISP::FTRUNCATE COMMON-LISP::USE-VALUE
+         COMMON-LISP::INVOKE-RESTART COMMON-LISP::WRITE-TO-STRING
+         COMMON-LISP::FCEILING COMMON-LISP::FROUND
+         COMMON-LISP::READ-FROM-STRING COMMON-LISP::FFLOOR
+         SYSTEM::PARSE-BODY-HEADER SYSTEM::BREAK-FUNCTION
+         SYSTEM::APROPOS-DOC COMMON-LISP::APROPOS
+         COMMON-LISP::APROPOS-LIST
+         ANSI-LOOP::LOOP-CONSTANT-FOLD-IF-POSSIBLE
+         COMMON-LISP::GET-SETF-EXPANSION SYSTEM::PRINT-DOC
+         COMMON-LISP::PARSE-NAMESTRING
+         COMMON-LISP::ENSURE-DIRECTORIES-EXIST
+         COMMON-LISP::DECODE-UNIVERSAL-TIME SYSTEM::SHOW-INFO
+         COMMON-LISP::STORE-VALUE SYSTEM::STEPPER)) 
+(COMMON-LISP::PROCLAIM
+    '(COMMON-LISP::FTYPE
+         (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T)
+             COMMON-LISP::T)
+         COMMON-LISP::VECTOR-PUSH SYSTEM::DM-NTH COMMON-LISP::LOGORC1
+         SLOOP::L-EQUAL SLOOP::NEVER-SLOOP-COLLECT
+         COMMON-LISP::LDB-TEST COMMON-LISP::LDB COMMON-LISP::LOGORC2
+         SLOOP::COUNT-SLOOP-COLLECT SLOOP::MAXIMIZE-SLOOP-COLLECT
+         SYSTEM::ALL-MATCHES ANSI-LOOP::LOOP-TMEMBER SLOOP::THE-TYPE
+         SYSTEM::?PUSH SYSTEM::INCREMENT-CURSOR SYSTEM::SET-DIR
+         SYSTEM::DM-NTH-CDR SYSTEM::IN-INTERVAL-P SLOOP::MAKE-VALUE
+         SYSTEM::DBL-UP COMMON-LISP::COERCE SYSTEM::MATCH-DIMENSIONS
+         COMMON-LISP::LOGNAND SLOOP::=-SLOOP-FOR
+         SYSTEM::KEYWORD-SUPPLIED-P SYSTEM::OVERWRITE-SLOT-DESCRIPTIONS
+         SYSTEM::LEFT-PARENTHESIS-READER
+         ANSI-LOOP::LOOP-MAYBE-BIND-FORM SYSTEM::COERCE-TO-STRING
+         SYSTEM::ADD-FILE SLOOP::PARSE-LOOP-MAP COMMON-LISP::LOGNOR
+         SYSTEM::MSUB SYSTEM::SET-BACK SYSTEM::SUPER-GO
+         SYSTEM::SUBSTRINGP ANSI-LOOP::LOOP-TEQUAL
+         ANSI-LOOP::LOOP-DO-WHILE SYSTEM::GET-LINE-OF-FORM
+         FPE::READ-INSTRUCTION SYSTEM::SUB-INTERVAL-P
+         SYSTEM::CHECK-SEQ-START-END SYSTEM::*BREAK-POINTS*
+         ANSI-LOOP::MAKE-LOOP-MINIMAX SLOOP::IN-PACKAGE-SLOOP-MAP
+         SYSTEM::DM-V SYSTEM::INFO-AUX
+         ANSI-LOOP::HIDE-VARIABLE-REFERENCES
+         SLOOP::COLLATE-SLOOP-COLLECT COMMON-LISP::PATHNAME-MATCH-P
+         SYSTEM::SET-PATH-STREAM-NAME SLOOP::SUM-SLOOP-COLLECT
+         ANSI-LOOP::LOOP-LOOKUP-KEYWORD
+         ANSI-LOOP::LOOP-DECLARE-VARIABLE SYSTEM::BREAK-STEP-NEXT
+         FPE::RF SLOOP::IN-TABLE-SLOOP-MAP SYSTEM::OBJLT
+         FPE::READ-OPERANDS SYSTEM::BREAK-STEP-INTO COMMON-LISP::BYTE
+         SYSTEM::SEQUENCE-CURSOR SYSTEM::LIST-DELQ
+         SYSTEM::SETF-LOGICAL-PATHNAME-TRANSLATIONS
+         SYSTEM::CONDITION-PASS SYSTEM::SETF-HELPER FPE::0-READER
+         SYSTEM::DISPLAY-COMPILED-ENV COMMON-LISP::NTH
+         COMPILER::COMPILER-DEF-HOOK SYSTEM::DOT-DIR-P
+         COMMON-LISP::LOGTEST SYSTEM::QUOTATION-READER
+         SYSTEM::ITERATE-OVER-BKPTS COMMON-LISP::LOGANDC1
+         SLOOP::ALWAYS-SLOOP-COLLECT SLOOP::DESETQ1
+         SYSTEM::GET-INFO-CHOICES COMMON-LISP::WRITE-BYTE
+         ANSI-LOOP::LOOP-DO-IF ANSI-LOOP::LOOP-NOTE-MINIMAX-OPERATION
+         ANSI-LOOP::LOOP-TASSOC SLOOP::IN-CAREFULLY-SLOOP-FOR
+         COMMON-LISP::DOCUMENTATION FPE::PAREN-READER SYSTEM::GET-NODES
+         SYSTEM::PARSE-SLOT-DESCRIPTION SLOOP::IN-FRINGE-SLOOP-MAP
+         SYSTEM::SAFE-EVAL SYSTEM::DISPLAY-ENV FPE::%-READER
+         SLOOP::THEREIS-SLOOP-COLLECT SYSTEM::LOOKUP-KEYWORD
+         COMMON-LISP::LOGANDC2 COMMON-LISP::NTHCDR
+         SLOOP::MINIMIZE-SLOOP-COLLECT SYSTEM::GET-MATCH
+         SYSTEM::SETF-EXPAND SLOOP::LOGXOR-SLOOP-COLLECT
+         ANSI-LOOP::LOOP-DO-ALWAYS)) 
+(COMMON-LISP::PROCLAIM
+    '(COMMON-LISP::FTYPE
+         (COMMON-LISP::FUNCTION
+             ((COMMON-LISP::INTEGER -9223372036854775808
+                  9223372036854775807)
+              (COMMON-LISP::INTEGER -9223372036854775808
+                  9223372036854775807))
+             COMMON-LISP::FIXNUM)
+         SYSTEM::ROUND-UP)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION (COMMON-LISP::*) COMMON-LISP::T)
-         SYSTEM::DESCRIBE-ENVIRONMENT SYSTEM::STEP-NEXT
-         COMMON-LISP::BREAK COMMON-LISP::ABORT SYSTEM::MAKE-S-DATA
-         ANSI-LOOP::MAKE-LOOP-COLLECTOR SLOOP::PARSE-LOOP-DECLARE
-         ANSI-LOOP::LOOP-GENTEMP SYSTEM::MAKE-INSTREAM
-         SYSTEM::MAYBE-CLEAR-INPUT
-         ANSI-LOOP::MAKE-LOOP-MINIMAX-INTERNAL COMMON-LISP::Y-OR-N-P
-         SYSTEM::CURRENT-STEP-FUN ANSI-LOOP::LOOP-DISALLOW-CONDITIONAL
-         COMMON-LISP::DRIBBLE SYSTEM::MAKE-RESTART
-         SLOOP::PARSE-LOOP-WITH SYSTEM::LOC COMMON-LISP::YES-OR-NO-P
-         SYSTEM::TRANSFORM-KEYWORDS SYSTEM::MAKE-CONTEXT
-         COMMON-LISP::COMPUTE-RESTARTS SYSTEM::DBL-READ
-         SYSTEM::STEP-INTO ANSI-LOOP::MAKE-LOOP-UNIVERSE
-         SYSTEM::BREAK-LOCALS ANSI-LOOP::MAKE-STANDARD-LOOP-UNIVERSE
-         COMMON-LISP::VECTOR ANSI-LOOP::MAKE-LOOP-PATH)) 
+         COMMON-LISP::Y-OR-N-P COMMON-LISP::YES-OR-NO-P
+         COMMON-LISP::DRIBBLE COMMON-LISP::VECTOR SYSTEM::NEXT-MATCH
+         SYSTEM::MAKE-S-DATA SYSTEM::LOC SYSTEM::BREAK-LOCALS
+         SLOOP::PARSE-LOOP-WITH COMMON-LISP::USER-HOMEDIR-PATHNAME
+         SYSTEM::STEP-INTO SYSTEM::MAYBE-CLEAR-INPUT
+         ANSI-LOOP::MAKE-LOOP-PATH SYSTEM::STEP-NEXT
+         ANSI-LOOP::LOOP-GENTEMP COMMON-LISP::COMPUTE-RESTARTS
+         SYSTEM::CURRENT-STEP-FUN SYSTEM::MAKE-INSTREAM
+         ANSI-LOOP::MAKE-LOOP-COLLECTOR SYSTEM::MAKE-RESTART
+         SYSTEM::DESCRIBE-ENVIRONMENT SYSTEM::TRANSFORM-KEYWORDS
+         COMMON-LISP::ABORT ANSI-LOOP::MAKE-STANDARD-LOOP-UNIVERSE
+         ANSI-LOOP::MAKE-LOOP-UNIVERSE SLOOP::PARSE-LOOP-DECLARE
+         COMMON-LISP::BREAK ANSI-LOOP::LOOP-DISALLOW-CONDITIONAL
+         SYSTEM::MAKE-CONTEXT SYSTEM::DBL-READ
+         COMMON-LISP::MAKE-PATHNAME
+         ANSI-LOOP::MAKE-LOOP-MINIMAX-INTERNAL)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::*)
-         ANSI-LOOP::LOOP-LIST-STEP SYSTEM::INSPECT-OBJECT
-         COMMON-LISP::DESCRIBE ANSI-LOOP::LOOP-OPTIMIZATION-QUANTITIES
-         SYSTEM::BREAK-GO SYSTEM::GET-&ENVIRONMENT
-         COMMON-LISP::PRINC-TO-STRING SYSTEM::WAITING
-         SYSTEM::INSTREAM-NAME ANSI-LOOP::NAMED-VARIABLE
-         COMMON-LISP::PRIN1-TO-STRING SYSTEM::INFO-SUBFILE
-         COMMON-LISP::INSPECT SYSTEM::END-WAITING
-         SYSTEM::FIND-DECLARATIONS
-         COMMON-LISP::INVOKE-RESTART-INTERACTIVELY
-         SYSTEM::BREAK-LEVEL-INVOKE-RESTART SYSTEM::ALOAD)) 
+         ANSI-LOOP::LOOP-OPTIMIZATION-QUANTITIES SYSTEM::BREAK-GO
+         COMMON-LISP::FILE-AUTHOR SYSTEM::ENSURE-DIR-STRING
+         SYSTEM::INFO-SUBFILE COMMON-LISP::DESCRIBE SYSTEM::END-WAITING
+         COMMON-LISP::PRIN1-TO-STRING SYSTEM::FIND-DECLARATIONS
+         COMMON-LISP::INSPECT ANSI-LOOP::NAMED-VARIABLE
+         SYSTEM::GET-&ENVIRONMENT SYSTEM::INSPECT-OBJECT
+         COMMON-LISP::PRINC-TO-STRING ANSI-LOOP::LOOP-LIST-STEP
+         SYSTEM::INSTREAM-NAME SYSTEM::BREAK-LEVEL-INVOKE-RESTART
+         SYSTEM::WAITING COMMON-LISP::INVOKE-RESTART-INTERACTIVELY)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
-         (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T)
+         (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::T)
+         SYSTEM::IHS-NOT-INTERPRETED-ENV COMMON-LISP::NINTH
+         SYSTEM::FIND-KCL-TOP-RESTART COMMON-LISP::TRUENAME
+         SYSTEM::DIRECTORY-LIST-CHECK SYSTEM::REAL-ASINH
+         SYSTEM::SHOW-ENVIRONMENT SYSTEM::PRINT-FRS
+         SYSTEM::REWRITE-RESTART-CASE-CLAUSE
+         COMMON-LISP::TWO-WAY-STREAM-OUTPUT-STREAM
+         ANSI-LOOP::LOOP-COLLECTOR-DATA SLOOP::POINTER-FOR-COLLECT
+         SYSTEM::MLP SYSTEM::WILD-PATH-ELEMENT-P SYSTEM::LNP
+         ANSI-LOOP::LOOP-MINIMAX-OPERATIONS SYSTEM::FRS-KIND
+         SYSTEM::BKPT-FILE COMMON-LISP::FIFTH
+         ANSI-LOOP::LOOP-COLLECTOR-P ANSI-LOOP::LOOP-UNIVERSE-ANSI
+         ANSI-LOOP::LOOP-PATH-PREPOSITION-GROUPS SYSTEM::IDESCRIBE
+         ANSI-LOOP::LOOP-CONSTANTP
+         ANSI-LOOP::LOOP-UNIVERSE-FOR-KEYWORDS COMMON-LISP::PROBE-FILE
+         ANSI-LOOP::LOOP-UNIVERSE-P COMMON-LISP::SINH SYSTEM::RESTART-P
+         SYSTEM::S-DATA-DOCUMENTATION
+         COMMON-LISP::ECHO-STREAM-OUTPUT-STREAM
+         SYSTEM::FIND-DOCUMENTATION SYSTEM::INFO-GET-FILE
+         SLOOP::PARSE-NO-BODY COMMON-LISP::FILE-NAMESTRING
+         COMMON-LISP::COMPILER-MACRO-FUNCTION SYSTEM::PROCESS-ARGS
+         ANSI-LOOP::LOOP-COLLECTOR-DTYPE COMMON-LISP::PHASE
+         SYSTEM::MAKE-FRAME SYSTEM::INSTREAM-STREAM
+         ANSI-LOOP::LOOP-COLLECTOR-HISTORY SYSTEM::FIX-LOAD-PATH
+         SYSTEM::COMPUTING-ARGS-P
+         ANSI-LOOP::LOOP-MINIMAX-ANSWER-VARIABLE COMMON-LISP::TENTH
+         ANSI-LOOP::MAKE-ANSI-LOOP-UNIVERSE SYSTEM::WILD-NAMESTRING-P
+         SYSTEM::BEST-ARRAY-ELEMENT-TYPE SYSTEM::DM-BAD-KEY
+         SYSTEM::TERMINAL-INTERRUPT SYSTEM::REGEXP-CONV
+         COMMON-LISP::FILE-WRITE-DATE SLOOP::PARSE-LOOP
+         ANSI-LOOP::LOOP-CONSTRUCT-RETURN SYSTEM::DWIM
+         ANSI-LOOP::LOOP-UNIVERSE-TYPE-KEYWORDS
+         SLOOP::RETURN-SLOOP-MACRO SLOOP::AVERAGING-SLOOP-MACRO
+         SYSTEM::S-DATA-NAME SYSTEM::CHECK-TRACE-SPEC
+         SYSTEM::RESTRICT-STREAM-ELEMENT-TYPE SLOOP::TRANSLATE-NAME
+         SYSTEM::ADD-TO-HOTLIST SYSTEM::S-DATA-CONC-NAME
+         ANSI-LOOP::LOOP-MINIMAX-TYPE SYSTEM::PRINT-IHS
+         SYSTEM::DBL-RPL-LOOP SYSTEM::CANONICALIZE-PATHNAME-DIRECTORY
+         SYSTEM::INSPECT-CONS SYSTEM::INSTREAM-STREAM-NAME
+         SYSTEM::S-DATA-P SYSTEM::EVAL-FEATURE
+         COMMON-LISP::ARRAY-DIMENSIONS SYSTEM::IHS-VISIBLE
+         ANSI-LOOP::LOOP-MINIMAX-FLAG-VARIABLE
+         SYSTEM::CHECK-DECLARATIONS COMMON-LISP::TANH
+         ANSI-LOOP::LOOP-UNIVERSE-PATH-KEYWORDS
+         COMMON-LISP::COMPILE-FILE-PATHNAME SYSTEM::INSPECT-PACKAGE
+         SLOOP::LOOP-LET-BINDINGS COMMON-LISP::CIS SYSTEM::SETUP-INFO
+         SYSTEM::NORMALIZE-TYPE ANSI-LOOP::LOOP-PSEUDO-BODY
+         SYSTEM::PATH-STREAM-NAME SYSTEM::INFO-GET-TAGS FPE::ST-LOOKUP
+         SYSTEM::BREAK-BACKWARD-SEARCH-STACK
+         ANSI-LOOP::LOOP-MINIMAX-TEMP-VARIABLE SYSTEM::SIMPLE-ARRAY-P
+         SYSTEM::S-DATA-TYPE COMMON-LISP::CONCATENATED-STREAM-STREAMS
+         SYSTEM::INSPECT-CHARACTER ANSI-LOOP::DESTRUCTURING-SIZE
+         SYSTEM::GET-BYTE-STREAM-NCHARS ANSI-LOOP::LOOP-PATH-P
+         COMMON-LISP::FIRST COMMON-LISP::SECOND
+         COMMON-LISP::TWO-WAY-STREAM-INPUT-STREAM
+         SYSTEM::MAKE-DEFPACKAGE-FORM SYSTEM::INSPECT-SYMBOL
+         SYSTEM::INSPECT-VECTOR
+         COMMON-LISP::LOAD-LOGICAL-PATHNAME-TRANSLATIONS
+         SYSTEM::RESTART-INTERACTIVE-FUNCTION SYSTEM::INSPECT-STRING
+         SYSTEM::DIR-P ANSI-LOOP::LOOP-COLLECTOR-CLASS
+         SYSTEM::S-DATA-CONSTRUCTORS SYSTEM::NODES-FROM-INDEX
+         SYSTEM::VERSION-PARSE SYSTEM::BKPT-FILE-LINE COMMON-LISP::ABS
+         SYSTEM::IHS-FNAME ANSI-LOOP::LOOP-MAKE-PSETQ
+         SYSTEM::LEAP-YEAR-P ANSI-LOOP::LOOP-EMIT-FINAL-VALUE
+         SYSTEM::GET-PATH SYSTEM::ALOAD SYSTEM::DM-KEY-NOT-ALLOWED
+         SYSTEM::MAKE-KCL-TOP-RESTART SYSTEM::S-DATA-SLOT-DESCRIPTIONS
+         COMMON-LISP::VECTOR-POP ANSI-LOOP::LOOP-UNIVERSE-KEYWORDS
+         ANSI-LOOP::LOOP-PATH-USER-DATA SYSTEM::S-DATA-SLOT-POSITION
+         COMMON-LISP::BROADCAST-STREAM-STREAMS
+         SYSTEM::LOGICAL-PATHNAMEP SYSTEM::BREAK-FORWARD-SEARCH-STACK
+         SLOOP::SLOOP-SLOOP-MACRO COMMON-LISP::SIGNUM
+         SYSTEM::RESET-TRACE-DECLARATIONS SYSTEM::CONTEXT-P
+         SYSTEM::S-DATA-FROZEN SYSTEM::NUMBER-OF-DAYS-FROM-1900
+         SYSTEM::S-DATA-STATICP ANSI-LOOP::LOOP-PATH-FUNCTION
+         SYSTEM::KNOWN-TYPE-P COMMON-LISP::PROVIDE SYSTEM::PNL1
+         ANSI-LOOP::LOOP-CODE-DUPLICATION-THRESHOLD
+         SYSTEM::COERCE-SLASH-TERMINATED COMMON-LISP::LOGICAL-PATHNAME
+         SYSTEM::DIR-CONJ SYSTEM::BKPT-FORM
+         SYSTEM::LOGICAL-PATHNAME-HOST-P SYSTEM::INSPECT-STRUCTURE
+         ANSI-LOOP::LOOP-UNIVERSE-IMPLICIT-FOR-REQUIRED
+         COMMON-LISP::FIND-ALL-SYMBOLS
+         ANSI-LOOP::LOOP-UNIVERSE-ITERATION-KEYWORDS
+         ANSI-LOOP::LOOP-PATH-INCLUSIVE-PERMITTED
+         COMMON-LISP::LOGICAL-PATHNAME-TRANSLATIONS
+         SYSTEM::TRACE-ONE-PREPROCESS COMMON-LISP::CONSTANTLY
+         COMMON-LISP::ACOS SYSTEM::S-DATA-OFFSET COMMON-LISP::ASINH
+         SYSTEM::SHORT-NAME SYSTEM::S-DATA-INCLUDED SYSTEM::DBL-EVAL
+         SYSTEM::BKPT-FUNCTION SYSTEM::INSPECT-NUMBER
+         SYSTEM::GET-INSTREAM SYSTEM::SHOW-BREAK-POINT FPE::LOOKUP
+         SYSTEM::NEXT-STACK-FRAME SYSTEM::INSPECT-ARRAY
+         SYSTEM::S-DATA-RAW ANSI-LOOP::LOOP-MINIMAX-INFINITY-DATA
+         SYSTEM::RESTART-REPORT-FUNCTION SYSTEM::TOGGLE-CASE
+         SYSTEM::NODE-OFFSET SYSTEM::INSTREAM-P
+         ANSI-LOOP::LOOP-PATH-NAMES SYSTEM::FREEZE-DEFSTRUCT
+         COMMON-LISP::SEVENTH SYSTEM::SEARCH-STACK COMMON-LISP::SIXTH
+         ANSI-LOOP::LOOP-UNIVERSE-TYPE-SYMBOLS FPE::GREF
+         FPE::XMM-LOOKUP COMMON-LISP::HOST-NAMESTRING
+         ANSI-LOOP::LOOP-TYPED-INIT
+         SYSTEM::LOGICAL-PATHNAME-DESIGNATOR-P
+         ANSI-LOOP::LOOP-DO-THEREIS COMMON-LISP::EIGHTH
+         SYSTEM::UNIQUE-ID COMMON-LISP::THIRD
+         COMMON-LISP::BYTE-POSITION COMMON-LISP::SYNONYM-STREAM-SYMBOL
+         SYSTEM::PATCH-SHARP SYSTEM::PRINT-SYMBOL-APROPOS
+         COMMON-LISP::LOGNOT SLOOP::REPEAT-SLOOP-MACRO
+         COMMON-LISP::FOURTH SLOOP::SUBSTITUTE-SLOOP-BODY
+         COMMON-LISP::ATANH SLOOP::LOOP-COLLECT-KEYWORD-P
+         SYSTEM::SEQTYPE SYSTEM::RE-QUOTE-STRING COMMON-LISP::ISQRT
+         SYSTEM::DO-F SYSTEM::S-DATA-HAS-HOLES
+         ANSI-LOOP::LOOP-HACK-ITERATION ANSI-LOOP::LOOP-COLLECTOR-NAME
+         COMMON-LISP::RESTART-NAME COMMON-LISP::DIRECTORY-NAMESTRING
+         ANSI-LOOP::LOOP-EMIT-BODY COMMON-LISP::ACOSH
+         SYSTEM::RESTART-FUNCTION SYSTEM::INFO-NODE-FROM-POSITION
+         COMMON-LISP::ASIN ANSI-LOOP::LOOP-LIST-COLLECTION
+         SYSTEM::S-DATA-INCLUDES SYSTEM::GET-NEXT-VISIBLE-FUN
+         COMMON-LISP::BYTE-SIZE COMMON-LISP::PATHNAME
+         ANSI-LOOP::LOOP-MINIMAX-P SLOOP::PARSE-LOOP-INITIALLY
+         COMMON-LISP::COSH SYSTEM::EXPAND-HOME-DIR
+         COMMON-LISP::ECHO-STREAM-INPUT-STREAM
+         SYSTEM::INSERT-BREAK-POINT SYSTEM::RESTART-TEST-FUNCTION
+         SYSTEM::S-DATA-PRINT-FUNCTION SYSTEM::WILD-DIR-ELEMENT-P
+         SYSTEM::S-DATA-NAMED COMMON-LISP::INVOKE-DEBUGGER
+         COMMON-LISP::NAMESTRING ANSI-LOOP::LOOP-MAKE-DESETQ
+         COMMON-LISP::COMPLEMENT SYSTEM::WALK-THROUGH
+         COMMON-LISP::RATIONAL ANSI-LOOP::LOOP-MAXMIN-COLLECTION
+         COMMON-LISP::DELETE-FILE ANSI-LOOP::LOOP-COLLECTOR-TEMPVARS)) 
+(COMMON-LISP::PROCLAIM
+    '(COMMON-LISP::FTYPE
+         (COMMON-LISP::FUNCTION (COMMON-LISP::*) COMMON-LISP::*)
+         SYSTEM::BREAK-QUIT SYSTEM::BREAK-BDS SYSTEM::DBL-BACKTRACE
+         SYSTEM::BREAK-LOCAL SYSTEM::INFO-ERROR
+         SYSTEM::SHOW-BREAK-VARIABLES SYSTEM::BREAK-VS
+         COMMON-LISP::CONTINUE COMMON-LISP::MUFFLE-WARNING
+         SYSTEM::IHS-BACKTRACE ANSI-LOOP::LOOP-OPTIONAL-TYPE
+         SYSTEM::BREAK-PREVIOUS SYSTEM::BREAK-NEXT)) 
+(COMMON-LISP::PROCLAIM
+    '(COMMON-LISP::FTYPE
+         (COMMON-LISP::FUNCTION
+             ((COMMON-LISP::INTEGER -9223372036854775808
+                  9223372036854775807)
+              COMMON-LISP::T)
              COMMON-LISP::T)
-         ANSI-LOOP::MAKE-LOOP-MINIMAX COMMON-LISP::LDB
-         SYSTEM::LIST-DELQ FPE::RF SLOOP::L-EQUAL
-         ANSI-LOOP::LOOP-DECLARE-VARIABLE SYSTEM::DISPLAY-COMPILED-ENV
-         SYSTEM::SET-BACK ANSI-LOOP::HIDE-VARIABLE-REFERENCES
-         SYSTEM::GET-LINE-OF-FORM SYSTEM::BREAK-STEP-INTO
-         SLOOP::THE-TYPE SLOOP::COUNT-SLOOP-COLLECT
-         SYSTEM::KEYWORD-SUPPLIED-P COMMON-LISP::LOGANDC2
-         ANSI-LOOP::LOOP-MAYBE-BIND-FORM SYSTEM::SET-DIR
-         SYSTEM::COERCE-TO-STRING COMMON-LISP::VECTOR-PUSH
-         SYSTEM::DM-NTH-CDR SLOOP::IN-FRINGE-SLOOP-MAP
-         SLOOP::MAXIMIZE-SLOOP-COLLECT SYSTEM::ADD-FILE
-         SYSTEM::ALL-MATCHES SYSTEM::DM-NTH
-         SLOOP::IN-CAREFULLY-SLOOP-FOR SYSTEM::PARSE-SLOT-DESCRIPTION
-         ANSI-LOOP::LOOP-LOOKUP-KEYWORD FPE::0-READER
-         ANSI-LOOP::LOOP-TMEMBER COMPILER::COMPILER-DEF-HOOK
-         SYSTEM::INFO-AUX COMMON-LISP::NTH SYSTEM::QUOTATION-READER
-         SYSTEM::CHECK-SEQ-START-END COMMON-LISP::LOGNAND
-         SYSTEM::SUBSTRINGP COMMON-LISP::LOGORC2
-         ANSI-LOOP::LOOP-NOTE-MINIMAX-OPERATION SYSTEM::SAFE-EVAL
-         ANSI-LOOP::LOOP-DO-IF SLOOP::THEREIS-SLOOP-COLLECT
-         SYSTEM::MATCH-DIMENSIONS SYSTEM::GET-MATCH
-         SYSTEM::SUB-INTERVAL-P FPE::PAREN-READER
-         SLOOP::IN-TABLE-SLOOP-MAP COMMON-LISP::LOGTEST
-         SLOOP::LOGXOR-SLOOP-COLLECT SYSTEM::DM-V
-         SYSTEM::GET-INFO-CHOICES SLOOP::COLLATE-SLOOP-COLLECT
-         SYSTEM::BREAK-STEP-NEXT ANSI-LOOP::LOOP-TEQUAL
-         COMMON-LISP::WRITE-BYTE COMMON-LISP::NTHCDR
-         SYSTEM::SETF-HELPER SLOOP::NEVER-SLOOP-COLLECT SLOOP::DESETQ1
-         ANSI-LOOP::LOOP-DO-WHILE COMMON-LISP::DOCUMENTATION
-         FPE::%-READER SYSTEM::IN-INTERVAL-P SLOOP::SUM-SLOOP-COLLECT
-         SYSTEM::OBJLT COMMON-LISP::LDB-TEST SLOOP::PARSE-LOOP-MAP
-         SYSTEM::GET-NODES SLOOP::MAKE-VALUE SYSTEM::CONDITION-PASS
-         SLOOP::IN-PACKAGE-SLOOP-MAP SYSTEM::INCREMENT-CURSOR
-         ANSI-LOOP::LOOP-DO-ALWAYS SYSTEM::DISPLAY-ENV SYSTEM::SUPER-GO
-         SLOOP::MINIMIZE-SLOOP-COLLECT COMMON-LISP::LOGNOR
-         COMMON-LISP::LOGANDC1 COMMON-LISP::BYTE SYSTEM::DBL-UP
-         SYSTEM::ITERATE-OVER-BKPTS COMMON-LISP::LOGORC1
-         FPE::READ-OPERANDS SLOOP::ALWAYS-SLOOP-COLLECT
-         SYSTEM::SETF-EXPAND SYSTEM::OVERWRITE-SLOT-DESCRIPTIONS
-         SYSTEM::*BREAK-POINTS* SYSTEM::LOOKUP-KEYWORD
-         ANSI-LOOP::LOOP-TASSOC SYSTEM::LEFT-PARENTHESIS-READER
-         SLOOP::=-SLOOP-FOR FPE::READ-INSTRUCTION COMMON-LISP::COERCE
-         SYSTEM::SEQUENCE-CURSOR)) 
+         SYSTEM::SMALLNTHCDR)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
-         (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*)
-             COMMON-LISP::*)
-         COMMON-LISP::FFLOOR SYSTEM::BREAK-FUNCTION
-         COMMON-LISP::APROPOS-LIST COMMON-LISP::DECODE-UNIVERSAL-TIME
-         SYSTEM::STEPPER COMMON-LISP::REQUIRE SYSTEM::APROPOS-DOC
-         SYSTEM::PRINT-DOC SYSTEM::INFO COMMON-LISP::USE-VALUE
-         COMMON-LISP::WRITE-TO-STRING COMMON-LISP::FCEILING
-         SYSTEM::GET-SETF-METHOD
-         ANSI-LOOP::LOOP-CONSTANT-FOLD-IF-POSSIBLE SYSTEM::NLOAD
-         COMMON-LISP::ENSURE-DIRECTORIES-EXIST
-         COMMON-LISP::WILD-PATHNAME-P COMMON-LISP::FTRUNCATE
-         COMMON-LISP::FROUND SYSTEM::PARSE-BODY-HEADER
-         COMMON-LISP::INVOKE-RESTART SYSTEM::SHOW-INFO
-         COMMON-LISP::READ-FROM-STRING
-         SYSTEM::GET-SETF-METHOD-MULTIPLE-VALUE COMMON-LISP::APROPOS
-         COMMON-LISP::STORE-VALUE)) 
+         (COMMON-LISP::FUNCTION (COMMON-LISP::T)
+             COMMON-LISP::HASH-TABLE)
+         SYSTEM::CONTEXT-SPICE)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
-         (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::T)
-         ANSI-LOOP::LOOP-DO-WITH SYSTEM::WINE-TMP-REDIRECT
-         SLOOP::PARSE-ONE-WHEN-CLAUSE COMMON-LISP::TYPE-ERROR
-         SYSTEM::INSPECT-INDENT SYSTEM::SET-CURRENT SYSTEM::TEST-ERROR
-         SLOOP::LOOP-POP ANSI-LOOP::LOOP-DO-REPEAT
-         ANSI-LOOP::LOOP-GET-PROGN SYSTEM::DM-TOO-FEW-ARGUMENTS
-         ANSI-LOOP::LOOP-CONTEXT SYSTEM::READ-EVALUATED-FORM
-         SYSTEM::ALL-TRACE-DECLARATIONS
-         COMMON-LISP::LISP-IMPLEMENTATION-VERSION
-         SYSTEM::DEFAULT-SYSTEM-BANNER ANSI-LOOP::LOOP-DO-RETURN
-         SYSTEM::INSPECT-INDENT-1 SYSTEM::STEP-READ-LINE
-         SYSTEM::SET-ENV SYSTEM::DM-TOO-MANY-ARGUMENTS
-         ANSI-LOOP::LOOP-BIND-BLOCK SLOOP::PARSE-LOOP1
-         ANSI-LOOP::LOOP-DO-NAMED SLOOP::PARSE-LOOP-COLLECT
-         SYSTEM::KCL-TOP-RESTARTS SYSTEM::INSPECT-READ-LINE
-         SYSTEM::SET-UP-TOP-LEVEL SYSTEM::SHOW-RESTARTS SYSTEM::DBL
-         SLOOP::PARSE-LOOP-FOR ANSI-LOOP::LOOP-ITERATION-DRIVER
-         ANSI-LOOP::LOOP-WHEN-IT-VARIABLE ANSI-LOOP::LOOP-DO-DO
-         SYSTEM::DEFAULT-INFO-HOTLIST SYSTEM::GET-TEMP-DIR
-         ANSI-LOOP::LOOP-POP-SOURCE SLOOP::LOOP-UN-POP
-         SYSTEM::TOP-LEVEL ANSI-LOOP::LOOP-DO-FINALLY
-         ANSI-LOOP::LOOP-DO-INITIALLY SYSTEM::GET-INDEX-NODE
-         SYSTEM::SETUP-LINEINFO SLOOP::PARSE-LOOP-WHEN SYSTEM::CLEANUP
-         ANSI-LOOP::LOOP-GET-FORM SLOOP::PARSE-LOOP-DO
-         SYSTEM::INIT-BREAK-POINTS SLOOP::LOOP-PEEK
-         SYSTEM::GET-SIG-FN-NAME SYSTEM::ILLEGAL-BOA)) 
+         (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::FIXNUM)
+         SYSTEM::S-DATA-SIZE FPE::REG-LOOKUP SYSTEM::INSTREAM-LINE
+         SYSTEM::S-DATA-LENGTH SYSTEM::THE-START)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
-         (COMMON-LISP::FUNCTION (COMMON-LISP::FIXNUM COMMON-LISP::T)
+         (COMMON-LISP::FUNCTION (COMMON-LISP::FIXNUM) COMMON-LISP::T)
+         SYSTEM::MATCH-BEGINNING SYSTEM::MATCH-END)) 
+(COMMON-LISP::MAPC
+    (COMMON-LISP::LAMBDA (COMPILER::X)
+      (COMMON-LISP::SETF
+          (COMMON-LISP::GET COMPILER::X 'COMPILER::PROCLAIMED-CLOSURE)
+          COMMON-LISP::T))
+    '(SYSTEM::CONDITION-CLASS-P SYSTEM::WARNINGP SYSTEM::SI-CLASS-OF
+         SYSTEM::SI-FIND-CLASS SYSTEM::DEFINE-STRUCTURE
+         FPE::BREAK-ON-FLOATING-POINT-EXCEPTIONS
+         SYSTEM::SIMPLE-CONDITION-CLASS-P SYSTEM::AUTOLOAD
+         SYSTEM::SI-CLASS-PRECEDENCE-LIST SYSTEM::SI-CLASS-NAME
+         SYSTEM::TRACE-ONE SYSTEM::MAKE-ACCESS-FUNCTION
+         SYSTEM::UNTRACE-ONE SYSTEM::SI-CLASSP SYSTEM::CONDITIONP
+         SYSTEM::AUTOLOAD-MACRO)) 
+(COMMON-LISP::PROCLAIM
+    '(COMMON-LISP::FTYPE
+         (COMMON-LISP::FUNCTION
+             ((COMMON-LISP::INTEGER -9223372036854775808
+                  9223372036854775807))
              COMMON-LISP::T)
-         SYSTEM::SMALLNTHCDR)) 
+         SYSTEM::GET-CONTEXT SYSTEM::PUSH-CONTEXT)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T)
              COMMON-LISP::FIXNUM)
-         SYSTEM::THE-END ANSI-LOOP::DUPLICATABLE-CODE-P
-         SYSTEM::RELATIVE-LINE SYSTEM::GET-NODE-INDEX)) 
+         SYSTEM::RELATIVE-LINE SYSTEM::LENEL SYSTEM::THE-END
+         ANSI-LOOP::DUPLICATABLE-CODE-P SYSTEM::FASLINK
+         SYSTEM::GET-NODE-INDEX)) 
+(COMMON-LISP::PROCLAIM
+    '(COMMON-LISP::FTYPE
+         (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::T)
+         SLOOP::PARSE-ONE-WHEN-CLAUSE ANSI-LOOP::LOOP-DO-FINALLY
+         SLOOP::LOOP-PEEK ANSI-LOOP::LOOP-DO-INITIALLY SLOOP::LOOP-POP
+         ANSI-LOOP::LOOP-GET-PROGN SYSTEM::KCL-TOP-RESTARTS
+         SYSTEM::INSPECT-READ-LINE SLOOP::PARSE-LOOP-WHEN
+         ANSI-LOOP::LOOP-GET-FORM SYSTEM::DEFAULT-SYSTEM-BANNER
+         SYSTEM::SET-UP-TOP-LEVEL SYSTEM::GET-INDEX-NODE
+         ANSI-LOOP::LOOP-DO-DO ANSI-LOOP::LOOP-WHEN-IT-VARIABLE
+         SYSTEM::SETUP-LINEINFO COMMON-LISP::TYPE-ERROR
+         SYSTEM::READ-EVALUATED-FORM SYSTEM::INSPECT-INDENT-1
+         SLOOP::LOOP-UN-POP SLOOP::PARSE-LOOP-DO
+         ANSI-LOOP::LOOP-DO-WITH SYSTEM::INSPECT-INDENT
+         SYSTEM::GET-TEMP-DIR ANSI-LOOP::LOOP-ITERATION-DRIVER
+         SYSTEM::WINE-TMP-REDIRECT SLOOP::PARSE-LOOP-COLLECT
+         SYSTEM::DEFAULT-INFO-HOTLIST SLOOP::PARSE-LOOP1
+         SYSTEM::CLEANUP ANSI-LOOP::LOOP-DO-NAMED SYSTEM::DBL
+         SYSTEM::ALL-TRACE-DECLARATIONS SYSTEM::TEST-ERROR
+         ANSI-LOOP::LOOP-BIND-BLOCK ANSI-LOOP::LOOP-DO-REPEAT
+         SYSTEM::ILLEGAL-BOA SYSTEM::SET-ENV SYSTEM::SET-CURRENT
+         SYSTEM::INIT-BREAK-POINTS SYSTEM::GET-SIG-FN-NAME
+         ANSI-LOOP::LOOP-DO-RETURN ANSI-LOOP::LOOP-CONTEXT
+         SYSTEM::SHOW-RESTARTS SYSTEM::STEP-READ-LINE
+         SLOOP::PARSE-LOOP-FOR SYSTEM::DM-TOO-MANY-ARGUMENTS
+         COMMON-LISP::LISP-IMPLEMENTATION-VERSION SYSTEM::TOP-LEVEL
+         ANSI-LOOP::LOOP-POP-SOURCE SYSTEM::DM-TOO-FEW-ARGUMENTS)) 
 (COMMON-LISP::PROCLAIM
     '(COMMON-LISP::FTYPE
          (COMMON-LISP::FUNCTION
-             (COMMON-LISP::FIXNUM COMMON-LISP::FIXNUM)
-             COMMON-LISP::FIXNUM)
-         SYSTEM::ROUND-UP))
+             ((COMMON-LISP::VECTOR COMMON-LISP::CHARACTER
+                  COMMON-LISP::*))
+             COMMON-LISP::T)
+         SYSTEM::RESET-SYS-PATHS)) 
+(COMMON-LISP::PROCLAIM
+    '(COMMON-LISP::FTYPE
+         (COMMON-LISP::FUNCTION (COMMON-LISP::T)
+             (COMMON-LISP::VECTOR COMMON-LISP::T))
+         SYSTEM::CONTEXT-VEC)) 
+(COMMON-LISP::PROCLAIM
+    '(COMMON-LISP::FTYPE
+         (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::*)
+         SYSTEM::BREAK-HELP SYSTEM::BREAK-MESSAGE
+         SYSTEM::SIMPLE-BACKTRACE ANSI-LOOP::LOOP-DO-FOR
+         SYSTEM::BREAK-CURRENT SYSTEM::GCL-TOP-LEVEL
+         SYSTEM::BREAK-RESUME)) 
\ No newline at end of file
--- gcl-2.6.12.orig/o/alloc.c
+++ gcl-2.6.12/o/alloc.c
@@ -447,7 +447,6 @@ set_tm_maxpage(struct typemanager *tm,fi
   
   fixnum r=tm->tm_type==t_relocatable,j=tm->tm_maxpage,z=(n-j)*(r ? 2 : 1);
   if (z>available_pages) return 0;
-  if (r && 2*n+page(rb_start)>real_maxpage) return 0;
   available_pages-=z;
   tm->tm_adjgbccnt*=((double)j+1)/(n+1);
   tm->tm_maxpage=n;
@@ -909,7 +908,7 @@ alloc_after_reclaiming_pages(struct type
 
   fixnum m=tpage(tm,n),reloc_min;
 
-  if (tm->tm_type>=t_end) return NULL;
+  if (tm->tm_type>t_end) return NULL;
 
   reloc_min=npage(rb_pointer-rb_start);
 
@@ -925,6 +924,8 @@ alloc_after_reclaiming_pages(struct type
 
   }
 
+  if (tm->tm_type>=t_end) return NULL;
+
   maybe_reallocate_page(tm,tm->tm_percent_free*tm->tm_npage);
 
   return alloc_from_freelist(tm,n);
@@ -1093,8 +1094,7 @@ DEFUNM_NEW("ALLOCATED",object,fSallocate
 	     RV(make_fixnum(tm->tm_maxpage)),
 	     RV(make_fixnum(tm->tm_nppage)),
 	     RV(make_fixnum(tm->tm_gbccount)),
-	     RV(make_fixnum(tm->tm_npage*tm->tm_nppage-tm->tm_nfree))
-	     ));
+	     RV(make_fixnum(tm->tm_npage*tm->tm_nppage-tm->tm_nfree))));
 }
  
 #ifdef SGC_CONT_DEBUG
@@ -1658,7 +1658,7 @@ DEFUN_NEW("GPROF-QUIT",object,fSgprof_qu
   massert(getcwd(b,sizeof(b)));
   massert(!chdir(P_tmpdir));
   _mcleanup();
-  massert(snprintf(b1,sizeof(b1),"gprof %s",kcl_self)>0);
+  massert(snprintf(b1,sizeof(b1),"gprof '%s'",kcl_self)>0);
   massert((pp=popen(b1,"r")));
   while ((n=fread(b1,1,sizeof(b1),pp)))
     massert(fwrite(b1,1,n,stdout));
--- gcl-2.6.12.orig/o/array.c
+++ gcl-2.6.12/o/array.c
@@ -1139,9 +1139,9 @@ Icheck_displaced(object displaced_list,
 /*  } */
 /* } */
 
-DEFUNO_NEW("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE,
-       OO,OO,OO,OO,void,siLreplace_array,(object old,object new),"")
-{ struct dummy fw ;
+DEFUN_NEW("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE,OO,OO,OO,OO,(object old,object new),"") {
+
+  struct dummy fw;
   fw = old->d;
 
   old = IisArray(old);
--- gcl-2.6.12.orig/o/bind.c
+++ gcl-2.6.12/o/bind.c
@@ -24,7 +24,6 @@ Foundation, 675 Mass Ave, Cambridge, MA
 */
 
 #include "include.h"
-#include <string.h>
 
 static void
 illegal_lambda(void);
@@ -95,17 +94,19 @@ lambda_bind(object *arg_top)
 	struct aux *aux=NULL;
 	int naux;
 	bool special_processed;
+	object s[1],ss;
 	vs_mark;
 
 	bds_check;
 	lambda = vs_head;
-	if (type_of(lambda) != t_cons)
+	if (!consp(lambda))
 		FEerror("No lambda list.", 0);
 	lambda_list = lambda->c.c_car;
 	body = lambda->c.c_cdr;
 
 	required = (struct required *)vs_top;
 	nreq = 0;
+	s[0]=Cnil;
 	for (;;) {
 		if (endp(lambda_list))
 			goto REQUIRED_ONLY;
@@ -152,7 +153,7 @@ OPTIONAL:
 			goto SEARCH_DECLARE;
 		x = lambda_list->c.c_car;
 		lambda_list = lambda_list->c.c_cdr;
-		if (type_of(x) == t_cons) {
+		if (consp(x)) {
 			check_symbol(x->c.c_car);
 			check_var(x->c.c_car);
 			vs_push(x->c.c_car);
@@ -226,9 +227,9 @@ KEYWORD:
 			goto SEARCH_DECLARE;
 		x = lambda_list->c.c_car;
 		lambda_list = lambda_list->c.c_cdr;
-		if (type_of(x) == t_cons) {
-			if (type_of(x->c.c_car) == t_cons) {
-				if (!keywordp(x->c.c_car->c.c_car))
+		if (consp(x)) {
+			if (consp(x->c.c_car)) {
+				if (type_of(x->c.c_car->c.c_car)!=t_symbol)
 				  /* FIXME better message */
 					FEunexpected_keyword(x->c.c_car->c.c_car);
 				vs_push(x->c.c_car->c.c_car);
@@ -296,7 +297,7 @@ AUX_L:
 			goto SEARCH_DECLARE;
 		x = lambda_list->c.c_car;
 		lambda_list = lambda_list->c.c_cdr;
-		if (type_of(x) == t_cons) {
+		if (consp(x)) {
 			check_symbol(x->c.c_car);
 			check_var(x->c.c_car);
 			vs_push(x->c.c_car);
@@ -336,10 +337,10 @@ SEARCH_DECLARE:
 				break;
 			continue;
 		}
-		if (type_of(form)!=t_cons || !isdeclare(form->c.c_car))
+		if (!consp(form) || !isdeclare(form->c.c_car))
 			break;
 		for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) {
-			if (type_of(ds->c.c_car) != t_cons)
+			if (!consp(ds->c.c_car))
 				illegal_declare(form);
 			if (ds->c.c_car->c.c_car == sLspecial) {
 				vs = ds->c.c_car->c.c_cdr;
@@ -381,8 +382,7 @@ SEARCH_DECLARE:
 		}
 	if (special_processed)
 		continue;
-	/*  lex_special_bind(v);  */
-	lex_env[0] = MMcons(MMcons(v, Cnil), lex_env[0]);
+	s[0] = MMcons(MMcons(v, Cnil), s[0]);
 
 /**/
 				}
@@ -437,17 +437,20 @@ SEARCH_DECLARE:
 		bind_var(rest->rest_var, vs_head, rest->rest_spp);
 	}
 	if (key_flag) {
+                int allow_other_keys_found=0;
 		i = narg - nreq - nopt;
 		if (i >= 0 && i%2 != 0)
 		  /* FIXME better message */
 		  FEunexpected_keyword(Cnil);
 		other_keys_appeared = FALSE;
 		for (i = nreq + nopt;  i < narg;  i += 2) {
-			if (!keywordp(base[i]))
+			if (type_of(base[i])!=t_symbol)
 				FEunexpected_keyword(base[i]);
-			if (base[i] == sKallow_other_keys &&
-			    base[i+1] != Cnil)
+			if (base[i] == sKallow_other_keys && !allow_other_keys_found) {
+			    allow_other_keys_found=1;
+			    if (base[i+1] != Cnil)
 				allow_other_keys_flag = TRUE;
+                        }
 			for (j = 0;  j < nkey;  j++) {
 				if (keyword[j].key_word == base[i]) {
 					if (keyword[j].key_svar_val
@@ -460,7 +463,8 @@ SEARCH_DECLARE:
 					goto NEXT_ARG;
 				}
 			}
-			other_keys_appeared = TRUE;
+                        if (base[i] != sKallow_other_keys)
+			  other_keys_appeared = TRUE;
 
 		NEXT_ARG:
 			continue;
@@ -492,7 +496,7 @@ SEARCH_DECLARE:
 		eval_assign(temporary, aux[i].aux_init);
 		bind_var(aux[i].aux_var, temporary, aux[i].aux_spp);
 	}
-	if (type_of(body) != t_cons || body->c.c_car == form) {
+	if (!consp(body) || body->c.c_car == form) {
 		vs_reset;
 		vs_head = body;
 	} else {
@@ -500,6 +504,13 @@ SEARCH_DECLARE:
 		vs_reset;
 		vs_head = body;
 	}
+
+	if (s[0]!=Cnil) {
+	  for (ss=s[0];ss->c.c_cdr!=Cnil;ss=ss->c.c_cdr);
+	  ss->c.c_cdr=lex_env[0];
+	  lex_env[0]=s[0];
+	}
+
 	return;
 
 REQUIRED_ONLY:
@@ -515,10 +526,10 @@ REQUIRED_ONLY:
 				break;
 			continue;
 		}
-		if (type_of(form)!=t_cons || !isdeclare(form->c.c_car))
+		if (!consp(form) || !isdeclare(form->c.c_car))
 			break;
 		for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) {
-			if (type_of(ds->c.c_car) != t_cons)
+			if (!consp(ds->c.c_car))
 				illegal_declare(form);
 			if (ds->c.c_car->c.c_car == sLspecial) {
 				vs = ds->c.c_car->c.c_cdr;
@@ -537,7 +548,7 @@ REQUIRED_ONLY:
 		continue;
 	/*  lex_special_bind(v);  */
 	temporary = MMcons(v, Cnil);
-	lex_env[0] = MMcons(temporary, lex_env[0]);
+	s[0] = MMcons(temporary, s[0]);
 
 /**/
 				}
@@ -555,7 +566,7 @@ REQUIRED_ONLY:
 		bind_var(required[i].req_var,
 			 base[i],
 			 required[i].req_spp);
-	if (type_of(body) != t_cons || body->c.c_car == form) {
+	if (!consp(body) || body->c.c_car == form) {
 		vs_reset;
 		vs_head = body;
 	} else {
@@ -563,6 +574,13 @@ REQUIRED_ONLY:
 		vs_reset;
 		vs_head = body;
 	}
+
+	if (s[0]!=Cnil) {
+	  for (ss=s[0];ss->c.c_cdr!=Cnil;ss=ss->c.c_cdr);
+	  ss->c.c_cdr=lex_env[0];
+	  lex_env[0]=s[0];
+	}
+
 }
 
 void
@@ -612,7 +630,7 @@ struct bind_temp {
 */
 
 object
-find_special(object body, struct bind_temp *start, struct bind_temp *end)
+find_special(object body, struct bind_temp *start, struct bind_temp *end,object *s)
 { 
         object temporary;
 	object form=Cnil;
@@ -622,6 +640,7 @@ find_special(object body, struct bind_te
 	vs_mark;
 
 	vs_push(Cnil);
+	s=s ? s : lex_env;
 	for (;  !endp(body);  body = body->c.c_cdr) {
 		form = body->c.c_car;
 
@@ -634,10 +653,10 @@ find_special(object body, struct bind_te
 				break;
 			continue;
 		}
-		if (type_of(form)!=t_cons || !isdeclare(form->c.c_car))
+		if (!consp(form) || !isdeclare(form->c.c_car))
 			break;
 		for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) {
-			if (type_of(ds->c.c_car) != t_cons)
+			if (!consp(ds->c.c_car))
 				illegal_declare(form);
 			if (ds->c.c_car->c.c_car == sLspecial) {
 				vs = ds->c.c_car->c.c_cdr;
@@ -655,14 +674,14 @@ find_special(object body, struct bind_te
 		continue;
 	/*  lex_special_bind(v);  */
 	temporary = MMcons(v, Cnil);
-	lex_env[0] = MMcons(temporary, lex_env[0]);
+	s[0] = MMcons(temporary, s[0]);
 /**/
 				}
 			}
 		}
 	}
 
-	if (body != Cnil && body->c.c_car != form)
+	if (body != Cnil && body->c.c_car != form && type_of(form)==t_cons && isdeclare(form->c.c_car))/*FIXME*/
 		body = make_cons(form, body->c.c_cdr);
 	vs_reset;
 	return(body);
@@ -674,10 +693,10 @@ let_bind(object body, struct bind_temp *
 	struct bind_temp *bt;
 
 	bds_check;
-	vs_push(find_special(body, start, end));
 	for (bt = start;  bt < end;  bt++) {
 		eval_assign(bt->bt_init, bt->bt_init);
 	}
+	vs_push(find_special(body, start, end,NULL));
 	for (bt = start;  bt < end;  bt++) {
 		bind_var(bt->bt_var, bt->bt_init, bt->bt_spp);
 	}
@@ -688,13 +707,20 @@ object
 letA_bind(object body, struct bind_temp *start, struct bind_temp *end)
 {
 	struct bind_temp *bt;
-	
+	object s[1],ss;
+
 	bds_check;
-	vs_push(find_special(body, start, end));
+	s[0]=Cnil;
+	vs_push(find_special(body, start, end,s));
 	for (bt = start;  bt < end;  bt++) {
 		eval_assign(bt->bt_init, bt->bt_init);
 		bind_var(bt->bt_var, bt->bt_init, bt->bt_spp);
 	}
+	if (s[0]!=Cnil) {
+	  for (ss=s[0];ss->c.c_cdr!=Cnil;ss=ss->c.c_cdr);
+	  ss->c.c_cdr=lex_env[0];
+	  lex_env[0]=s[0];
+	}
 	return(vs_pop);
 }
 
@@ -703,12 +729,12 @@ letA_bind(object body, struct bind_temp
 
 #endif
 
-#define	NOT_YET		10
-#define	FOUND		11
+#define	NOT_YET		stp_ordinary
+#define	FOUND		stp_special
 #define	NOT_KEYWORD	1
 
 void
-parse_key(object *base, bool rest, bool allow_other_keys,int n, ...)
+parse_key(object *base, bool rest, bool allow_other_keys, int n, ...)
 { 
         object temporary;
 	va_list ap;
@@ -735,7 +761,7 @@ parse_key(object *base, bool rest, bool
 	  FEunexpected_keyword(Cnil);
 	if (narg == 2) {
 		k = base[0];
-		if (!keywordp(k))
+		if (type_of(k)!=t_symbol)
 		  FEunexpected_keyword(k);
 		if (k == sKallow_other_keys && ! allow_other_keys_found) {
 		  allow_other_keys_found=1;
@@ -777,7 +803,7 @@ parse_key(object *base, bool rest, bool
 	va_end(ap);
 	for (v = base;  v < vs_top;  v += 2) {
 		k = v[0];
-		if (!keywordp(k)) {
+		if (type_of(k)!=t_symbol) {
 			error_flag = NOT_KEYWORD;
 			other_key = k;
 			continue;
@@ -827,16 +853,19 @@ check_other_key(object l, int n, ...)
 	object k;
 	int i;
 	bool allow_other_keys = FALSE;
+	int allow_other_keys_found=0;
 
 	for (;  !endp(l);  l = l->c.c_cdr->c.c_cdr) {
 		k = l->c.c_car;
-		if (!keywordp(k))
+		if (type_of(k)!=t_symbol)
 		  FEunexpected_keyword(k);
 		if (endp(l->c.c_cdr))
 		  /* FIXME better message */
 		  FEunexpected_keyword(Cnil);
-		if (k == sKallow_other_keys && l->c.c_cdr->c.c_car != Cnil) {
-			allow_other_keys = TRUE;
+		if (k == sKallow_other_keys && !allow_other_keys_found) {
+		  allow_other_keys_found=1;
+		  if (l->c.c_cdr->c.c_car != Cnil)
+		    allow_other_keys = TRUE;
 		} else {
 		  char buf [100];
 		  bzero(buf,n);
@@ -1110,7 +1139,7 @@ gcl_init_bind(void)
 	make_cons(make_ordinary("&BODY"), Cnil)))))))));
 
 	make_constant("LAMBDA-PARAMETERS-LIMIT",
-		      make_fixnum(64));
+		      make_fixnum(MAX_ARGS+1));
 
 
 
--- gcl-2.6.12.orig/o/error.c
+++ gcl-2.6.12/o/error.c
@@ -490,49 +490,78 @@ vfun_wrong_number_of_args(object x)
 
 
 void
-check_arg_range(int n, int m)
-{  
-  object x,x1;
+check_arg_range(int n, int m) {
 
-  x=make_fixnum(n);
-  x1=make_fixnum(VFUN_NARGS);
   if (VFUN_NARGS < n)
-    Icall_error_handler(
-			sKtoo_few_arguments,
-			 make_simple_string("Needed at least ~D args, but received ~d"),
-			 2,x,x1);
-   else if (VFUN_NARGS > m)
-          Icall_error_handler(
-			 sKtoo_many_arguments,
-			 make_simple_string("Needed no more than ~D args, but received ~d"),
-			 2,x,x1);
- }
+    FEtoo_few_arguments(0,VFUN_NARGS);
+  if (VFUN_NARGS > m)
+    FEtoo_many_arguments(0,VFUN_NARGS);
+
+}
 			 
      
 DEF_ORDINARY("TERMINAL-INTERRUPT",sSterminal_interrupt,SI,"");
-DEF_ORDINARY("WRONG-TYPE-ARGUMENT",sKwrong_type_argument,KEYWORD,"");
-DEF_ORDINARY("TOO-FEW-ARGUMENTS",sKtoo_few_arguments,KEYWORD,"");
-DEF_ORDINARY("TOO-MANY-ARGUMENTS",sKtoo_many_arguments,KEYWORD,"");
-DEF_ORDINARY("UNEXPECTED-KEYWORD",sKunexpected_keyword,KEYWORD,"");
-DEF_ORDINARY("INVALID-FORM",sKinvalid_form,KEYWORD,"");
-DEF_ORDINARY("UNBOUND-VARIABLE",sKunbound_variable,KEYWORD,"");
-DEF_ORDINARY("INVALID-VARIABLE",sKinvalid_variable,KEYWORD,"");
-DEF_ORDINARY("UNDEFINED-FUNCTION",sKundefined_function,KEYWORD,"");
-DEF_ORDINARY("INVALID-FUNCTION",sKinvalid_function,KEYWORD,"");
-DEF_ORDINARY("PACKAGE-ERROR",sKpackage_error,KEYWORD,"");
-DEF_ORDINARY("DATUM",sKdatum,KEYWORD,"");
-DEF_ORDINARY("EXPECTED-TYPE",sKexpected_type,KEYWORD,"");
-DEF_ORDINARY("PACKAGE",sKpackage,KEYWORD,"");
-DEF_ORDINARY("FORMAT-CONTROL",sKformat_control,KEYWORD,"");
-DEF_ORDINARY("FORMAT-ARGUMENTS",sKformat_arguments,KEYWORD,"");
 DEF_ORDINARY("CATCH",sKcatch,KEYWORD,"");
 DEF_ORDINARY("PROTECT",sKprotect,KEYWORD,"");
 DEF_ORDINARY("CATCHALL",sKcatchall,KEYWORD,"");
 
 
+DEF_ORDINARY("CONDITION",sLcondition,LISP,"");
+DEF_ORDINARY("SERIOUS-CONDITION",sLserious_condition,LISP,"");
+DEF_ORDINARY("SIMPLE-CONDITION",sLsimple_condition,LISP,"");
+
+DEF_ORDINARY("ERROR",sLerror,LISP,"");
+DEF_ORDINARY("SIMPLE-ERROR",sLsimple_error,LISP,"");
+DEF_ORDINARY("FORMAT-CONTROL",sKformat_control,KEYWORD,"");
+DEF_ORDINARY("FORMAT-ARGUMENTS",sKformat_arguments,KEYWORD,"");
+
+DEF_ORDINARY("TYPE-ERROR",sLtype_error,LISP,"");
+DEF_ORDINARY("DATUM",sKdatum,KEYWORD,"");
+DEF_ORDINARY("EXPECTED-TYPE",sKexpected_type,KEYWORD,"");
+DEF_ORDINARY("SIMPLE-TYPE-ERROR",sLsimple_type_error,LISP,"");
+
+DEF_ORDINARY("PROGRAM-ERROR",sLprogram_error,LISP,"");
+DEF_ORDINARY("CONTROL-ERROR",sLcontrol_error,LISP,"");
+DEF_ORDINARY("PACKAGE-ERROR",sLpackage_error,LISP,"");
+DEF_ORDINARY("PACKAGE",sKpackage,KEYWORD,"");
+
+DEF_ORDINARY("STREAM-ERROR",sLstream_error,LISP,"");
+DEF_ORDINARY("STREAM",sKstream,KEYWORD,"");
+DEF_ORDINARY("END-OF-FILE",sLend_of_file,LISP,"");
+
+DEF_ORDINARY("FILE-ERROR",sLfile_error,LISP,"");
+DEF_ORDINARY("PATHNAME",sKpathname,KEYWORD,"");
+
+DEF_ORDINARY("CELL-ERROR",sLcell_error,LISP,"");
+DEF_ORDINARY("NAME",sKname,KEYWORD,"");
+DEF_ORDINARY("UNBOUND-SLOT",sLunbound_slot,LISP,"");
+DEF_ORDINARY("UNBOUND-VARIABLE",sLunbound_variable,LISP,"");
+DEF_ORDINARY("UNDEFINED-FUNCTION",sLundefined_function,LISP,"");
+
+DEF_ORDINARY("ARITHMETIC-ERROR",sLarithmetic_error,LISP,"");
+DEF_ORDINARY("OPERATION",sKoperation,KEYWORD,"");
+DEF_ORDINARY("OPERANDS",sKoperands,KEYWORD,"");
+DEF_ORDINARY("DIVISION-BY-ZERO",sLdivision_by_zero,LISP,"");
+DEF_ORDINARY("FLOATING-POINT-OVERFLOW",sLfloating_point_overflow,LISP,"");
+DEF_ORDINARY("FLOATING-POINT-UNDERFLOW",sLfloating_point_underflow,LISP,"");
+DEF_ORDINARY("FLOATING-POINT-INEXACT",sLfloating_point_inexact,LISP,"");
+DEF_ORDINARY("FLOATING-POINT-INVALID-OPERATION",sLfloating_point_invalid_operation,LISP,"");
+
+DEF_ORDINARY("PARSE-ERROR",sLparse_error,LISP,"");
+
+DEF_ORDINARY("PRINT-NOT-READABLE",sLprint_not_readable,LISP,"");
+
+DEF_ORDINARY("READER-ERROR",sLreader_error,LISP,"");
+DEF_ORDINARY("PATHNAME-ERROR",sLpathname_error,SI,"");
+
+DEF_ORDINARY("STORAGE-CONDITION",sLstorage_condition,LISP,"");
+
+DEF_ORDINARY("WARNING",sLwarning,LISP,"");
+DEF_ORDINARY("SIMPLE-WARNING",sLsimple_warning,LISP,"");
+DEF_ORDINARY("STYLE-WARNING",sLstyle_warning,LISP,"");
+
 void
-gcl_init_error(void)
-{
-	null_string = make_simple_string("");
-	enter_mark_origin(&null_string);
+gcl_init_error(void) {
+  null_string = make_simple_string("");
+  enter_mark_origin(&null_string);
 }
--- gcl-2.6.12.orig/o/fasdump.c
+++ gcl-2.6.12/o/fasdump.c
@@ -1501,14 +1501,12 @@ read_fasl_vector(object in)
  object d;
  int tem;
  if (((tem=getc(((FILE *)in->sm.sm_fp))) == EOF) && feof(((FILE *)in->sm.sm_fp)))
-   { d = coerce_to_pathname(in);
-     d = make_pathname(d->pn.pn_host,
-		       d->pn.pn_device,
-		       d->pn.pn_directory,
-		       d->pn.pn_name,
-		       make_simple_string("data"),
-		       d->pn.pn_version);
-     d = coerce_to_namestring(d);
+   { char *pf;
+     coerce_to_filename(in,FN1);
+     for (pf=FN1+strlen(FN1);pf>FN1 && pf[-1]!='.';pf--);
+     if (pf==FN1) {pf=FN1+strlen(FN1);*pf++='.';}
+     snprintf(pf,sizeof(FN1)-(pf-FN1),"data");
+     d=make_simple_string(FN1);
      in = open_stream(d,smm_input,Cnil,Cnil);
      if (in == Cnil) 
        FEerror("Can't open file ~s",1,d);
--- gcl-2.6.12.orig/o/file.d
+++ gcl-2.6.12/o/file.d
@@ -138,7 +138,7 @@ void
 end_of_stream(strm)
 object strm;
 {
-	FEerror("Unexpected end of ~S.", 1, strm);
+  END_OF_FILE(strm);
 }
 
 /*
@@ -167,6 +167,7 @@ BEGIN:
 	case smm_probe:
 		return(FALSE);
 
+	case smm_file_synonym:
 	case smm_synonym:
 		strm = symbol_value(strm->sm.sm_object0);
 		if (type_of(strm) != t_stream)
@@ -223,6 +224,7 @@ BEGIN:
 	case smm_probe:
 		return(FALSE);
 
+	case smm_file_synonym:
 	case smm_synonym:
 		strm = symbol_value(strm->sm.sm_object0);
 		if (type_of(strm) != t_stream)
@@ -270,6 +272,7 @@ BEGIN:
 	case smm_socket:
 	    return (sLcharacter);
 	    
+	case smm_file_synonym:
 	case smm_synonym:
 		strm = symbol_value(strm->sm.sm_object0);
 		if (type_of(strm) != t_stream)
@@ -341,220 +344,208 @@ cannot_create(object);
 	Fn is a namestring.
 */
 object
-open_stream(fn, smm, if_exists, if_does_not_exist)
-object fn;
-enum smmode smm;
-object if_exists, if_does_not_exist;
-{
-	object x;
-	FILE *fp=NULL;
-	char fname[PATH_MAX];
-	object unzipped = 0;
-	vs_mark;
+open_stream(object fn,enum smmode smm, object if_exists, object if_does_not_exist) {
 
-/*
-	if (type_of(fn) != t_string)
-		FEwrong_type_argument(sLstring, fn);
-*/
-	/* if (fn->st.st_fillp > BUFSIZ - 1) */
-	/* 	too_long_file_name(fn); */
-	/* for (i = 0;  i < fn->st.st_fillp;  i++) */
-	/* 	fname[i] = fn->st.st_self[i]; */
-	
-	/* fname[i] = '\0'; */
-	coerce_to_filename(fn,fname);
-	if (smm == smm_input || smm == smm_probe) {
-                if(fname[0]=='|')
-		  fp = popen(fname+1,"r");
-		else 
-		  fp = fopen_not_dir(fname, "r");
-		
-	      AGAIN:
-		if (fp == NULL) {
-		        if (sSAallow_gzipped_fileA->s.s_dbind != sLnil)
-			  { 
-			    static struct string st;
-			    char buf[256];
-			    if (snprintf(buf,sizeof(buf),"%s.gz",fname)<=0)
-			      FEerror("Cannot write .gz filename",0);
-			    st.st_self=buf;
-			    st.st_dim=st.st_fillp=strlen(buf);
-			    set_type_of(&st,t_string);
-			    if (file_exists((object)&st)) {
-			      FILE *pp;
-			      int n;
-			      if (!(fp=tmpfile()))
-				FEerror("Cannot create temporary file",0);
-			      if (snprintf(buf,sizeof(buf),"zcat %s.gz",fname)<=0)
-				FEerror("Cannot write zcat pipe name",0);
-			      if (!(pp=popen(buf,"r")))
-				FEerror("Cannot open zcat pipe",0);
-			      while((n=fread(buf,1,sizeof(buf),pp)))
-				if (!fwrite(buf,1,n,fp))
-				  FEerror("Cannot write pipe output to temporary file",0);
-			      if (pclose(pp)<0)
-				FEerror("Cannot close zcat pipe",0);
-			      if (fseek(fp,0,SEEK_SET))
-				FEerror("Cannot rewind temporary file\n",0); 
-			      goto AGAIN;
-			    }
-			  }
-			      
-/* 			    fp = fopen_not_dir(buf,"r"); */
-/* 			    if (fp) */
-/* 			      {  */
-/* #ifdef NO_MKSTEMP */
-/* 	                        char *tmp; */
-/* #else */
-/* 	                        char tmp[200]; */
-/* #endif */
-/* 				char command [500]; */
-/* 				fclose(fp); */
-/* #ifdef NO_MKSTEMP */
-/* 				tmp = tmpnam(0); */
-/* #else */
-/* 				snprintf(tmp,sizeof(tmp),"uzipXXXXXX"); */
-				/* mkstemp(tmp); */ /* fixme: catch errors */
-/* #endif */
-/* 				unzipped = make_simple_string(tmp); */
-/* 				sprintf(command,"gzip -dc %s > %s",buf,tmp); */
-/* 				fp = 0; */
-/* 				if (0 == system(command)) */
-/* 				  { */
-/* 				    fp = fopen_not_dir(tmp,"r"); */
-/* 				    if (fp)  */
-/* 				      goto AGAIN; */
-/* 				    /\* should not get here *\/ */
-/* 				    else { unlink(tmp);}} */
-/* 			      }} */
-			if (if_does_not_exist == sKerror)
-				cannot_open(fn);
-			else if (if_does_not_exist == sKcreate) {
-				fp = fopen_not_dir(fname, "w");
-				if (fp == NULL)
-					cannot_create(fn);
-				fclose(fp);
-				fp = fopen_not_dir(fname, "r");
-				if (fp == NULL)
-					cannot_open(fn);
-			} else if (if_does_not_exist == Cnil)
-				return(Cnil);
-			else
-			 FEerror("~S is an illegal IF-DOES-NOT-EXIST option.",
-				 1, if_does_not_exist);
-		}
-	} else if (smm == smm_output || smm == smm_io) {
-		if (if_exists == sKnew_version && if_does_not_exist == sKcreate)
-			goto CREATE;
-		fp = fopen_not_dir(fname, "r");
-		if (fp != NULL) {
-			fclose(fp);
-			if (if_exists == sKerror)
-				FEerror("The file ~A already exists.", 1, fn);
-			else if (if_exists == sKrename) {
-				if (smm == smm_output)
-					fp = backup_fopen(fname, "w");
-				else
-					fp = backup_fopen(fname, "w+");
-				if (fp == NULL)
-					cannot_create(fn);
-			} else if (if_exists == sKrename_and_delete ||
-				   if_exists == sKnew_version ||
-				   if_exists == sKsupersede) {
-				if (smm == smm_output)
-					fp = fopen_not_dir(fname, "w");
-				else
-					fp = fopen_not_dir(fname, "w+");
-				if (fp == NULL)
-					cannot_create(fn);
-			} else if (if_exists == sKoverwrite) {
-				fp = fopen_not_dir(fname, "r+");
-				if (fp == NULL)
-					cannot_open(fn);
-			} else if (if_exists == sKappend) {
-				if (smm == smm_output)
-					fp = fopen_not_dir(fname, "a");
-				else
-					fp = fopen_not_dir(fname, "a+");
-				if (fp == NULL)
-				FEerror("Cannot append to the file ~A.",1,fn);
-			} else if (if_exists == Cnil)
-				return(Cnil);
-			else
-				FEerror("~S is an illegal IF-EXISTS option.",
-					1, if_exists);
-		} else {
-			if (if_does_not_exist == sKerror)
-				FEerror("The file ~A does not exist.", 1, fn);
-			else if (if_does_not_exist == sKcreate) {
-			CREATE:
-				if (smm == smm_output)
-				  {
-				    if(fname[0]=='|')
-				      fp = popen(fname+1,"w");
-				    else 
-		                       fp = fopen_not_dir(fname, "w");
-				  }
-				else
-					fp = fopen_not_dir(fname, "w+");
-				if (fp == NULL)
-					cannot_create(fn);
-			} else if (if_does_not_exist == Cnil)
-				return(Cnil);
-			else
-			 FEerror("~S is an illegal IF-DOES-NOT-EXIST option.",
-				 1, if_does_not_exist);
-		}
+  object x;
+  FILE *fp=NULL;
+  vs_mark;
+
+  coerce_to_filename(fn,FN1);
+  if (smm == smm_input || smm == smm_probe) {
+    if(FN1[0]=='|')
+      fp = popen(FN1+1,"r");
+    else
+      fp = fopen_not_dir(FN1, "r");
+
+    if ((fp == NULL) &&
+	(sSAallow_gzipped_fileA->s.s_dbind != sLnil)) {
+      union lispunion st;
+      char buf[256];
+      if (snprintf(buf,sizeof(buf),"%s.gz",FN1)<=0)
+	FEerror("Cannot write .gz filename",0);
+      st.st.st_self=buf;
+      st.st.st_dim=st.st.st_fillp=strlen(buf);
+      set_type_of(&st,t_string);
+      if (fSstat((object)&st)!=Cnil) {
+	FILE *pp;
+	int n;
+	if (!(fp=tmpfile()))
+	  FEerror("Cannot create temporary file",0);
+	if (snprintf(buf,sizeof(buf),"zcat %s.gz",FN1)<=0)
+	  FEerror("Cannot write zcat pipe name",0);
+	if (!(pp=popen(buf,"r")))
+	  FEerror("Cannot open zcat pipe",0);
+	while((n=fread(buf,1,sizeof(buf),pp)))
+	  if (!fwrite(buf,1,n,fp))
+	    FEerror("Cannot write pipe output to temporary file",0);
+	if (pclose(pp)<0)
+	  FEerror("Cannot close zcat pipe",0);
+	if (fseek(fp,0,SEEK_SET))
+	  FEerror("Cannot rewind temporary file\n",0);
+      }
+    }
+    if (fp == NULL) {
+      if (if_does_not_exist == sKerror)
+	cannot_open(fn);
+      else if (if_does_not_exist == sKcreate) {
+	fp = fopen_not_dir(FN1, "w");
+	if (fp == NULL)
+	  cannot_create(fn);
+	fclose(fp);
+	fp = fopen_not_dir(FN1, "r");
+	if (fp == NULL)
+	  cannot_open(fn);
+      } else if (if_does_not_exist == Cnil)
+	return(Cnil);
+      else
+	FEerror("~S is an illegal IF-DOES-NOT-EXIST option.",
+		1, if_does_not_exist);
+    }
+  } else if (smm == smm_output || smm == smm_io) {
+    if (FN1[0] == '|')
+      fp = NULL;
+    else
+      fp = fopen_not_dir(FN1, "r");
+    if (fp != NULL) {
+      fclose(fp);
+      if (if_exists == sKerror)
+	FILE_ERROR(fn,"File exists");
+      else if (if_exists == sKrename) {
+	massert(snprintf(FN2,sizeof(FN2),"%s.BAK",FN1)>=0);
+	massert(!rename(FN1,FN2));
+	if (smm == smm_output)
+	  fp = fopen(FN1, "w");
+	else
+	  fp = fopen(FN1, "w+");
+	if (fp == NULL)
+	  cannot_create(fn);
+      } else if (if_exists == sKrename_and_delete ||
+		 if_exists == sKnew_version ||
+		 if_exists == sKsupersede) {
+	if (smm == smm_output)
+	  fp = fopen_not_dir(FN1, "w");
+	else
+	  fp = fopen_not_dir(FN1, "w+");
+	if (fp == NULL)
+	  cannot_create(fn);
+      } else if (if_exists == sKoverwrite) {
+	fp = fopen_not_dir(FN1, "r+");
+	if (fp == NULL)
+	  cannot_open(fn);
+      } else if (if_exists == sKappend) {
+	if (smm == smm_output)
+	  fp = fopen_not_dir(FN1, "a");
+	else
+	  fp = fopen_not_dir(FN1, "a+");
+	if (fp == NULL)
+	  FEerror("Cannot append to the file ~A.",1,fn);
+      } else if (if_exists == Cnil)
+	return(Cnil);
+      else
+	FEerror("~S is an illegal IF-EXISTS option.",
+		1, if_exists);
+    } else {
+      if (if_does_not_exist == sKerror)
+	FILE_ERROR(fn,"The file does not exist");
+      else if (if_does_not_exist == sKcreate) {
+	if (smm == smm_output) {
+	  if(FN1[0]=='|')
+	    fp = popen(FN1+1,"w");
+	  else
+	    fp = fopen_not_dir(FN1, "w");
 	} else
-		error("illegal stream mode");
-	x = alloc_object(t_stream);
-	x->sm.sm_mode = (short)smm;
-	x->sm.sm_fp = fp;
+	  fp = fopen_not_dir(FN1, "w+");
+	if (fp == NULL)
+	  cannot_create(fn);
+      } else if (if_does_not_exist == Cnil)
+	return(Cnil);
+      else
+	FEerror("~S is an illegal IF-DOES-NOT-EXIST option.",
+		1, if_does_not_exist);
+    }
+  } else
+    FEerror("Illegal open mode for ~S.",1,fn);
+
+  vs_push(make_simple_string(FN1));
+  x = alloc_object(t_stream);
+  x->sm.sm_mode = (short)smm;
+  x->sm.sm_fp = fp;
+  x->sm.sm_buffer = 0;
+  x->sm.sm_object0 = sLcharacter;
+  x->sm.sm_object1 = vs_head;
+  x->sm.sm_int0 = x->sm.sm_int1 = 0;
+  x->sm.sm_flags=0;
+  vs_push(x);
+
+  setup_stream_buffer(x);
+  vs_reset;
+
+  if (smm==smm_probe)
+    close_stream(x);
+
+  return(x);
 
-	x->sm.sm_buffer = 0;
-	x->sm.sm_object0 = (unzipped ? make_cons(sSAallow_gzipped_fileA,unzipped) : sLcharacter);
-	x->sm.sm_object1 = fn;
-	x->sm.sm_int0 = x->sm.sm_int1 = 0;
-	vs_push(x);
-	setup_stream_buffer(x);
-	vs_reset;
-	return(x);
 }
 
 static void
 gclFlushSocket(object);
 
+DEFUN_NEW("OPEN-INT",object,fSopen_int,SI,8,8,NONE,OO,OO,OO,OO,
+	  (object fn,object direction,object element_type,object if_exists,
+	   object iesp,object if_does_not_exist,object idnesp,
+	   object external_format),"") {
+
+  enum smmode smm=0;
+  vs_mark;
+  object strm,filename;
+
+  filename=fn;
+  if (direction == sKinput) {
+    smm = smm_input;
+    if (idnesp==Cnil)
+      if_does_not_exist = sKerror;
+  } else if (direction == sKoutput) {
+    smm = smm_output;
+    if (iesp==Cnil)
+      if_exists = sKnew_version;
+    if (idnesp==Cnil) {
+      if (if_exists == sKoverwrite ||
+	  if_exists == sKappend)
+	if_does_not_exist = sKerror;
+      else
+	if_does_not_exist = sKcreate;
+    }
+  } else if (direction == sKio) {
+    smm = smm_io;
+    if (iesp==Cnil)
+      if_exists = sKnew_version;
+    if (idnesp==Cnil) {
+      if (if_exists == sKoverwrite ||
+	  if_exists == sKappend)
+	if_does_not_exist = sKerror;
+      else
+	if_does_not_exist = sKcreate;
+    }
+  } else if (direction == sKprobe) {
+    smm = smm_probe;
+    if (idnesp==Cnil)
+      if_does_not_exist = Cnil;
+  } else
+    FEerror("~S is an illegal DIRECTION for OPEN.", 1, direction);
+  strm = open_stream(filename, smm, if_exists, if_does_not_exist);
+  if (type_of(strm) == t_stream) {
+    strm->sm.sm_object0 = element_type;
+    strm->sm.sm_object1 = fn;
+  }
+  vs_reset;
+  RETURN1(strm);
+}
 
 DEFUN_NEW("OPEN-STREAM-P",object,fLopen_stream_p,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") {
 
   check_type_stream(&x);
 
-  switch(x->sm.sm_mode) {
-  case smm_output:
-  case smm_input:
-  case smm_io:
-  case smm_probe:
-  case smm_socket:
-  case smm_string_input:
-  case smm_string_output:
-    return x->d.tt==1 ? Cnil : Ct;
-  case smm_synonym:
-    return FFN(fLopen_stream_p)(symbol_value(x->sm.sm_object0));
-  case smm_broadcast:
-  case smm_concatenated:
-    for (x=x->sm.sm_object0;!endp(x);x=x->c.c_cdr)
-      if (!FFN(fLopen_stream_p)(x))
-	return Cnil;
-    return Ct;
-  case smm_two_way:
-  case smm_echo:
-    if (FFN(fLopen_stream_p)(STREAM_INPUT_STREAM(x))==Cnil)
-      return Cnil;
-    return FFN(fLopen_stream_p)(STREAM_OUTPUT_STREAM(x));
-  default:
-    error("illegal stream mode");
-    return Cnil;
-  }
+  return GET_STREAM_FLAG(x,gcl_sm_closed) ? Cnil : Ct;
 
 }
     /*
@@ -562,94 +553,132 @@ DEFUN_NEW("OPEN-STREAM-P",object,fLopen_
 	The abort_flag is not used now.
 */
 void
-close_stream(strm)
-object strm;
-/*bool abort_flag; */	/*  Not used now!  */
-{
-	object x;
+close_stream(object strm)  {
 
-BEGIN:
-	strm->d.tt=1;
+  object x;
 
-	switch (strm->sm.sm_mode) {
-	case smm_output:
-		if (strm->sm.sm_fp == stdout)
-			FEerror("Cannot close the standard output.", 0);
-		if (strm->sm.sm_fp == NULL) break;
-		fflush(strm->sm.sm_fp);
-		deallocate_stream_buffer(strm);
-		fclose(strm->sm.sm_fp);
-		strm->sm.sm_fp = NULL;
-		break;
+  if (FFN(fLopen_stream_p)(strm)==Cnil)
+    return;
 
+  switch (strm->sm.sm_mode) {
+  case smm_output:
+    if (strm->sm.sm_fp == stdout)
+      FEerror("Cannot close the standard output.", 0);
+    fflush(strm->sm.sm_fp);
+    deallocate_stream_buffer(strm);
+    fclose(strm->sm.sm_fp);
+    strm->sm.sm_fp = NULL;
+    strm->sm.sm_fd = -1;
+    break;
 
-	case smm_socket:
-	  if (SOCKET_STREAM_FD(strm) < 2)
-	    emsg("tried Closing %d ! as socket \n",SOCKET_STREAM_FD(strm));
-	  else {
+  case smm_socket:
+    if (SOCKET_STREAM_FD(strm) < 2)
+      emsg("tried Closing %d ! as socket \n",SOCKET_STREAM_FD(strm));
+    else {
 #ifdef HAVE_NSOCKET
-          if (GET_STREAM_FLAG(strm,gcl_sm_output))
-              {	 
-		gclFlushSocket(strm);
-                 /* there are two for one fd so close only one */
-            	  tcpCloseSocket(SOCKET_STREAM_FD(strm));
-               } 
+      if (GET_STREAM_FLAG(strm,gcl_sm_output)) {
+	gclFlushSocket(strm);
+	/* there are two for one fd so close only one */
+	tcpCloseSocket(SOCKET_STREAM_FD(strm));
+      }
 #endif
-	  SOCKET_STREAM_FD(strm)=-1;
-	  }
+      SOCKET_STREAM_FD(strm)=-1;
+    }
 
-	case smm_input:
-		if (strm->sm.sm_fp == stdin)
-			FEerror("Cannot close the standard input.", 0);
-	  
-	case smm_io:
-	case smm_probe:
-		if (strm->sm.sm_fp == NULL) break;
-		deallocate_stream_buffer(strm);
-		if (strm->sm.sm_object1 &&
-		    type_of(strm->sm.sm_object1)==t_string &&
-		    strm->sm.sm_object1->st.st_self[0] =='|')
-		  pclose(strm->sm.sm_fp);
-		else 
-		  fclose(strm->sm.sm_fp);
-		strm->sm.sm_fp = NULL;
-		if (strm->sm.sm_object0 &&
-		    type_of(strm->sm.sm_object0 ) == t_cons &&
-		    Mcar(strm->sm.sm_object0 ) == sSAallow_gzipped_fileA)
-		  fLdelete_file(Mcdr(strm->sm.sm_object0));
-		break;
+  case smm_input:
+    if (strm->sm.sm_fp == stdin)
+      FEerror("Cannot close the standard input.", 0);
 
-	case smm_synonym:
-		strm = symbol_value(strm->sm.sm_object0);
-		if (type_of(strm) != t_stream)
-			FEwrong_type_argument(sLstream, strm);
-		goto BEGIN;
+  case smm_io:
+  case smm_probe:
+    deallocate_stream_buffer(strm);
+    if (strm->sm.sm_object1 &&
+	type_of(strm->sm.sm_object1)==t_string &&
+	strm->sm.sm_object1->st.st_self[0] =='|')
+      pclose(strm->sm.sm_fp);
+    else
+      fclose(strm->sm.sm_fp);
+    strm->sm.sm_fp = NULL;
+    strm->sm.sm_fd = -1;
+    if (strm->sm.sm_object0 &&
+	type_of(strm->sm.sm_object0 )==t_cons &&
+	Mcar(strm->sm.sm_object0)==sSAallow_gzipped_fileA)
+      ifuncall1(sLdelete_file,Mcdr(strm->sm.sm_object0));
+    break;
 
-	case smm_broadcast:
-		for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
-			close_stream(x->c.c_car);
-		break;
+  case smm_file_synonym:
+  case smm_synonym:
+    strm = symbol_value(strm->sm.sm_object0);
+    if (type_of(strm) != t_stream)
+      TYPE_ERROR(strm,sLstream);
+    close_stream(strm);
+    break;
 
-	case smm_concatenated:
-		for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
-			close_stream(x->c.c_car);
-		break;
+  case smm_broadcast:
+  case smm_concatenated:
+    for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
+      close_stream(x->c.c_car);
+    break;
 
-	case smm_two_way:
-	case smm_echo:
-		close_stream(STREAM_INPUT_STREAM(strm));
-		close_stream(STREAM_OUTPUT_STREAM(strm));
-		break;
+  case smm_two_way:
+  case smm_echo:
+    close_stream(STREAM_INPUT_STREAM(strm));
+    close_stream(STREAM_OUTPUT_STREAM(strm));
+    break;
 
-	case smm_string_input:
-		break;		/*  There is nothing to do.  */
+  case smm_string_input:
+  case smm_string_output:
+    break;
 
-	case smm_string_output:
-		break;		/*  There is nothing to do.  */
+  default:
+    error("Illegal stream mode");
+  }
+
+  SET_STREAM_FLAG(strm,gcl_sm_closed,1);
+
+}
+
+DEFUN_NEW("INTERACTIVE-STREAM-P",object,fLinteractive_stream_p,LISP,1,1,NONE,OO,OO,OO,OO,(object strm),"") {
+
+  check_type_stream(&strm);
+
+  switch (strm->sm.sm_mode) {
+  case smm_output:
+  case smm_input:
+  case smm_io:
+  case smm_probe:
+    if ((strm->sm.sm_fp == stdin) ||
+	(strm->sm.sm_fp == stdout) ||
+	(strm->sm.sm_fp == stderr))
+      return Ct;
+    return Cnil;
+    break;
+  case smm_file_synonym:
+  case smm_synonym:
+    strm = symbol_value(strm->sm.sm_object0);
+    if (type_of(strm) != t_stream)
+      FEwrong_type_argument(sLstream, strm);
+    break;
+
+  case smm_broadcast:
+  case smm_concatenated:
+    if (( consp(strm->sm.sm_object0) ) &&
+	( type_of(strm->sm.sm_object0->c.c_car) == t_stream ))
+      strm=strm->sm.sm_object0->c.c_car;
+    else
+      return Cnil;
+    break;
+
+  case smm_two_way:
+  case smm_echo:
+    strm=STREAM_INPUT_STREAM(strm);
+    break;
+  default:
+    return Cnil;
+  }
+
+  return Cnil;
 
-	default:
-		error("illegal stream mode");
-	}
 }
 
 object
@@ -665,6 +694,7 @@ object istrm, ostrm;
 	STREAM_INPUT_STREAM(strm) = istrm;
 	STREAM_OUTPUT_STREAM(strm) = ostrm;
 	strm->sm.sm_int0 = strm->sm.sm_int1 = 0;
+	strm->sm.sm_flags=0;
 	return(strm);
 }
 
@@ -694,6 +724,7 @@ int istart, iend;
 	strm->sm.sm_object1 = OBJNULL;
 	STRING_INPUT_STREAM_NEXT(strm)= istart;
 	STRING_INPUT_STREAM_END(strm)= iend;
+	strm->sm.sm_flags=0;
 	return(strm);
 }
 
@@ -729,6 +760,7 @@ int line_length;
 	STRING_STREAM_STRING(strm) = strng;
 	strm->sm.sm_object1 = OBJNULL;
 	strm->sm.sm_int0 = STREAM_FILE_COLUMN(strm) = 0;
+	strm->sm.sm_flags=0;
 	vs_reset;
 	return(strm);
 }
@@ -782,6 +814,7 @@ BEGIN:
 		/* strm->sm.sm_int0++; */
 		return(c==EOF ? c : (c&0377));
 
+	case smm_file_synonym:
 	case smm_synonym:
 		strm = symbol_value(strm->sm.sm_object0);
 		if (type_of(strm) != t_stream)
@@ -884,6 +917,7 @@ BEGIN:
 		/* --strm->sm.sm_int0; */  /* use ftell now for position */
 		break;
 
+	case smm_file_synonym:
 	case smm_synonym:
 		strm = symbol_value(strm->sm.sm_object0);
 		if (type_of(strm) != t_stream)
@@ -985,6 +1019,7 @@ BEGIN:
 
 		break;
 
+	case smm_file_synonym:
 	case smm_synonym:
 		strm = symbol_value(strm->sm.sm_object0);
 		if (type_of(strm) != t_stream)
@@ -1095,6 +1130,7 @@ BEGIN:
 #endif
 		  closed_stream(strm);
 		break;
+	case smm_file_synonym:
 	case smm_synonym:
 		strm = symbol_value(strm->sm.sm_object0);
 		if (type_of(strm) != t_stream)
@@ -1183,6 +1219,7 @@ BEGIN:
 	case smm_probe:
 		return(FALSE);
 
+	case smm_file_synonym:
 	case smm_synonym:
 		strm = symbol_value(strm->sm.sm_object0);
 		check_stream(strm);
@@ -1308,6 +1345,7 @@ BEGIN:
 #endif
 		return TRUE;
 
+	case smm_file_synonym:
 	case smm_synonym:
 		strm = symbol_value(strm->sm.sm_object0);
 		if (type_of(strm) != t_stream)
@@ -1363,6 +1401,7 @@ BEGIN:
 	case smm_string_output:
 		return(STRING_STREAM_STRING(strm)->st.st_fillp);
 
+	case smm_file_synonym:
 	case smm_synonym:
 		strm = symbol_value(strm->sm.sm_object0);
 		if (type_of(strm) != t_stream)
@@ -1412,6 +1451,7 @@ BEGIN:
 		}
 		return(0);
 
+	case smm_file_synonym:
 	case smm_synonym:
 		strm = symbol_value(strm->sm.sm_object0);
 		if (type_of(strm) != t_stream)
@@ -1448,6 +1488,7 @@ BEGIN:
 		
 
 	  
+	case smm_file_synonym:
 	case smm_synonym:
 		strm = symbol_value(strm->sm.sm_object0);
 		if (type_of(strm) != t_stream)
@@ -1487,6 +1528,7 @@ BEGIN:
 	case smm_two_way:
            strm=STREAM_OUTPUT_STREAM(strm);
            goto BEGIN;
+	case smm_file_synonym:
 	case smm_synonym:
 		strm = symbol_value(strm->sm.sm_object0);
 		if (type_of(strm) != t_stream)
@@ -1553,6 +1595,22 @@ load(const char *s) {
 
 
 
+static int
+file_synonym_stream_p(object x) {
+  switch(x->sm.sm_mode) {
+  case smm_input:
+  case smm_output:
+  case smm_io:
+  case smm_probe:
+  case smm_file_synonym:
+    return 1;
+  case smm_synonym:
+    return file_synonym_stream_p(x->sm.sm_object0->s.s_dbind);
+  default:
+    return 0;
+  }
+}
+
 LFD(Lmake_synonym_stream)()
 {
 	object x;
@@ -1560,12 +1618,13 @@ LFD(Lmake_synonym_stream)()
 	check_arg(1);
 	check_type_sym(&vs_base[0]);
 	x = alloc_object(t_stream);
-	x->sm.sm_mode = (short)smm_synonym;
+	x->sm.sm_mode = file_synonym_stream_p(vs_base[0]) ? (short)smm_file_synonym : (short)smm_synonym;
 	x->sm.sm_fp = NULL;
 	x->sm.sm_buffer = 0;
 	x->sm.sm_object0 = vs_base[0];
 	x->sm.sm_object1 = OBJNULL;
 	x->sm.sm_int0 = x->sm.sm_int1 = 0;
+	x->sm.sm_flags=0;
 	vs_base[0] = x;
 }
 
@@ -1589,6 +1648,7 @@ LFD(Lmake_broadcast_stream)()
 	x->sm.sm_object0 = vs_base[0];
 	x->sm.sm_object1 = OBJNULL;
 	x->sm.sm_int0 = x->sm.sm_int1 = 0;
+	x->sm.sm_flags=0;
 	vs_base[0] = x;
 }
 
@@ -1612,6 +1672,7 @@ LFD(Lmake_concatenated_stream)()
 	x->sm.sm_object0 = vs_base[0];
 	x->sm.sm_object1 = OBJNULL;
 	x->sm.sm_int0 = x->sm.sm_int1 = 0;
+	x->sm.sm_flags=0;
 	vs_base[0] = x;
 }
 
@@ -1700,6 +1761,38 @@ LFD(siLoutput_stream_string)()
 	vs_base[0] = vs_base[0]->sm.sm_object0;
 }
 
+DEFUN_NEW("FILE-STREAM-P",object,fSfile_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  RETURN1(type_of(x)==t_stream &&
+	  (x->sm.sm_mode==smm_input || x->sm.sm_mode==smm_output || x->sm.sm_mode==smm_io || x->sm.sm_mode==smm_probe)
+	  ? Ct : Cnil);
+}
+
+DEFUN_NEW("SYNONYM-STREAM-P",object,fSsynonym_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  RETURN1(type_of(x)==t_stream && (x->sm.sm_mode==smm_file_synonym || x->sm.sm_mode==smm_synonym) ? Ct : Cnil);
+}
+
+DEFUN_NEW("TERMINAL-INPUT-STREAM-P",object,fSterminal_input_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_input && x->sm.sm_fp && isatty(fileno((FILE *)x->sm.sm_fp)) ? Ct : Cnil);
+}
+
+DEFUN_NEW("BROADCAST-STREAM-P",object,fSbroadcast_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_broadcast ? Ct : Cnil);
+}
+
+DEFUN_NEW("ECHO-STREAM-P",object,fSecho_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_echo ? Ct : Cnil);
+}
+
+DEFUN_NEW("TWO-WAY-STREAM-P",object,fStwo_way_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_two_way ? Ct : Cnil);
+}
+
+DEFUN_NEW("CONCATENATED-STREAM-P",object,fSconcatenated_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_concatenated ? Ct : Cnil);
+}
+
+
+
 LFD(Lstreamp)()
 {
 	check_arg(1);
@@ -1747,54 +1840,6 @@ LFD(Lstream_element_type)()
 	@(return Ct)
 @)
 
-@(static defun open (filename
-	      &key (direction sKinput)
-		   (element_type sLcharacter)
-		   (if_exists Cnil iesp)
-		   (if_does_not_exist Cnil idnesp)
-	      &aux strm)
-	enum smmode smm=0;
-@
-	check_type_or_pathname_string_symbol_stream(&filename);
-	filename = coerce_to_namestring(filename);
-	if (direction == sKinput) {
-		smm = smm_input;
-		if (!idnesp)
-			if_does_not_exist = sKerror;
-	} else if (direction == sKoutput) {
-		smm = smm_output;
-		if (!iesp)
-			if_exists = sKnew_version;
-		if (!idnesp) {
-			if (if_exists == sKoverwrite ||
-			    if_exists == sKappend)
-				if_does_not_exist = sKerror;
-			else
-				if_does_not_exist = sKcreate;
-		}
-	} else if (direction == sKio) {
-		smm = smm_io;
-		if (!iesp)
-			if_exists = sKnew_version;
-		if (!idnesp) {
-			if (if_exists == sKoverwrite ||
-			    if_exists == sKappend)
-				if_does_not_exist = sKerror;
-			else
-				if_does_not_exist = sKcreate;
-		}
-	} else if (direction == sKprobe) {
-		smm = smm_probe;
-		if (!idnesp)
-			if_does_not_exist = Cnil;
-	} else
-		FEerror("~S is an illegal DIRECTION for OPEN.",
-			1, direction);
-	strm = open_stream(filename, smm, if_exists, if_does_not_exist);
-	if (type_of(strm) == t_stream)
-	    strm->sm.sm_object0 = element_type;
-	@(return strm)
-@)
 
 @(defun file_position (file_stream &o position)
 	int i=0;
@@ -1838,175 +1883,72 @@ object sLAload_pathnameA;
 DEFVAR("*COLLECT-BINARY-MODULES*",sSAcollect_binary_modulesA,SI,sLnil,"");
 DEFVAR("*BINARY-MODULES*",sSAbinary_modulesA,SI,Cnil,"");
 
-@(static defun load (pathname
-	      &key (verbose `symbol_value(sLAload_verboseA)`)
-		    print
-		    (if_does_not_exist sKerror)
-	      &aux pntype fasl_filename lsp_filename filename
-		   defaults strm stdoutput x
-		   package)
-	bds_ptr old_bds_top;
-	int i;
-	object strm1;
-@
-	check_type_or_pathname_string_symbol_stream(&pathname);
-	pathname = coerce_to_pathname(pathname);
-	defaults = symbol_value(Vdefault_pathname_defaults);
-	defaults = coerce_to_pathname(defaults);
-	pathname = merge_pathnames(pathname, defaults, sKnewest);
-	pntype = pathname->pn.pn_type;
-	filename = coerce_to_namestring(pathname);
-	if (user_match(filename->st.st_self,filename->st.st_fillp))
-		@(return Cnil)
-        old_bds_top=bds_top;
-  	if (pntype == Cnil || pntype == sKwild ||
-	    (type_of(pntype) == t_string &&
-#ifdef UNIX
-	    string_eq(pntype, FASL_string))) {
-#endif
-#ifdef AOSVS
+DEFUN_NEW("LOAD-STREAM",object,fSload_stream,SI,2,2,NONE,OO,OO,OO,OO,(object strm,object print),"") {
 
-#endif
-		pathname->pn.pn_type = FASL_string;
-		fasl_filename = coerce_to_namestring(pathname);
-	}
-	if (pntype == Cnil || pntype == sKwild ||
-	    (type_of(pntype) == t_string &&
-#ifdef UNIX
-	    string_eq(pntype, LSP_string))) {
-#endif
-#ifdef AOSVS
+  object x;
 
-#endif
-		pathname->pn.pn_type = LSP_string;
-		lsp_filename = coerce_to_namestring(pathname);
-	}
-	if (fasl_filename != Cnil && file_exists(fasl_filename)) {
-		if (verbose != Cnil) {
-			SETUP_PRINT_DEFAULT(fasl_filename);
-			if (file_column(PRINTstream) != 0)
-				write_str("\n");
-			write_str("Loading ");
-			PRINTescape = FALSE;
-			write_object(fasl_filename, 0);
-			write_str("\n");
-			CLEANUP_PRINT_DEFAULT;
-			flush_stream(PRINTstream);
-		}
-		package = symbol_value(sLApackageA);
-		bds_bind(sLApackageA, package);
-		bds_bind(sLAload_pathnameA,fasl_filename);
-		if (sSAcollect_binary_modulesA->s.s_dbind==Ct) {
-		  object _x=sSAbinary_modulesA->s.s_dbind;
-		  object _y=Cnil;
-		  while (_x!=Cnil) {
-		    _y=_x;
-		    _x=_x->c.c_cdr;
-		  }
-		  if (_y==Cnil)
-		    sSAbinary_modulesA->s.s_dbind=make_cons(fasl_filename,Cnil);
-		  else 
-		    _y->c.c_cdr=make_cons(fasl_filename,Cnil);
-		}
-		i = fasload(fasl_filename);
-		if (print != Cnil) {
-			SETUP_PRINT_DEFAULT(Cnil);
-			vs_top = PRINTvs_top;
-			if (file_column(PRINTstream) != 0)
-				write_str("\n");
-			write_str("Fasload successfully ended.");
-			write_str("\n");
-			CLEANUP_PRINT_DEFAULT;
-			flush_stream(PRINTstream);
-		}
-		bds_unwind(old_bds_top);
-		if (verbose != Cnil) {
-			SETUP_PRINT_DEFAULT(fasl_filename);
-			if (file_column(PRINTstream) != 0)
-				write_str("\n");
-			write_str("Finished loading ");
-			PRINTescape = FALSE;
-			write_object(fasl_filename, 0);
-			write_str("\n");
-			CLEANUP_PRINT_DEFAULT;
-			flush_stream(PRINTstream);
-		}
-		@(return `make_fixnum(i)`)
-	}
-	if (lsp_filename != Cnil && file_exists(lsp_filename)) {
-		filename = lsp_filename;
-	}
-	if (if_does_not_exist != Cnil)
-		if_does_not_exist = sKerror;
-	strm1 = strm
-	= open_stream(filename, smm_input, Cnil, if_does_not_exist);
-	if (strm == Cnil)
-		@(return Cnil)
-	if (verbose != Cnil) {
-		SETUP_PRINT_DEFAULT(filename);
-		if (file_column(PRINTstream) != 0)
-			write_str("\n");
-		write_str("Loading ");
-		PRINTescape = FALSE;
-		write_object(filename, 0);
-		write_str("\n");
-		CLEANUP_PRINT_DEFAULT;
-		flush_stream(PRINTstream);
-	}
-	package = symbol_value(sLApackageA);
-	bds_bind(sLAload_pathnameA,pathname);
-	bds_bind(sLApackageA, package);
-	bds_bind(sLAstandard_inputA, strm);
-	frs_push(FRS_PROTECT, Cnil);
-	if (nlj_active) {
-		close_stream(strm1);
-		nlj_active = FALSE;
-		frs_pop();
-		bds_unwind(old_bds_top);
-		unwind(nlj_fr, nlj_tag);
-	}
-	for (;;) {
-		preserving_whitespace_flag = FALSE;
-		detect_eos_flag = TRUE;
-		x = read_object_non_recursive(strm);
-		if (x == OBJNULL)
-			break;
-		{
-			object *base = vs_base, *top = vs_top, *lex = lex_env;
-			object xx;
-
-			lex_new();
-			eval(x);
-			xx = vs_base[0];
-			lex_env = lex;
-			vs_top = top;
-			vs_base = base;
-			x = xx;
-		}
-		if (print != Cnil) {
-			SETUP_PRINT_DEFAULT(x);
-			write_object(x, 0);
-			write_str("\n");
-			CLEANUP_PRINT_DEFAULT;
-			flush_stream(PRINTstream);
-		}
-	}
-	close_stream(strm);
-	frs_pop();
-	bds_unwind(old_bds_top);
-	if (verbose != Cnil) {
-		SETUP_PRINT_DEFAULT(filename);
-		if (file_column(PRINTstream) != 0)
-			write_str("\n");
-		write_str("Finished loading ");
-		PRINTescape = FALSE;
-		write_object(filename, 0);
-		write_str("\n");
-		CLEANUP_PRINT_DEFAULT;
-		flush_stream(PRINTstream);
-	}
-	@(return Ct)
-@)
+  for (;;) {
+    preserving_whitespace_flag = FALSE;
+    detect_eos_flag = TRUE;
+    x = read_object_non_recursive(strm);
+    if (x == OBJNULL)
+      break;
+    {
+      object *base = vs_base, *top = vs_top, *lex = lex_env;
+      object xx;
+
+      lex_new();
+      eval(x);
+      xx = vs_base[0];
+      lex_env = lex;
+      vs_top = top;
+      vs_base = base;
+      x = xx;
+    }
+    if (print != Cnil) {
+      SETUP_PRINT_DEFAULT(x);
+      write_object(x, 0);
+      write_str("\n");
+      CLEANUP_PRINT_DEFAULT;
+      flush_stream(PRINTstream);
+    }
+  }
+
+  RETURN1(Ct);
+
+}
+
+DEFUN_NEW("LOAD-FASL",object,fSload_fasl,SI,2,2,NONE,OO,OO,OO,OO,(object fasl_filename,object print),"") {
+
+  int i;
+
+  if (sSAcollect_binary_modulesA->s.s_dbind==Ct) {
+    object _x=sSAbinary_modulesA->s.s_dbind;
+    object _y=Cnil;
+    while (_x!=Cnil) {
+      _y=_x;
+      _x=_x->c.c_cdr;
+    }
+    if (_y==Cnil)
+      sSAbinary_modulesA->s.s_dbind=make_cons(fasl_filename,Cnil);
+    else
+      _y->c.c_cdr=make_cons(fasl_filename,Cnil);
+  }
+  i = fasload(fasl_filename);
+  if (print != Cnil) {
+    SETUP_PRINT_DEFAULT(Cnil);
+    vs_top = PRINTvs_top;
+    if (file_column(PRINTstream) != 0)
+      write_str("\n");
+    write_str(";; Fasload successfully ended.");
+    write_str("\n");
+    CLEANUP_PRINT_DEFAULT;
+    flush_stream(PRINTstream);
+  }
+
+  RETURN1(make_fixnum(i));
+
+}
 
 static void
 FFN(siLget_string_input_stream_index)()
@@ -2018,9 +1960,6 @@ FFN(siLget_string_input_stream_index)()
 	vs_base[0] = make_fixnum(STRING_INPUT_STREAM_NEXT(vs_base[0]));
 }
 
-DEFUN_NEW("TERMINAL-INPUT-STREAM-P",object,fSterminal_input_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
-  RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_input && x->sm.sm_fp && isatty(fileno((FILE *)x->sm.sm_fp)) ? Ct : Cnil);
-}
 
 LFD(siLmake_string_output_stream_from_string)()
 {
@@ -2038,6 +1977,7 @@ LFD(siLmake_string_output_stream_from_st
 	strm->sm.sm_object1 = OBJNULL;
 	/* strm->sm.sm_int0 = strng->st.st_fillp; */
 	STREAM_FILE_COLUMN(strm) = 0;
+	strm->sm.sm_flags=0;
 	vs_base[0] = strm;
 }
 
@@ -2071,14 +2011,14 @@ static void
 cannot_open(fn)
 object fn;
 {
-	FEerror("Cannot open the file ~A.", 1, fn);
+	FILE_ERROR(fn,"Cannot open");
 }
 
 static void
 cannot_create(fn)
 object fn;
 {
-	FEerror("Cannot create the file ~A.", 1, fn);
+	FILE_ERROR(fn,"Cannot create");
 }
 
 static void
@@ -2141,6 +2081,7 @@ int out;
  if (type_of(strm) != t_stream)
    FEwrong_type_argument(sLstream, strm);
  switch (strm->sm.sm_mode){
+ case smm_file_synonym:
  case smm_synonym:
   strm = symbol_value(strm->sm.sm_object0);
   if (type_of(strm) != t_stream)
@@ -2566,6 +2507,7 @@ gcl_init_file(void)
 #endif
 	standard_input->sm.sm_int0 = 0; /* unused */
 	standard_input->sm.sm_int1 = 0; /* unused */
+	standard_input->sm.sm_flags=0;
 
 	standard_output = alloc_object(t_stream);
 	standard_output->sm.sm_mode = (short)smm_output;
@@ -2578,18 +2520,20 @@ gcl_init_file(void)
 #endif
 	standard_output->sm.sm_int0 = 0; /* unused */
 	STREAM_FILE_COLUMN(standard_output) = 0;
+	standard_output->sm.sm_flags=0;
 
 	terminal_io = standard
 	= make_two_way_stream(standard_input, standard_output);
 	enter_mark_origin(&terminal_io);
 
 	x = alloc_object(t_stream);
-	x->sm.sm_mode = (short)smm_synonym;
+	x->sm.sm_mode = (short)smm_file_synonym;
 	x->sm.sm_fp = NULL;
 	x->sm.sm_buffer = 0;
 	x->sm.sm_object0 = sLAterminal_ioA;
 	x->sm.sm_object1 = OBJNULL;
 	x->sm.sm_int0 = x->sm.sm_int1 = 0; /* unused */
+	x->sm.sm_flags=0;
 	standard_io = x;
 	enter_mark_origin(&standard_io);	
 
@@ -2597,7 +2541,9 @@ gcl_init_file(void)
 
 DEFVAR("*IGNORE-EOF-ON-TERMINAL-IO*",sSAignore_eof_on_terminal_ioA,SI,Cnil,"");
 DEFVAR("*LOAD-PATHNAME*",sLAload_pathnameA,LISP,Cnil,"");
+DEFVAR("*LOAD-TRUENAME*",sSAload_truenameA,LISP,Cnil,"");
 DEFVAR("*LOAD-VERBOSE*",sLAload_verboseA,LISP,Ct,"");
+DEFVAR("*LOAD-PRINT*",sLAload_printA,LISP,Cnil,"");
 
 DEF_ORDINARY("ABORT",sKabort,KEYWORD,"");
 DEF_ORDINARY("APPEND",sKappend,KEYWORD,"");
@@ -2622,6 +2568,7 @@ DEF_ORDINARY("SUPERSEDE",sKsupersede,KEY
 DEF_ORDINARY("VERBOSE",sKverbose,KEYWORD,"");
 
 
+DEF_ORDINARY("DELETE-FILE",sLdelete_file,LISP,"");
 
 
 void
@@ -2673,13 +2620,9 @@ gcl_init_file_function()
 	make_function("STREAM-ELEMENT-TYPE", Lstream_element_type);
 	make_function("CLOSE", Lclose);
 
-	make_function("OPEN", Lopen);
-
 	make_function("FILE-POSITION", Lfile_position);
 	make_function("FILE-LENGTH", Lfile_length);
 
-	make_function("LOAD", Lload);
-
 	make_si_function("GET-STRING-INPUT-STREAM-INDEX",
 			 siLget_string_input_stream_index);
 	make_si_function("MAKE-STRING-OUTPUT-STREAM-FROM-STRING",
--- gcl-2.6.12.orig/o/gbc.c
+++ gcl-2.6.12/o/gbc.c
@@ -57,7 +57,7 @@ mark_contblock(void *, int);
    since this is more portable and faster lets use them --W. Schelter
    These assume that DBEGIN is divisible by 32, or else we should have
    #define Shamt(x) (((((int) x -DBEGIN) >> 2) & ~(~0 << 5)))
-*/ 
+*/
 #define LOG_BITS_CHAR 3
 
 #if CPTR_SIZE == 8
@@ -72,7 +72,7 @@ void *
 cb_in(void *p) {
   struct contblock **cbpp;
   int i;
-  
+
   for (cbpp=&cb_pointer,i=0;*cbpp;cbpp=&((*cbpp)->cb_link),i++) {
     if ((void *)*cbpp<=p && ((void *)(*cbpp)+(*cbpp)->cb_size) >p)
       return *cbpp;
@@ -84,7 +84,7 @@ int
 cb_print(void) {
   struct contblock **cbpp;
   int i;
-  
+
   for (cbpp=&cb_pointer,i=0;*cbpp;cbpp=&((*cbpp)->cb_link),i++)
     emsg("%lu at %p\n",(*cbpp)->cb_size,*cbpp);
   emsg("%u blocks\n",i);
@@ -146,7 +146,7 @@ pageinfo_p(void *v) {
     (!pi->next || (void *)pi->next>=v+(pi->type==t_contiguous ? pi->in_use : 1)*PAGESIZE);
 
 }
-    
+
 static inline char
 get_bit(char *v,struct pageinfo *pi,void *x) {
   void *ve=CB_DATA_START(pi);
@@ -157,16 +157,6 @@ get_bit(char *v,struct pageinfo *pi,void
   return (v[i]>>s)&0x1;
 }
 
-/* static inline void */
-/* set_bit(char *v,struct pageinfo *pi,void *x) { */
-/*   void *ve=CB_DATA_START(pi); */
-/*   fixnum off=(x-ve)>>LOG_BYTES_CONTBLOCK,i=off>>LOG_BITS_CHAR,s=off&~(~0UL<<LOG_BITS_CHAR); */
-/* #ifdef CONTBLOCK_MARK_DEBUG */
-/*   off_check(v,ve,i,pi); */
-/* #endif */
-/*   v[i]|=(1UL<<s); */
-/* } */
-
 #define bit_get(v,i,s) ((v[i]>>s)&0x1)
 #define bit_set(v,i,s) (v[i]|=(1UL<<s))
 #define ptr_get(v,i,s) (v+(((i<<LOG_BITS_CHAR)|s)<<LOG_BYTES_CONTBLOCK))
@@ -226,11 +216,6 @@ get_mark_bit(struct pageinfo *pi,void *x
   return get_bit(CB_MARK_START(pi),pi,x);
 }
 
-/* static inline void */
-/* set_mark_bit(struct pageinfo *pi,void *x) { */
-/*   set_bit(CB_MARK_START(pi),pi,x); */
-/* } */
-
 static inline void *
 get_mark_bits(struct pageinfo *pi,void *x) {
   return get_bits(CB_MARK_START(pi),pi,x);
@@ -248,11 +233,6 @@ get_sgc_bit(struct pageinfo *pi,void *x)
   return get_bit(CB_SGCF_START(pi),pi,x);
 }
 
-/* static inline void */
-/* set_sgc_bit(struct pageinfo *pi,void *x) { */
-/*   set_bit(CB_SGCF_START(pi),pi,x); */
-/* } */
-
 static inline void *
 get_sgc_bits(struct pageinfo *pi,void *x) {
   return get_bits(CB_SGCF_START(pi),pi,x);
@@ -438,16 +418,16 @@ mark_leaf_data(object x,void **pp,ufixnu
   if (!marking(p)||!collecting(p))
     return;
 
-  if (what_to_collect!=t_contiguous && 
+  if (what_to_collect!=t_contiguous &&
       x && x->d.st>=ngc_thresh &&
       (dp=alloc_contblock_no_gc(s,static_promotion_limit))) {
-    
+
     *pp=memcpy(dp,p,s);
     x->d.st=0;
 
     return;
 
-  } 
+  }
 
   if (x && x->d.st<rst.d.st) x->d.st++;
 
@@ -460,7 +440,7 @@ mark_leaf_data(object x,void **pp,ufixnu
 
 static void mark_object1(object);
 #define mark_object(x) if (marking(x)) mark_object1(x)
-    
+
 static inline void
 mark_object_address(object *o,int f) {
 
@@ -468,7 +448,7 @@ mark_object_address(object *o,int f) {
   static ufixnum lr;
 
   ufixnum p=page(o);
-  
+
   if (lp!=p || !f) {
     lp=p;
     lr=
@@ -496,7 +476,7 @@ mark_object_array(object *o,object *oe)
 
 static void
 mark_object1(object x) {
-  
+
   fixnum i,j=0;/*FIXME*/
 
   if (is_marked_or_free(x))
@@ -567,7 +547,7 @@ mark_object1(object x) {
     break;
     
   case t_array:
-    MARK_LEAF_DATA(x,x->a.a_dims,sizeof(int)*x->a.a_rank);
+    MARK_LEAF_DATA(x,x->a.a_dims,sizeof(*x->a.a_dims)*x->a.a_rank);
 
   case t_vector:
   case t_bitvector:
@@ -615,7 +595,7 @@ mark_object1(object x) {
 	x->v.v_self=p;
 	adjust_displaced(x,j);
       }
-    } 
+    }
     mark_object(x->v.v_displaced);
     break;
     
@@ -627,7 +607,7 @@ mark_object1(object x) {
       mark_object(x->str.str_def);
       if (x->str.str_self)
 	for (i=0,j=S_DATA(def)->length;i<j;i++)
-	  if (s_type[i]==0)
+	  if (s_type[i]==aet_object)
 	    mark_object_address(&STREF(object,x,s_pos[i]),i);
       MARK_LEAF_DATA(x,x->str.str_self,S_DATA(def)->size);
     }
@@ -646,7 +626,8 @@ mark_object1(object x) {
 	MARK_LEAF_DATA(x,x->sm.sm_buffer,BUFSIZ);
       }
       break;
-    
+
+    case smm_file_synonym:
     case smm_synonym:
       mark_object(x->sm.sm_object0);
       break;
@@ -676,7 +657,7 @@ mark_object1(object x) {
       error("mark stream botch");
     }
     break;
-    
+
   case t_random:
     MARK_LEAF_DATA_ALIGNED(x,x->rnd.rnd_state._mp_seed->_mp_d,x->rnd.rnd_state._mp_seed->_mp_alloc*MP_LIMB_SIZE,MP_LIMB_SIZE);
     break;
@@ -700,6 +681,7 @@ mark_object1(object x) {
     mark_object(x->pn.pn_name);
     mark_object(x->pn.pn_type);
     mark_object(x->pn.pn_version);
+    mark_object(x->pn.pn_namestring);
     break;
     
   case t_closure:
@@ -854,24 +836,6 @@ mark_phase(void) {
   }
 #endif
   
-  /*
-    if (what_to_collect != t_symbol &&
-    (int)what_to_collect < (int)t_contiguous) {
-  */
-  
-  /* {int size; */
-  
-  /* for (pp = pack_pointer;  pp != NULL;  pp = pp->p_link) { */
-  /*   size = pp->p_internal_size; */
-  /*   if (pp->p_internal != NULL) */
-  /*     for (i = 0;  i < size;  i++) */
-  /* 	mark_object(pp->p_internal[i]); */
-  /*   size = pp->p_external_size; */
-  /*   if (pp->p_external != NULL) */
-  /*     for (i = 0;  i < size;  i++) */
-  /* 	mark_object(pp->p_external[i]); */
-  /* }} */
-  
   /* mark the c stack */
 #ifndef N_RECURSION_REQD
 #define N_RECURSION_REQD 2
@@ -979,15 +943,15 @@ mark_c_stack(jmp_buf env1, int n, void (
     extern void * __libc_ia64_register_backing_store_base;
     void * bst=GC_save_regs_in_stack();
     void * bsb=__libc_ia64_register_backing_store_base;
-    
+
     if (bsb>bst)
       (*fn)(bsb,bst,C_GC_OFFSET);
     else
       (*fn)(bst,bsb,C_GC_OFFSET);
-    
+
   }
 #endif
-  
+
 }
 
 static void
@@ -1035,7 +999,7 @@ contblock_sweep_phase(void) {
   struct pageinfo *v;
   STATIC char *s, *e, *p, *q;
   ufixnum i;
-    
+
   reset_contblock_freelist();
 
   for (i=0;i<contblock_array->v.v_fillp && (v=(void *)contblock_array->v.v_self[i]);i++) {
@@ -1045,7 +1009,7 @@ contblock_sweep_phase(void) {
 #ifdef SGC
     if (sgc_enabled && !(v->sgc_flags&SGC_PAGE_FLAG)) continue;
 #endif
-    
+
     s=CB_DATA_START(v);
     e=(void *)v+v->in_use*PAGESIZE;
 
@@ -1070,25 +1034,6 @@ contblock_sweep_phase(void) {
 int (*GBC_enter_hook)() = NULL;
 int (*GBC_exit_hook)() = NULL;
 
-/* void */
-/* ttss(void) { */
-
-/*   struct typemanager *tm; */
-/*   void *x,*y; */
-
-/*   for (tm=tm_table;tm<tm_table+t_end;tm++) { */
-
-/*     for (x=tm->tm_free;x!=OBJNULL;x=(void *)((struct freelist *)x)->f_link) { */
-/*       if (x==Cnil) */
-/* 	printf("barr\n"); */
-/*       /\* for (y=(void *)((struct freelist *)x)->f_link;y!=OBJNULL && y!=x;y=(void *)((struct freelist *)y)->f_link); *\/ */
-/*       /\* if (y==x) *\/ */
-/*       /\* 	printf("circle\n"); *\/ */
-/*     } */
-/*   } */
-
-/* } */
-
 fixnum fault_pages=0;
 
 static ufixnum
@@ -1102,7 +1047,7 @@ count_contblocks(void) {
   return ncb;
   
 }
- 
+
 
 void
 GBC(enum type t) {
@@ -1120,7 +1065,7 @@ GBC(enum type t) {
 
   ngc_thresh=fix(sSAleaf_collection_thresholdA->s.s_dbind);
   recent_allocation=0;
-  
+
   if (in_signal_handler && t == t_relocatable)
     error("cant gc relocatable in signal handler");
   
@@ -1146,7 +1091,6 @@ GBC(enum type t) {
 	    close_stream(o);
 	}
 
-    /* t = t_relocatable; */
     gc_time = -1;
     }
 
@@ -1265,54 +1209,6 @@ GBC(enum type t) {
 #endif
   }
   
-
-/*   { */
-/*     static int promoting; */
-/*     if (!promoting && promotion_pointer>promotion_pointer1) { */
-/*       object *p,st; */
-/*       promoting=1; */
-/*       st=alloc_simple_string(""); */
-/*       for (p=promotion_pointer1;p<promotion_pointer;p++) { */
-/* 	fixnum j; */
-/* 	object x=*p; */
-	
-/* 	if (type_of(x)==t_string) */
-
-/*  	  j=x->st.st_dim; */
-
-/* 	else switch (x->v.v_elttype) { */
-
-/* 	  case aet_lf: */
-/* 	    j=sizeof(longfloat)*x->v.v_dim; */
-/* 	    break; */
-/* 	  case aet_bit: */
-/* #define W_SIZE (8*sizeof(fixnum)) */
-/* 	    j=sizeof(fixnum)*((BV_OFFSET(x) + x->bv.bv_dim + W_SIZE -1)/W_SIZE); */
-/* 	    break; */
-/* 	  case aet_char: */
-/* 	  case aet_uchar: */
-/* 	    j=sizeof(char)*x->v.v_dim; */
-/* 	    break; */
-/* 	  case aet_short: */
-/* 	  case aet_ushort: */
-/* 	    j=sizeof(short)*x->v.v_dim; */
-/* 	    break; */
-/* 	  default: */
-/* 	    j=sizeof(fixnum)*x->v.v_dim; */
-/* 	  } */
-
-/* 	st->st.st_dim=j; */
-/* 	st->st.st_self=alloc_contblock(st->st.st_dim); */
-/* 	fprintf(stderr,"Promoting vector leaf bytes %lu at %p, %p -> %p\n",j,x,x->v.v_self,st->st.st_self); */
-/* 	fflush(stderr); */
-/* 	memcpy(st->st.st_self,x->v.v_self,st->st.st_dim); */
-/* 	x->v.v_self=(void *)st->st.st_self; */
-/*       } */
-/*       promoting=0; */
-/*     } */
-/*   } */
-	
-
 #ifdef DEBUG
   if (debug) {
     int i,j;
@@ -1361,8 +1257,6 @@ GBC(enum type t) {
 
   CHECK_INTERRUPT;
 
-  /* ttss(); */
-
 }
 
 static void
@@ -1472,7 +1366,7 @@ mark_contblock(void *p, int s) {
   STATIC char *q;
   STATIC char *x, *y;
   struct pageinfo *v;
-  
+
   if (NULL_OR_ON_C_STACK(p))
     return;
 
@@ -1495,17 +1389,17 @@ DEFUN_NEW("CONTIGUOUS-REPORT",object,fSc
   ufixnum i,j,k,s;
   struct typemanager *tm=tm_of(t_cfdata);
   void *p;
-  
+
   for (i=j=0,cbpp=&cb_pointer;(*cbpp);) {
     for (k=0,s=(*cbpp)->cb_size,p=*cbpp;*cbpp && (*cbpp)->cb_size==s;i+=(*cbpp)->cb_size,j++,k++,cbpp=&(*cbpp)->cb_link);
     emsg("%lu %lu starting at %p\n",k,s,p);
   }
   emsg("\nTotal free %lu in %lu pieces\n\n",i,j);
-  
-  for (i=j=k=0;k<contblock_array->v.v_fillp && (v=(void *)contblock_array->v.v_self[k]);k++,i+=v->in_use,j++) 
+
+  for (i=j=k=0;k<contblock_array->v.v_fillp && (v=(void *)contblock_array->v.v_self[k]);k++,i+=v->in_use,j++)
     emsg("%lu pages at %p\n",(unsigned long)v->in_use,v);
   emsg("\nTotal pages %lu in %lu pieces\n\n",i,j);
-  
+
   for (i=j=0,v=cell_list_head;v;v=v->next)
     if (tm->tm_type==v->type) {
       void *p;
@@ -1520,7 +1414,7 @@ DEFUN_NEW("CONTIGUOUS-REPORT",object,fSc
       }
     }
   emsg("\nTotal code bytes %lu in %lu pieces\n",i,j);
-  
+
   for (i=j=0,v=cell_list_head;v;v=v->next) {
     struct typemanager *tm=tm_of(v->type);
     void *p;
@@ -1589,15 +1483,13 @@ DEFUN_NEW("CONTIGUOUS-REPORT",object,fSc
     }
   }
   emsg("\nTotal leaf bytes %lu in %lu pieces\n",i,j);
-  
+
   return Cnil;
 
 }
 
 DEFUN_NEW("GBC",object,fSgbc,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") {
 
-   /* 1 args */
-  
   if (x0 == Ct) {
     tm_table[t_contiguous].tm_adjgbccnt--;
     GBC(t_other);
@@ -1644,5 +1536,5 @@ gcl_init_GBC(void) {
 #ifdef SGC
   make_si_function("SGC-ON",siLsgc_on);
 #endif
-  
+
 }
--- gcl-2.6.12.orig/o/iteration.c
+++ gcl-2.6.12/o/iteration.c
@@ -95,7 +95,7 @@ do_var_list(object var_list)
           
 
 
-		if (type_of(x) != t_cons)
+		if (!consp(x))
 			FEinvalid_form("The index, ~S, is illegal.", x);
 		y = MMcar(x);
 		check_var(y);
@@ -326,7 +326,7 @@ FFN(Fdolist)(VOL object arg)
 	}
 
 	eval_assign(start->bt_init, listform);
-	body = find_special(MMcdr(arg), start, start+1);
+	body = find_special(MMcdr(arg), start, start+1,NULL); /*?*/
 	vs_push(body);
 	bind_var(start->bt_var, Cnil, start->bt_spp);
 	if ((enum stype)start->bt_var->s.s_stype != stp_ordinary)
@@ -410,7 +410,7 @@ FFN(Fdotimes)(VOL object arg)
 	if (type_of(start->bt_init) != t_fixnum &&
 	    type_of(start->bt_init) != t_bignum)
 		FEwrong_type_argument(sLinteger, start->bt_init);
-	body = find_special(MMcdr(arg), start, start+1);
+	body = find_special(MMcdr(arg), start, start+1,NULL); /*?*/
 	vs_push(body);
 	bind_var(start->bt_var, make_fixnum(0), start->bt_spp);
 	if ((enum stype)start->bt_var->s.s_stype != stp_ordinary) {
--- gcl-2.6.12.orig/o/let.c
+++ gcl-2.6.12/o/let.c
@@ -151,7 +151,7 @@ FFN(Fmultiple_value_bind)(object form)
 	}
 	{
 	 object *vt = vs_top;
-	 vs_push(find_special(body, start, (struct bind_temp *)vt));
+	 vs_push(find_special(body, start, (struct bind_temp *)vt,NULL)); /*?*/
 	}
 	for (i = 0;  i < n;  i++)
 		bind_var(start[i].bt_var,
@@ -230,7 +230,7 @@ is an illegal function definition in FLE
 		lex_fun_bind(MMcar(def), top[0]);
 		def_list = MMcdr(def_list);
 	}
-	vs_push(find_special(MMcdr(args), NULL, NULL));
+	vs_push(find_special(MMcdr(args), NULL, NULL,NULL));
 	Fprogn(vs_head);
 	lex_env = lex;
 }
@@ -271,7 +271,7 @@ is an illegal function definition in LAB
 		MMcaar(closure_list) = lex_env[1];
 		closure_list = MMcdr(closure_list);
 	}
-	vs_push(find_special(MMcdr(args), NULL, NULL));
+	vs_push(find_special(MMcdr(args), NULL, NULL,NULL));
 	Fprogn(vs_head);
 	lex_env = lex;
 }
@@ -304,7 +304,7 @@ is an illegal macro definition in MACROF
 		lex_macro_bind(MMcar(def), MMcaddr(top[0]));
 		def_list = MMcdr(def_list);
 	}
-	vs_push(find_special(MMcdr(args), NULL, NULL));
+	vs_push(find_special(MMcdr(args), NULL, NULL,NULL));
 	Fprogn(vs_head);
 	lex_env = lex;
 }
--- gcl-2.6.12.orig/o/pathname.d
+++ gcl-2.6.12/o/pathname.d
@@ -28,744 +28,93 @@ Foundation, 675 Mass Ave, Cambridge, MA
 #include <string.h>
 #include "include.h"
 
+DEFUN_NEW("C-SET-T-TT",object,fSc_set_t_tt,SI,2,2,NONE,OO,IO,OO,OO,(object x,fixnum y),"") {
+  x->d.tt=y;
+  RETURN1(x);
+}
+
+
+DEFUN_NEW("C-T-TT",object,fSc_t_tt,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {
+  RETURN1((object)(fixnum)x->d.tt);
+}
+
+
+DEFUN_NEW("C-SET-PATHNAME-NAMESTRING",object,fSc_set_pathname_namestring,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") {
+  check_type_pathname(&x);
+  x->pn.pn_namestring=y;
+  RETURN1(x);
+}
+
+DEFUN_NEW("C-PATHNAME-HOST",object,fSc_pathname_host,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  check_type_pathname(&x);
+  RETURN1(x->pn.pn_host);
+}
+DEFUN_NEW("C-PATHNAME-DEVICE",object,fSc_pathname_device,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  check_type_pathname(&x);
+  RETURN1(x->pn.pn_device);
+}
+DEFUN_NEW("C-PATHNAME-DIRECTORY",object,fSc_pathname_directory,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  check_type_pathname(&x);
+  RETURN1(x->pn.pn_directory);
+}
+DEFUN_NEW("C-PATHNAME-NAME",object,fSc_pathname_name,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  check_type_pathname(&x);
+  RETURN1(x->pn.pn_name);
+}
+DEFUN_NEW("C-PATHNAME-TYPE",object,fSc_pathname_type,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  check_type_pathname(&x);
+  RETURN1(x->pn.pn_type);
+}
+DEFUN_NEW("C-PATHNAME-VERSION",object,fSc_pathname_version,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  check_type_pathname(&x);
+  RETURN1(x->pn.pn_version);
+}
+DEFUN_NEW("C-PATHNAME-NAMESTRING",object,fSc_pathname_namestring,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  check_type_pathname(&x);
+  RETURN1(x->pn.pn_namestring);
+}
 
-object
-make_pathname(host, device, directory, name, type, version)
-object host, device, directory, name, type, version;
-{
-	object x;
-
-	x = alloc_object(t_pathname);
-	x->pn.pn_host = host;
-	x->pn.pn_device = device;
-	x->pn.pn_directory = directory;
-	x->pn.pn_name = name;
-	x->pn.pn_type = type;
-	x->pn.pn_version = version;
-	return(x);
-}
-
-static void
-make_one(s, end)
-char *s;
-int end;
-{
-	int i;
-
-#ifdef UNIX
-	for (i = 0;  i < end;  i++)
-		token->st.st_self[i] = s[i];
-#endif
-#ifdef AOSVS
-
-
-
-#endif
-	token->st.st_fillp = end;
-	vs_push(copy_simple_string(token));
-}
-
-/* The function below does not attempt to handle DOS pathnames 
-   which use backslashes as directory separators.  It needs 
-   TLC from someone who feels pedantic. MJT */
-
-/* !!!!! Bug Fix. NLG */
-object
-parse_namestring(s, start, end, ep)
-object s;
-int start, end, *ep;
-{
-	int i, j, k, founddosdev = FALSE, oldstart=start, oldend=end, justdevice = FALSE;
-	int d;
-	object *vsp;
-	object x;
-	vs_mark;
-
-#ifndef IS_DIR_SEPARATOR
-#define IS_DIR_SEPARATOR(x) (x == '/')
-#endif
-
-	*ep=oldend;
-	vsp = vs_top + 1;
-	for (;--end >= start && isspace((int)s->st.st_self[end]););
-
-	/* Check for a DOS path and process later */
-	if ( ( (start+1) <= end) &&  (s->st.st_self[start+1] == ':' )) {
-	    start+=2;
-	    founddosdev = TRUE;
-        }
-        if ( start > end ) {
-	    make_one(&s->st.st_self[0], 0);
-	    justdevice = TRUE;
-	} else {
-	    for (i = j = start;  i <= end;  ) {
-#ifdef UNIX
-		if (IS_DIR_SEPARATOR(s->st.st_self[i])) {
-#endif
-			if (j == start && i == start) {
-				i++;
-				vs_push(sKroot);
-				j = i;
-				continue;
-			}
-#ifdef UNIX
-			if (i-j == 1 && s->st.st_self[j] == '.') {
-				vs_push(sKcurrent);
-			} else if (i-j == 1 && s->st.st_self[j] == '*') {
-				vs_push(sKwild);
-			} else if (i-j==2 && s->st.st_self[j]=='.' && s->st.st_self[j+1]=='.') {
-				vs_push(sKparent);
-			} else {
-				make_one(&s->st.st_self[j], i-j);
-                        }
-#endif
-			i++;
-			j = i;
-		} else {
-			i++;
-		}
-	    }
-	    *ep = i;
-	    vs_push(Cnil);
-	    while (vs_top > vsp)
-		stack_cons();
-	    if (i == j) {
-		/*  no file and no type  */
-		vs_push(Cnil);
-		vs_push(Cnil);
-		goto L;
-	    }
-	    for (k = j, d = -1;  k < i;  k++)
-		if (s->st.st_self[k] == '.')
-			d = k;
-	    if (d == -1) {
-		/*  no file type  */
-#ifdef UNIX
-		if (i-j == 1 && s->st.st_self[j] == '*')
-#endif
-			vs_push(sKwild);
-		else
-			make_one(&s->st.st_self[j], i-j);
-	        
-		vs_push(Cnil);
-	    } else if (d == j) {
-		/*  no file name  */
-		vs_push(Cnil);
-#ifdef UNIX
-		if (i-d-1 == 1 && s->st.st_self[d+1] == '*')
-#endif
-			vs_push(sKwild);
-		else
-			make_one(&s->st.st_self[d+1], i-d-1);
-	    } else {
-		/*  file name and file type  */
-#ifdef UNIX
-		if (d-j == 1 && s->st.st_self[j] == '*')
-#endif
-			vs_push(sKwild);
-		else {
-			make_one(&s->st.st_self[j], d-j);
-	             }
-#ifdef UNIX
-		if (i-d-1 == 1 && s->st.st_self[d+1] == '*')
-#endif
-			vs_push(sKwild);
-		else
-			make_one(&s->st.st_self[d+1], i-d-1);
-	    }
-        }
-L:
-	/* Process DOS device name found earlier, build a string in a list and push it */
-	if ( founddosdev ) {
-	    /* Drive letter */
-	    token->st.st_self[0] = s->st.st_self[oldstart];
-	    /* Colon */
-	    token->st.st_self[1] = s->st.st_self[oldstart+1];
-	    /* Fill pointer */
-	    token->st.st_fillp = 2;
-	    /* Push */
-	    vs_push(make_cons(copy_simple_string(token),Cnil));
-	} else {
-	    /* No device name */
-	    vs_push(Cnil);
-	}
-	if ( justdevice ) {
-	    x = make_pathname ( Cnil, vs_top[-1], Cnil, Cnil, Cnil, Cnil );
-	} else {
-	    x = make_pathname ( Cnil, vs_top[-1], vs_top[-4], vs_top[-3], vs_top[-2], Cnil );
-	}
-	vs_reset;
-	return(x);
-}
-
-object
-coerce_to_pathname(x)
-object x;
-{
-	object y;
-	int e;
-
-L:
-	switch (type_of(x)) {
-	case t_symbol:
-	case t_string:
-                /* !!!!! Bug Fix. NLG */
-		y = parse_namestring(x, 0, x->st.st_fillp, &e);
-		if (y == OBJNULL || e != x->st.st_fillp)
-			goto CANNOT_COERCE;
-		return(y);
-
-	case t_pathname:
-		return(x);
-
-	case t_stream:
-		switch (x->sm.sm_mode) {
-		case smm_input:
-		case smm_output:
-		case smm_probe:
-		case smm_io:
-			x = x->sm.sm_object1;
-			/*
-				The file was stored in sm.sm_object1.
-				See open.
-			*/
-			goto L;
-
-		case smm_synonym:
-			x = symbol_value(x->sm.sm_object0);
-			goto L;
-
-		default:
-			goto CANNOT_COERCE;
-		}
-
-	default:
-	CANNOT_COERCE:
-		FEerror("~S cannot be coerced to a pathname.", 1, x);
-		return(Cnil);
-	}
-}
-
-static object
-default_device(host)
-object host;
-{
-	return(Cnil);
-	/*  not implemented yet  */
-}
-
-object
-merge_pathnames(path, defaults, default_version)
-object path, defaults, default_version;
-{
-	object host, device, directory, name, type, version;
-
-	if (path->pn.pn_host == Cnil)
-		host = defaults->pn.pn_host;
-	else
-		host = path->pn.pn_host;
-	if (path->pn.pn_device == Cnil)
-		if (path->pn.pn_host == Cnil)
-			device = defaults->pn.pn_device;
-		else if (path->pn.pn_host == defaults->pn.pn_host)
-			device = defaults->pn.pn_device;
-		else
-			device = default_device(path->pn.pn_host);
-	else
-		device = path->pn.pn_device;
-
-	if (defaults->pn.pn_directory==Cnil || 
-	   (type_of(path->pn.pn_directory)==t_cons
-	    && path->pn.pn_directory->c.c_car==sKroot))
-		directory=path->pn.pn_directory;
-	else 
-	  directory=path->pn.pn_directory==Cnil ? 
-	    defaults->pn.pn_directory :
-	    append(defaults->pn.pn_directory,path->pn.pn_directory);
-
-	if (path->pn.pn_name == Cnil)
-		name = defaults->pn.pn_name;
-	else
-		name = path->pn.pn_name;
-	if (path->pn.pn_type == Cnil)
-		type = defaults->pn.pn_type;
-	else
-		type = path->pn.pn_type;
-	version = Cnil;
-	/*
-		In this implimentation, version is not counted
-	*/
-	return(make_pathname(host,device,directory,name,type,version));
-}
-
-/*
-	Namestring(x) converts a pathname to a namestring.
-*/
-object
-namestring(x)
-object x;
-{
-
-	int i, j;
-	object l, y;
-
-	i = 0;
-
-	l = x->pn.pn_device;
-	if (endp(l)) {
-		goto D;
-	}
-	y = l->c.c_car;
-	y = coerce_to_string(y);
-	for (j = 0;  j < y->st.st_fillp;  j++) {
-	    token->st.st_self[i++] = y->st.st_self[j];
-	}
-
-D:	l = x->pn.pn_directory;
-	if (endp(l))
-		goto L;
-	y = l->c.c_car;
-	if (y == sKroot) {
-#ifdef UNIX
-		token->st.st_self[i++] = '/';
-#endif
-		l = l->c.c_cdr;
-	}
-	for (;  !endp(l);  l = l->c.c_cdr) {
-		y = l->c.c_car;
-#ifdef UNIX
-		if (y == sKcurrent) {
-			token->st.st_self[i++] = '.';
-			token->st.st_self[i++] = '/';
-			continue;
-		} else if (y == sKwild) {
-			token->st.st_self[i++] = '*';
-			token->st.st_self[i++] = '/';
-			continue;
-		} else if (y == sKparent) {
-			token->st.st_self[i++] = '.';
-			token->st.st_self[i++] = '.';
-			token->st.st_self[i++] = '/';
-			continue;
-		}
-#endif
-		y = coerce_to_string(y);
-		for (j = 0;  j < y->st.st_fillp;  j++)
-			token->st.st_self[i++]
-			= y->st.st_self[j];
-#ifdef UNIX
-		token->st.st_self[i++] = '/';
-#endif
-#ifdef AOSVS
-
-#endif
-	}
-L:
-	y = x->pn.pn_name;
-	if (y == Cnil)
-		goto M;
-	if (y == sKwild) {
-#ifdef UNIX
-		token->st.st_self[i++] = '*';
-#endif
-#ifdef AOSVS
-
-#endif
-		goto M;
-	}
-	if (type_of(y) != t_string)
-		FEerror("~S is an illegal pathname name.", 1, y);
-	for (j = 0;  j < y->st.st_fillp;  j++)
-		token->st.st_self[i++] = y->st.st_self[j];
-M:
-	y = x->pn.pn_type;
-	if (y == Cnil)
-		goto N;
-	if (y == sKwild) {
-		token->st.st_self[i++] = '.';
-#ifdef UNIX
-		token->st.st_self[i++] = '*';
-#endif
-#ifdef AOSVS
-
-#endif
-		goto N;
-	}
-	if (type_of(y) != t_string)
-		FEerror("~S is an illegal pathname name.", 1, y);
-	token->st.st_self[i++] = '.';
-	for (j = 0;  j < y->st.st_fillp;  j++)
-		token->st.st_self[i++] = y->st.st_self[j];
-N:
-	token->st.st_fillp = i;
-#ifdef FIX_FILENAME
-        {char buf[MAXPATHLEN];
-         if (i > MAXPATHLEN-1) i =MAXPATHLEN-1;
-         memcpy(buf,token->st.st_self,i);
-         buf[i]=0;
-         FIX_FILENAME(x,buf);
-         return (make_simple_string(buf));
-         }
-#endif
-	return(copy_simple_string(token));
-}
-
-object
-coerce_to_namestring(x)
-object x;
-{
-
-L:
-	switch (type_of(x)) {
-	case t_symbol:
-	{BEGIN_NO_INTERRUPT;
-		vs_push(alloc_simple_string(x->s.s_fillp));
-		/* By Nick Gall */
-		vs_head->st.st_self = alloc_relblock(x->s.s_fillp);
-		{
-			int i;
-			for (i = 0;  i < x->s.s_fillp;  i++)
-				vs_head->st.st_self[i] = x->s.s_self[i];
-		}
-	END_NO_INTERRUPT;}
-                return(vs_pop);
-
-	case t_string:
-		return(x);
-
-	case t_pathname:
-		return(namestring(x));
-
-	case t_stream:
-		switch (x->sm.sm_mode) {
-		case smm_input:
-		case smm_output:
-		case smm_probe:
-		case smm_io:
-			x = x->sm.sm_object1;
-			/*
-				The file was stored in sm.sm_object1.
-				See open.
-			*/
-			goto L;
-
-		case smm_synonym:
-			x = symbol_value(x->sm.sm_object0);
-			goto L;
-
-		default:
-			goto CANNOT_COERCE;
-		}
-
-	default:
-	CANNOT_COERCE:
-		FEerror("~S cannot be coerced to a namestring.", 1, x);
-		return(Cnil);
-	}
-}
-
-LFD(Lpathname)(void)
-{
-	check_arg(1);
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-}
-
-@(defun parse_namestring (thing
-	&o host
-	   (defaults `symbol_value(Vdefault_pathname_defaults)`)
-	&k start end junk_allowed
-	&a x y)
-	int s, e, ee;
-@
-	check_type_or_pathname_string_symbol_stream(&thing);
-	check_type_or_pathname_string_symbol_stream(&defaults);
-	defaults = coerce_to_pathname(defaults);
-	x = thing;
-L:
-	switch (type_of(x)) {
-	case t_symbol:
-	case t_string:
-		get_string_start_end(x, start, end, &s, &e);
-		for (;  s < e && isspace((int)x->st.st_self[s]);  s++)
-			;
-		y
-                  /* !!!!! Bug Fix. NLG */
-		= parse_namestring(x,
-                                   s,
-				   e - s,
-				   &ee);
-		if (junk_allowed == Cnil) {
-			for (;  ee < e - s;  ee++)
-				if (!isspace((int)x->st.st_self[s + ee]))
-					break;
-			if (y == OBJNULL || ee != e - s)
-				FEerror("Cannot parse the namestring ~S~%\
-from ~S to ~S.",
-					3, x, start, end);
-		} else
-			if (y == OBJNULL)
-				@(return Cnil `make_fixnum(s + ee)`)
-		start = make_fixnum(s + ee);
-		break;
-
-	case t_pathname:
-		y = x;
-		break;
-
-	case t_stream:
-		switch (x->sm.sm_mode) {
-		case smm_input:
-		case smm_output:
-		case smm_probe:
-		case smm_io:
-			x = x->sm.sm_object1;
-			/*
-				The file was stored in sm.sm_object1.
-				See open.
-			*/
-			goto L;
-
-		case smm_synonym:
-			x = symbol_value(x->sm.sm_object0);
-			goto L;
-
-		default:
-			goto CANNOT_PARSE;
-		}
-
-	default:
-	CANNOT_PARSE:
-		FEerror("Cannot parse the namestring ~S.", 1, x);
-	}
-	if (host != Cnil && y->pn.pn_host != Cnil &&
-	    host != y->pn.pn_host)
-		FEerror("The hosts ~S and ~S do not match.",
-			2, host, y->pn.pn_host);
-	@(return y start)
-@)
-
-@(defun merge_pathnames (path
-	&o (defaults `symbol_value(Vdefault_pathname_defaults)`)
- 	   (default_version sKnewest))
-@
-	check_type_or_pathname_string_symbol_stream(&path);
-	check_type_or_pathname_string_symbol_stream(&defaults);
-	path = coerce_to_pathname(path);
-	defaults = coerce_to_pathname(defaults);
-	@(return `merge_pathnames(path, defaults, default_version)`)
-@)
-
-@(defun make_pathname (&key
-        (host `Cnil` host_supplied_p)
-	(device `Cnil` device_supplied_p)
-	(directory `Cnil` directory_supplied_p)
-	(name `Cnil` name_supplied_p)
-	(type `Cnil` type_supplied_p)
-	(version `Cnil` version_supplied_p)
-	defaults
-		       &aux x)
-@
-	if ( defaults == Cnil ) {
-		defaults = symbol_value ( Vdefault_pathname_defaults );
-		defaults = coerce_to_pathname ( defaults );
-		defaults = make_pathname ( defaults->pn.pn_host,
-				 Cnil, Cnil, Cnil, Cnil, Cnil);
-	} else {
-		defaults = coerce_to_pathname(defaults);
-        }
-	x = make_pathname(host, device, directory, name, type, version);
-	x = merge_pathnames(x, defaults, Cnil);
-        if ( host_supplied_p) x->pn.pn_host = host;
-	if (device_supplied_p) x->pn.pn_device = device;
-	if (directory_supplied_p) x->pn.pn_directory = directory;
-	if (name_supplied_p) x->pn.pn_name = name;
-	if (type_supplied_p) x->pn.pn_type = type;
-	if (version_supplied_p) x->pn.pn_version = version;
-	@(return x)
-@)
-
-LFD(Lpathnamep)(void)
-{
-	check_arg(1);
-
-	if (type_of(vs_base[0]) == t_pathname)
-		vs_base[0] = Ct;
-	else
-		vs_base[0] = Cnil;
-}
-
-LFD(Lpathname_host)(void)
-{
-	check_arg(1);
-
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-	vs_base[0] = vs_base[0]->pn.pn_host;
-}
-
-LFD(Lpathname_device)(void)
-{
-	check_arg(1);
-
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-	vs_base[0] = vs_base[0]->pn.pn_device;
-}
-
-LFD(Lpathname_directory)(void)
-{
-	check_arg(1);
-
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-	vs_base[0] = vs_base[0]->pn.pn_directory;
-}
-
-LFD(Lpathname_name)(void)
-{
-	check_arg(1);
-
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-	vs_base[0] = vs_base[0]->pn.pn_name;
-}
-
-LFD(Lpathname_type)(void)
-{
-	check_arg(1);
-
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-	vs_base[0] = vs_base[0]->pn.pn_type;
-}
-
-LFD(Lpathname_version)(void)
-{
-	check_arg(1);
-
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-	vs_base[0] = vs_base[0]->pn.pn_version;
-}
-
-LFD(Lnamestring)(void)
-{
-	check_arg(1);
-
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	vs_base[0] = coerce_to_namestring(vs_base[0]);
-}
-
-LFD(Lfile_namestring)(void)
-{
-	check_arg(1);
-
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-	vs_base[0]
-	= make_pathname(Cnil, Cnil, Cnil,
-		        vs_base[0]->pn.pn_name,
-		        vs_base[0]->pn.pn_type,
-		        vs_base[0]->pn.pn_version);
-	vs_base[0] = namestring(vs_base[0]);
-}
-
-LFD(Ldirectory_namestring)(void)
-{
-	check_arg(1);
-
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-	vs_base[0]
-	= make_pathname(Cnil, Cnil,
-		        vs_base[0]->pn.pn_directory,
-		        Cnil, Cnil, Cnil);
-	vs_base[0] = namestring(vs_base[0]);
-}
-
-LFD(Lhost_namestring)(void)
-{
-	check_arg(1);
-
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-	vs_base[0] = vs_base[0]->pn.pn_host;
-	if (vs_base[0] == Cnil || vs_base[0] == sKwild)
-		vs_base[0] = make_simple_string("");
-}
-
-@(defun enough_namestring (path
-	&o (defaults `symbol_value(Vdefault_pathname_defaults)`))
-@
-	check_type_or_pathname_string_symbol_stream(&path);
-	check_type_or_pathname_string_symbol_stream(&defaults);
-	defaults = coerce_to_pathname(defaults);
-	path = coerce_to_pathname(path);
-	path
-	= make_pathname(equalp(path->pn.pn_host, defaults->pn.pn_host) ?
-			Cnil : path->pn.pn_host,
-	                equalp(path->pn.pn_device,
-			       defaults->pn.pn_device) ?
-			Cnil : path->pn.pn_device,
-	                equalp(path->pn.pn_directory,
-			       defaults->pn.pn_directory) ?
-			Cnil : path->pn.pn_directory,
-	                equalp(path->pn.pn_name, defaults->pn.pn_name) ?
-			Cnil : path->pn.pn_name,
-	                equalp(path->pn.pn_type, defaults->pn.pn_type) ?
-			Cnil : path->pn.pn_type,
-	                equalp(path->pn.pn_version,
-			       defaults->pn.pn_version) ?
-			Cnil : path->pn.pn_version);
-	@(return `namestring(path)`)
-@)
+
+DEFUN_NEW("C-STREAM-OBJECT0",object,fSc_stream_object0,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  RETURN1(x->sm.sm_object0);
+}
+
+DEFUN_NEW("C-STREAM-OBJECT1",object,fSc_stream_object1,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  RETURN1(x->sm.sm_object1);
+}
+
+DEFUN_NEW("C-SET-STREAM-OBJECT1",object,fSc_set_stream_object1,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") {
+  x->sm.sm_object1=y;
+  RETURN1(x);
+}
+
+DEFUN_NEW("INIT-PATHNAME",object,fSinit_pathname,SI,7,7,NONE,OO,OO,OO,OO,
+      (object host,object device,object directory,object name,object type,object version,object namestring),"") {
+
+  object x=alloc_object(t_pathname);
+
+  x->pn.pn_host=host;
+  x->pn.pn_device=device;
+  x->pn.pn_directory=directory;
+  x->pn.pn_name=name;
+  x->pn.pn_type=type;
+  x->pn.pn_version=version;
+  x->pn.pn_namestring=namestring;
+
+  RETURN1(x);
+
+}
+
+DEFUN_NEW("PATHNAMEP",object,fLpathnamep,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  RETURN1(type_of(x)==t_pathname ? Ct : Cnil);
+}
 
 void
-gcl_init_pathname(void)
-{
-	Vdefault_pathname_defaults =
-	make_special("*DEFAULT-PATHNAME-DEFAULTS*",
-		     make_pathname(Cnil, Cnil, Cnil, Cnil, Cnil, Cnil));
-
-	sKwild = make_keyword("WILD");
-	sKnewest = make_keyword("NEWEST");
-
-	sKstart = make_keyword("START");
-	sKend = make_keyword("END");
-	sKjunk_allowed = make_keyword("JUNK-ALLOWED");
-
-	sKhost = make_keyword("HOST");
-	sKdevice = make_keyword("DEVICE");
-	sKdirectory = make_keyword("DIRECTORY");
-	sKname = make_keyword("NAME");
-	sKtype = make_keyword("TYPE");
-	sKversion = make_keyword("VERSION");
-	sKdefaults = make_keyword("DEFAULTS");
-
-	sKroot = make_keyword("ROOT");
-	sKcurrent = make_keyword("CURRENT");
-	sKparent = make_keyword("PARENT");
-	sKper = make_keyword("PER");
+gcl_init_pathname(void) {
+
 }
 
 void
-gcl_init_pathname_function()
-{
-	make_function("PATHNAME", Lpathname);
-	make_function("PARSE-NAMESTRING", Lparse_namestring);
-	make_function("MERGE-PATHNAMES", Lmerge_pathnames);
-	make_function("MAKE-PATHNAME", Lmake_pathname);
-	make_function("PATHNAMEP", Lpathnamep);
-	make_function("PATHNAME-HOST", Lpathname_host);
-	make_function("PATHNAME-DEVICE", Lpathname_device);
-	make_function("PATHNAME-DIRECTORY", Lpathname_directory);
-	make_function("PATHNAME-NAME", Lpathname_name);
-	make_function("PATHNAME-TYPE", Lpathname_type);
-	make_function("PATHNAME-VERSION", Lpathname_version);
-	make_function("NAMESTRING", Lnamestring);
-	make_function("FILE-NAMESTRING", Lfile_namestring);
-	make_function("DIRECTORY-NAMESTRING", Ldirectory_namestring);
-	make_function("HOST-NAMESTRING", Lhost_namestring);
-	make_function("ENOUGH-NAMESTRING", Lenough_namestring);
+gcl_init_pathname_function(void) {
+
 }
--- gcl-2.6.12.orig/o/predicate.c
+++ gcl-2.6.12/o/predicate.c
@@ -29,6 +29,10 @@ Foundation, 675 Mass Ave, Cambridge, MA
 #include <string.h>
 #include "include.h"
 
+DEFUN_NEW("PATHNAME-DESIGNATORP",object,fSpathname_designatorp,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  RETURN1(pathname_designatorp(x) ? Ct : Cnil);
+}
+
 DEFUNO_NEW("NULL",object,fLnull,LISP
 	  ,1,1,NONE,OO,OO,OO,OO,void,Lnull,(object x0),"")
 {
--- gcl-2.6.12.orig/o/print.d
+++ gcl-2.6.12/o/print.d
@@ -1260,6 +1260,7 @@ int level;
 			write_ch('>');
 			break;
 
+		case smm_file_synonym:
 		case smm_synonym:
 			write_str("#<synonym stream to ");
 			write_object(x->sm.sm_object0, level);
@@ -1381,7 +1382,7 @@ int level;
 		if (1 || PRINTescape) {
 			write_ch('#');
 			write_ch('p');
-			vs_push(namestring(x));
+			vs_push(x->pn.pn_namestring==Cnil ? make_simple_string("") : x->pn.pn_namestring);
 			write_object(vs_head, level);
 			vs_popp;
 		} else {
--- gcl-2.6.12.orig/o/read.d
+++ gcl-2.6.12/o/read.d
@@ -1564,38 +1564,6 @@ Ldefault_dispatch_macro()
 }
 
 /*
-	#p" ... " returns the pathname with namestring ... .
-*/
-static void
-Lsharp_p_reader()
-{
-	check_arg(3);
-	if (vs_base[2] != Cnil && !READsuppress)
-		extra_argument('p');
-	vs_popp;
-	vs_popp;
-	vs_base[0] = read_object(vs_base[0]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-}
-
-/*
-	#" ... " returns the pathname with namestring ... .
-*/
-static void
-Lsharp_double_quote_reader()
-{
-	check_arg(3);
-
-	if (vs_base[2] != Cnil && !READsuppress)
-		extra_argument('"');
-	vs_popp;
-	unread_char(vs_base[1], vs_base[0]);
-	vs_popp;
-	vs_base[0] = read_object(vs_base[0]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-}
-
-/*
 	#$ fixnum returns a random-state with the fixnum
 	as its content.
 */
@@ -2369,9 +2337,6 @@ gcl_init_read()
 	dtab['<'] = make_cf(Lsharp_less_than_reader);
 */
 	dtab['|'] = make_cf(Lsharp_vertical_bar_reader);
-	dtab['"'] = make_cf(Lsharp_double_quote_reader);
-	dtab['p'] = make_cf(Lsharp_p_reader);
-	dtab['P'] = make_cf(Lsharp_p_reader);
 	/*  This is specific to this implimentation  */
 	dtab['$'] = make_cf(Lsharp_dollar_reader);
 	/*  This is specific to this implimentation  */
--- gcl-2.6.12.orig/o/regexp.c
+++ gcl-2.6.12/o/regexp.c
@@ -117,7 +117,7 @@ min_initial_branch_length(regexp *, unsi
 #define	PLUS	11	/* node	Match this (simple) thing 1 or more times. */
 #define	OPEN	20	/* no	Mark this point in input as start of #n. */
 			/*	OPEN+1 is number 1, etc. */
-#define	CLOSE	30	/* no	Analogous to OPEN. */
+#define	CLOSE	(OPEN+NSUBEXP)	/* no	Analogous to OPEN. */
 
 /*
  * Opcode notes:
@@ -1083,15 +1083,8 @@ regmatch(char *prog)
 			break;
 		case BACK:
 			break;
-		case OPEN+1:
-		case OPEN+2:
-		case OPEN+3:
-		case OPEN+4:
-		case OPEN+5:
-		case OPEN+6:
-		case OPEN+7:
-		case OPEN+8:
-		case OPEN+9: {
+		case OPEN+1 ... OPEN+NSUBEXP-1:
+		  {
 				register int no;
 				register char *save;
 
@@ -1112,15 +1105,8 @@ regmatch(char *prog)
 			}
 			/* NOTREACHED */
 			break;
-		case CLOSE+1:
-		case CLOSE+2:
-		case CLOSE+3:
-		case CLOSE+4:
-		case CLOSE+5:
-		case CLOSE+6:
-		case CLOSE+7:
-		case CLOSE+8:
-		case CLOSE+9: {
+		case CLOSE+1 ... CLOSE+NSUBEXP-1:
+		  {
 				register int no;
 				register char *save;
 
@@ -1394,27 +1380,11 @@ char *op;
 	case END:
 		p = "END";
 		break;
-	case OPEN+1:
-	case OPEN+2:
-	case OPEN+3:
-	case OPEN+4:
-	case OPEN+5:
-	case OPEN+6:
-	case OPEN+7:
-	case OPEN+8:
-	case OPEN+9:
+	case OPEN+1 ... OPEN+NSUBEXP-1:
 		sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN);
 		p = NULL;
 		break;
-	case CLOSE+1:
-	case CLOSE+2:
-	case CLOSE+3:
-	case CLOSE+4:
-	case CLOSE+5:
-	case CLOSE+6:
-	case CLOSE+7:
-	case CLOSE+8:
-	case CLOSE+9:
+	case CLOSE+1 ... CLOSE+NSUBEXP-1:
 		sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE);
 		p = NULL;
 		break;
--- gcl-2.6.12.orig/o/regexp.h
+++ gcl-2.6.12/o/regexp.h
@@ -1,7 +1,7 @@
 #ifndef _REGEXP
 #define _REGEXP 1
 
-#define NSUBEXP  10
+#define NSUBEXP  19
 typedef struct regexp {
 	char *startp[NSUBEXP];
 	char *endp[NSUBEXP];
--- gcl-2.6.12.orig/o/regexpr.c
+++ gcl-2.6.12/o/regexpr.c
@@ -81,6 +81,7 @@ DEFUN_NEW("COMPILE-REGEXP",object,fScomp
   res->v.v_elttype=aet_uchar;
   res->v.v_adjustable=0;
   res->v.v_offset=0;
+  res->v.v_self=NULL;
   if (!(res->v.v_self=(void *)regcomp(tmp,&res->v.v_dim)))
     FEerror("regcomp failure",0);
   res->v.v_fillp=res->v.v_dim;
--- gcl-2.6.12.orig/o/run_process.c
+++ gcl-2.6.12/o/run_process.c
@@ -177,10 +177,12 @@ void run_process ( char *name )
     stream_in->sm.sm_mode = smm_input;
     stream_in->sm.sm_fp = ofp;
     stream_in->sm.sm_buffer = 0;
+    stream_in->sm.sm_flags=0;
     stream_out = (object) alloc_object(t_stream);
     stream_out->sm.sm_mode = smm_output;
     stream_out->sm.sm_fp = ifp;
     stream_out->sm.sm_buffer = 0;
+    stream_out->sm.sm_flags=0;
     setup_stream_buffer ( stream_in );
     setup_stream_buffer ( stream_out );
     stream = make_two_way_stream ( stream_in, stream_out );
@@ -433,6 +435,7 @@ enum smmode smm;
 	stream->sm.sm_object0 = sLcharacter;
 	stream->sm.sm_object1 = host_l;
 	stream->sm.sm_int0 = stream->sm.sm_int1 = 0;
+	stream->sm.sm_flags=0;
 	vs_push(stream);
 	setup_stream_buffer(stream);
 	vs_reset;
@@ -503,6 +506,7 @@ make_socket_pair()
   stream_in->sm.sm_int0 = sockets_in[1];
   stream_in->sm.sm_int1 = 0;
   stream_in->sm.sm_object0=stream_in->sm.sm_object1=OBJNULL;
+  stream_in->sm.sm_flags = 0;
   stream_out = (object) alloc_object(t_stream);
   stream_out->sm.sm_mode = smm_output;
   stream_out->sm.sm_fp = fp2;
@@ -511,6 +515,7 @@ make_socket_pair()
   setup_stream_buffer(stream_out);
   stream_out->sm.sm_int0 = sockets_out[1];
   stream_out->sm.sm_int1 = 0;
+  stream_out->sm.sm_flags = 0;
   stream_out->sm.sm_object0=stream_out->sm.sm_object1=OBJNULL;
   stream = make_two_way_stream(stream_in, stream_out);
   return(stream);
--- gcl-2.6.12.orig/o/sfaslcoff.c
+++ gcl-2.6.12/o/sfaslcoff.c
@@ -151,6 +151,16 @@ find_init_address(struct syment *sym,str
 
 }    
 
+static ul
+get_sym_value(const char *name) {
+
+  struct node *answ;
+
+  return (answ=find_sym_ptable(name)) ? answ->address :
+    ({massert(!emsg("Unrelocated non-local symbol: %s\n",name));0;});
+
+}
+
 static void
 relocate_symbols(struct syment *sym,struct syment *sye,struct scnhdr *sec1,char *st1) {
 
@@ -163,22 +173,10 @@ relocate_symbols(struct syment *sym,stru
 
     else if (!sym->n_scnum) {
 
-      char c=0,*s;
-
-      if (sym->n.n.n_zeroes) {
-	c=sym->n.n_name[8];
-	sym->n.n_name[8]=0;
-	s=sym->n.n_name;
-      } else
-	s=st1+sym->n.n.n_offset;
-
-      if ((answ=find_sym_ptable(s))) 
-	sym->n_value=answ->address;
+      if (sym->n.n.n_zeroes)
+	STOP(sym->n.n_name,sym->n_value=get_sym_value(sym->n.n_name));
       else
-	massert(!emsg("Unrelocated non-local symbol: %s\n",s));
-
-      if (c)
-	sym->n.n_name[8]=c;
+	sym->n_value=get_sym_value(st1+sym->n.n.n_offset);
 
     }
 
@@ -391,13 +389,11 @@ fasload(object faslfile) {
   struct reloc *rel,*rele;
   object memory, data;
   FILE *fp;
-  char filename[MAXPATHLEN],*st1,*ste;
+  char *st1,*ste;
   int i;
   ul init_address=0;
   void *st,*est;
 
-  coerce_to_filename(faslfile, filename);
-  faslfile = open_stream(faslfile, smm_input, Cnil, sKerror);
   fp = faslfile->sm.sm_fp;
 
   massert(st=get_mmap(fp,&est));
@@ -427,7 +423,6 @@ fasload(object faslfile) {
   data = read_fasl_vector(faslfile);
 
   massert(!un_mmap(st,est));
-  close_stream(faslfile);
 
 #ifdef CLEAR_CACHE
   CLEAR_CACHE;
--- gcl-2.6.12.orig/o/sfaslelf.c
+++ gcl-2.6.12/o/sfaslelf.c
@@ -542,15 +542,13 @@ int
 fasload(object faslfile) {
 
   FILE *fp;
-  char filename[256],*sn,*st1,*dst1;
+  char *sn,*st1,*dst1;
   ul init_address=0,end,gs=0,*got=&gs,*gote=got+1;
   object memory,data;
   Shdr *sec1,*sece;
   Sym *sym1,*syme,*dsym1,*dsyme;
   void *v1,*ve;
 
-  coerce_to_filename(faslfile, filename);
-  faslfile = open_stream(faslfile, smm_input, Cnil, sKerror);
   fp = faslfile->sm.sm_fp;
   
   massert(v1=get_mmap(fp,&ve));
@@ -573,7 +571,6 @@ fasload(object faslfile) {
   data=feof(fp) ? 0 : read_fasl_vector(faslfile);
   
   massert(!un_mmap(v1,ve));
-  close_stream(faslfile);
   
   massert(!clear_protect_memory(memory));
 
--- gcl-2.6.12.orig/o/sfaslmacho.c
+++ gcl-2.6.12/o/sfaslmacho.c
@@ -524,7 +524,6 @@ fasload(object faslfile) {
 
   FILE *fp;
   object data;
-  char filename[256];
   ul init_address=-1;
   object memory;
   void *v1,*ve,*p;
@@ -533,8 +532,6 @@ fasload(object faslfile) {
   char *st1=NULL,*ste=NULL;
   ul gs,*got=&gs,*gote,*io1=NULL,rls,start;
 
-  coerce_to_filename(faslfile, filename);
-  faslfile = open_stream(faslfile, smm_input, Cnil, sKerror);
   fp = faslfile->sm.sm_fp;
 
   massert(v1=get_mmap(fp,&ve));
@@ -563,7 +560,6 @@ fasload(object faslfile) {
 #endif
   
   massert(!un_mmap(v1,ve));
-  close_stream(faslfile);
   
   init_address-=(ul)memory->cfd.cfd_start;
   call_init(init_address,memory,data,0);
--- gcl-2.6.12.orig/o/sgbc.c
+++ gcl-2.6.12/o/sgbc.c
@@ -717,7 +717,7 @@ sgc_start(void) {
       void *p=NULL,*pe;
       struct pageinfo *pi;
       ufixnum i;
-      
+
       old_cb_pointer=cb_pointer;
       reset_contblock_freelist();
 
@@ -774,6 +774,8 @@ sgc_start(void) {
       object v=sSAwritableA->s.s_dbind;
       for (i=page(v->v.v_self);i<=page(v->v.v_self+CEI(v->bv.bv_offset+v->v.v_dim-1,8*sizeof(fixnum))/(8*sizeof(fixnum)));i++)
 	SET_WRITABLE(i);
+      SET_WRITABLE(page(v));
+      SET_WRITABLE(page(sSAwritableA));
     }
 
     tm_of(t_relocatable)->tm_alt_npage=0;
@@ -787,7 +789,7 @@ sgc_start(void) {
      Turn  memory protection on for the pages which are writable.
   */
   sgc_enabled=1;
-  if (memory_protect(1)) 
+  if (memory_protect(1))
     sgc_quit();
   if (sSAnotify_gbcA->s.s_dbind != Cnil)
     emsg("[SGC on]");
@@ -897,7 +899,7 @@ sgc_quit(void) {
       for (p=pagetochar(page(v)),j=tm->tm_nppage;j>0;--j,p+=tm->tm_size)
   	((object) p)->d.s=SGC_NORMAL;
 #endif
-  
+
   for (i=0;i<contblock_array->v.v_fillp &&(v=(void *)contblock_array->v.v_self[i]);i++)
     if (v->sgc_flags&SGC_PAGE_FLAG) 
       bzero(CB_SGCF_START(v),CB_DATA_START(v)-CB_SGCF_START(v));
@@ -931,7 +933,7 @@ memprotect_handler(int sig, long code, v
 #endif 
   if (faddr >= (void *)core_end || faddr < data_start) {
     static void *old_faddr;
-    if (old_faddr==faddr) 
+    if (old_faddr==faddr)
       if (fault_count++ > 300) error("fault count too high");
     old_faddr=faddr;
     INSTALL_MPROTECT_HANDLER;
@@ -1017,7 +1019,7 @@ memory_protect(int on) {
 
     if (writable==WRITABLE_PAGE_P(i) && i<end) continue;
 
-    if (sgc_mprotect(beg,i-beg,writable)) 
+    if (sgc_mprotect(beg,i-beg,writable))
       return -1;
     writable=1-writable;
     beg=i;
--- gcl-2.6.12.orig/o/toplevel.c
+++ gcl-2.6.12/o/toplevel.c
@@ -173,7 +173,7 @@ FFN(Flocally)(object body)
 	object *oldlex = lex_env;
 
 	lex_copy();
-	body = find_special(body, NULL, NULL);
+	body = find_special(body, NULL, NULL,NULL);
 	vs_push(body);
 	Fprogn(body);
 	lex_env = oldlex;
--- gcl-2.6.12.orig/o/typespec.c
+++ gcl-2.6.12/o/typespec.c
@@ -231,114 +231,71 @@ DEF_ORDINARY("SIGNED-SHORT",sSsigned_sho
 DEF_ORDINARY("UNSIGNED-SHORT",sSunsigned_short,SI,"");
 DEF_ORDINARY("*",sLA,LISP,"");
 DEF_ORDINARY("PLUSP",sLplusp,LISP,"");
-DEF_ORDINARY("DIVISION-BY-ZERO",sLdivision_by_zero,LISP,"");
-DEF_ORDINARY("FLOATING-POINT-INEXACT",sLfloating_point_inexact,LISP,"");
-DEF_ORDINARY("FLOATING-POINT-INVALID-OPERATION",sLfloating_point_invalid_operation,LISP,"");
-DEF_ORDINARY("FLOATING-POINT-OVERFLOW",sLfloating_point_overflow,LISP,"");
-DEF_ORDINARY("FLOATING-POINT-UNDERFLOW",sLfloating_point_underflow,LISP,"");
-DEF_ORDINARY("PROGRAM-ERROR",sLprogram_error,LISP,"");
-DEF_ORDINARY("UNDEFINED-FUNCTION",sLundefined_function,LISP,"");
-DEF_ORDINARY("UNBOUND-VARIABLE",sLunbound_variable,LISP,"");
-DEF_ORDINARY("PACKAGE-ERROR",sLpackage_error,LISP,"");
 
 DEF_ORDINARY("METHOD-COMBINATION",sLmethod_combination,LISP,"");
-DEF_ORDINARY("ARITHMETIC-ERROR",sLarithmetic_error,LISP,"");
 DEF_ORDINARY("BASE-CHAR",sLbase_char,LISP,"");
 DEF_ORDINARY("BASE-STRING",sLbase_string,LISP,"");
 DEF_ORDINARY("BROADCAST-STREAM",sLbroadcast_stream,LISP,"");
 DEF_ORDINARY("BUILT-IN-CLASS",sLbuilt_in_class,LISP,"");
-DEF_ORDINARY("CELL-ERROR",sLcell_error,LISP,"");
 DEF_ORDINARY("CLASS",sLclass,LISP,"");
 DEF_ORDINARY("CONCATENATED-STREAM",sLconcatenated_stream,LISP,"");
-DEF_ORDINARY("CONDITION",sLcondition,LISP,"");
-DEF_ORDINARY("CONTROL-ERROR",sLcontrol_error,LISP,"");
 DEF_ORDINARY("ECHO-STREAM",sLecho_stream,LISP,"");
-DEF_ORDINARY("END-OF-FILE",sLend_of_file,LISP,"");
-DEF_ORDINARY("ERROR",sLerror,LISP,"");
 DEF_ORDINARY("EXTENDED-CHAR",sLextended_char,LISP,"");
-DEF_ORDINARY("FILE-ERROR",sLfile_error,LISP,"");
 DEF_ORDINARY("FILE-STREAM",sLfile_stream,LISP,"");
 DEF_ORDINARY("GENERIC-FUNCTION",sLgeneric_function,LISP,"");
 DEF_ORDINARY("LOGICAL-PATHNAME",sLlogical_pathname,LISP,"");
 DEF_ORDINARY("METHOD",sLmethod,LISP,"");
 /* FIXME -- need this for types in predlib.lsp, why can't we use the keyword sKpackage_error ? */
-DEF_ORDINARY("PARSE-ERROR",sLparse_error,LISP,"");
-DEF_ORDINARY("PRINT-NOT-READABLE",sLprint_not_readable,LISP,"");
-DEF_ORDINARY("READER-ERROR",sLreader_error,LISP,"");
-DEF_ORDINARY("SERIOUS-CONDITION",sLserious_condition,LISP,"");
 DEF_ORDINARY("SIMPLE-BASE-STRING",sLsimple_base_string,LISP,"");
-DEF_ORDINARY("SIMPLE-CONDITION",sLsimple_condition,LISP,"");
-DEF_ORDINARY("SIMPLE-TYPE-ERROR",sLsimple_type_error,LISP,"");
-DEF_ORDINARY("SIMPLE-WARNING",sLsimple_warning,LISP,"");
 DEF_ORDINARY("STANDARD-CLASS",sLstandard_class,LISP,"");
 DEF_ORDINARY("STANDARD-GENERIC-FUNCTION",sLstandard_generic_function,LISP,"");
 DEF_ORDINARY("STANDARD-METHOD",sLstandard_method,LISP,"");
 DEF_ORDINARY("STANDARD-OBJECT",sLstandard_object,LISP,"");
-DEF_ORDINARY("STORAGE-CONDITION",sLstorage_condition,LISP,"");
-DEF_ORDINARY("STREAM-ERROR",sLstream_error,LISP,"");
 DEF_ORDINARY("STRING-STREAM",sLstring_stream,LISP,"");
 DEF_ORDINARY("STRUCTURE-CLASS",sLstructure_class,LISP,"");
 DEF_ORDINARY("STRUCTURE-OBJECT",sLstructure_object,LISP,"");
-DEF_ORDINARY("STYLE-WARNING",sLstyle_warning,LISP,"");
 DEF_ORDINARY("SYNONYM-STREAM",sLsynonym_stream,LISP,"");
 DEF_ORDINARY("TWO-WAY-STREAM",sLtwo_way_stream,LISP,"");
-DEF_ORDINARY("TYPE-ERROR",sLtype_error,LISP,"");
-DEF_ORDINARY("UNBOUND-SLOT",sLunbound_slot,LISP,"");
-DEF_ORDINARY("WARNING",sLwarning,LISP,"");
 
 DEFCONST("CHAR-SIZE",sSchar_size,SI,small_fixnum(CHAR_SIZE),"Size in bits of a character");
 DEFCONST("SHORT-SIZE",sSshort_size,SI,small_fixnum(CHAR_SIZE*sizeof(short)),"Size in bits of a short integer");
 
 void     
-gcl_init_typespec(void)
-{
+gcl_init_typespec(void) {
 }
 
 void
-gcl_init_typespec_function(void)
-{
-	TSor_symbol_string
-	= make_cons(sLor, make_cons(sLsymbol, make_cons(sLstring, Cnil)));
-	enter_mark_origin(&TSor_symbol_string);
-	TSor_string_symbol
-	= make_cons(sLor, make_cons(sLstring, make_cons(sLsymbol, Cnil)));
-	enter_mark_origin(&TSor_string_symbol);
-	TSor_symbol_string_package
-	= make_cons(sLor,
-		    make_cons(sLsymbol,
-			      make_cons(sLstring,
-					make_cons(sLpackage, Cnil))));
-	enter_mark_origin(&TSor_symbol_string_package);
-
-	TSnon_negative_integer
-	= make_cons(sLinteger,
-		    make_cons(make_fixnum(0), make_cons(sLA, Cnil)));
-	enter_mark_origin(&TSnon_negative_integer);
-	TSpositive_number = make_cons(sLsatisfies, make_cons(sLplusp, Cnil));
-	enter_mark_origin(&TSpositive_number);
-	TSor_integer_float
-	= make_cons(sLor, make_cons(sLinteger, make_cons(sLfloat, Cnil)));
-	enter_mark_origin(&TSor_integer_float);
-	TSor_rational_float
-	= make_cons(sLor, make_cons(sLrational, make_cons(sLfloat, Cnil)));
-	enter_mark_origin(&TSor_rational_float);
+gcl_init_typespec_function(void) {
+
+  TSor_symbol_string=make_cons(sLor, make_cons(sLsymbol, make_cons(sLstring, Cnil)));
+  enter_mark_origin(&TSor_symbol_string);
+
+  TSor_string_symbol=make_cons(sLor, make_cons(sLstring, make_cons(sLsymbol, Cnil)));
+  enter_mark_origin(&TSor_string_symbol);
+
+  TSor_symbol_string_package=make_cons(sLor,make_cons(sLsymbol,make_cons(sLstring,make_cons(sLpackage, Cnil))));
+  enter_mark_origin(&TSor_symbol_string_package);
+
+  TSnon_negative_integer= make_cons(sLinteger,make_cons(make_fixnum(0), make_cons(sLA, Cnil)));
+  enter_mark_origin(&TSnon_negative_integer);
+
+  TSpositive_number=make_cons(sLsatisfies, make_cons(sLplusp, Cnil));
+  enter_mark_origin(&TSpositive_number);
+
+  TSor_integer_float=make_cons(sLor, make_cons(sLinteger, make_cons(sLfloat, Cnil)));
+  enter_mark_origin(&TSor_integer_float);
+
+  TSor_rational_float=make_cons(sLor, make_cons(sLrational, make_cons(sLfloat, Cnil)));
+  enter_mark_origin(&TSor_rational_float);
+
 #ifdef UNIX
-	TSor_pathname_string_symbol
-	= make_cons(sLor,
-		    make_cons(sLpathname,
-			      make_cons(sLstring,
-					make_cons(sLsymbol,
-						  Cnil))));
-	enter_mark_origin(&TSor_pathname_string_symbol);
+  TSor_pathname_string_symbol=make_cons(sLor,make_cons(sLpathname,make_cons(sLstring,make_cons(sLsymbol,Cnil))));
+  enter_mark_origin(&TSor_pathname_string_symbol);
 #endif
-	TSor_pathname_string_symbol_stream
-	= make_cons(sLor,
-		    make_cons(sLpathname,
-			      make_cons(sLstring,
-					make_cons(sLsymbol,
-						  make_cons(sLstream,
-							    Cnil)))));
-	enter_mark_origin(&TSor_pathname_string_symbol_stream);
 
-	make_function("TYPE-OF", Ltype_of);
+  TSor_pathname_string_symbol_stream=make_cons(sLor,make_cons(sLpathname,make_cons(sLstring,make_cons(sLsymbol,make_cons(sLstream,Cnil)))));
+  enter_mark_origin(&TSor_pathname_string_symbol_stream);
+
+  make_function("TYPE-OF", Ltype_of);
+
 }				
--- gcl-2.6.12.orig/o/unexec-19.29.c
+++ gcl-2.6.12/o/unexec-19.29.c
@@ -936,7 +936,7 @@ copy_text_and_data (int new, int a_out)
    
 
     /* The use of _execname is incompatible with RISCiX 1.1 */
-    sprintf (command, "nm %s | fgrep mcount", _execname);
+    sprintf (command, "nm '%s' | fgrep mcount", _execname);
 
     if ( (pfile = popen(command, "r")) == NULL)
     {
--- gcl-2.6.12.orig/o/unexec.c
+++ gcl-2.6.12/o/unexec.c
@@ -937,7 +937,7 @@ copy_text_and_data (int new, int a_out)
    
 
     /* The use of _execname is incompatible with RISCiX 1.1 */
-    sprintf (command, "nm %s | fgrep mcount", _execname);
+    sprintf (command, "nm '%s' | fgrep mcount", _execname);
 
     if ( (pfile = popen(command, "r")) == NULL)
     {
--- gcl-2.6.12.orig/o/unixfasl.c
+++ gcl-2.6.12/o/unixfasl.c
@@ -279,9 +279,7 @@ AGAIN:
 #define FASLINK
 #ifndef PRIVATE_FASLINK
 
-static int
-faslink(object faslfile, object ldargstring)
-{
+DEFUN_NEW("FASLINK-INT",object,fSfaslink_int,SI,2,2,NONE,II,OO,OO,OO,(object faslfile, object ldargstring),"") {
 #if defined(__ELF__) || defined(DARWIN)
   FEerror("faslink() not supported for ELF or DARWIN yet",0);
   return 0;
@@ -381,36 +379,10 @@ SEEK_TO_END_OFILE(faslfile->sm.sm_fp);
 
 #endif
 
-static void
-FFN(siLfaslink)(void)
-{
-	bds_ptr old_bds_top;
-	int i;
-	object package;
-
-	check_arg(2);
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	check_type_string(&vs_base[1]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-	vs_base[0]->pn.pn_type = FASL_string;
-	vs_base[0] = namestring(vs_base[0]);
-	package = symbol_value(sLApackageA);
-	old_bds_top = bds_top;
-	bds_bind(sLApackageA, package);
-	i = faslink(vs_base[0], vs_base[1]);
-	bds_unwind(old_bds_top);
-	vs_top = vs_base;
-	vs_push(make_fixnum(i));
-}
-
 #endif
 #endif/*  svr4 */
 #endif /* UNIXFASL */
 
 void
-gcl_init_unixfasl(void)
-{
-#ifdef FASLINK
-	make_si_function("FASLINK", siLfaslink);
-#endif
+gcl_init_unixfasl(void) {
 }
--- gcl-2.6.12.orig/o/unixfsys.c
+++ gcl-2.6.12/o/unixfsys.c
@@ -44,10 +44,6 @@ Foundation, 675 Mass Ave, Cambridge, MA
 #define HAVE_RENAME
 #endif
 
-void Ldirectory(void);
-
-
-
 #ifdef NEED_GETWD
 #include <sys/dir.h>
 
@@ -168,17 +164,41 @@ getwd(char *buffer) {
       b_[_c+_d]=0;\
       })
 
+static object
+get_string(object x) {
+  switch(type_of(x)) {
+  case t_symbol:
+  case t_string:
+    return x;
+  case t_pathname:
+    return x->pn.pn_namestring;
+  case t_stream:
+    switch(x->sm.sm_mode) {
+    case smm_input:
+    case smm_output:
+    case smm_probe:
+    case smm_io:
+      return get_string(x->sm.sm_object1);
+    case smm_file_synonym:
+    case smm_synonym:
+      return get_string(x->sm.sm_object0->s.s_dbind);
+    }
+  }
+  return Cnil;
+}
+
+
 void
 coerce_to_filename(object pathname,char *p) {
 
-  object namestring=coerce_to_namestring(pathname);
+  object namestring=get_string(pathname);
   unsigned e=namestring->st.st_fillp;
-  char *q=namestring->st.st_self,*qe=q+e;;
+  char *q=namestring->st.st_self,*qe=q+e;
 
-  if (pathname==Cnil)
+  if (pathname==Cnil||namestring==Cnil)
     FEerror ( "NIL argument.", 1, pathname ); 
   
-  if (*q=='~') {
+  if (*q=='~' && e) {
 
     unsigned m=0;
     char *s=++q,*c;
@@ -224,134 +244,6 @@ coerce_to_filename(object pathname,char
     
 }
 
-object
-truename(object pathname)
-{
-	register char *p, *q;
-	char filename[MAXPATHLEN];
-	char truefilename[MAXPATHLEN];
-	char current_directory[MAXPATHLEN];
-	char directory[MAXPATHLEN];
-#ifdef __MINGW32__ 
-        DWORD current_directory_length =
-            GetCurrentDirectory ( MAXPATHLEN, current_directory ); 
-        if ( MAXPATHLEN < current_directory_length ) { 
-           FEerror ( "truename got a current directory name larger than MAXPATHLEN", 1, "" ); 
-        } 
-        if ( 0 == current_directory_length ) { 
-           FEerror ( "truename could not determine the current directory.", 1, "" ); 
-        } 
-#else 
-        massert(current_directory==getcwd(current_directory,sizeof(current_directory))); 
-#endif 
-    
-	coerce_to_filename(pathname, filename);
-	
-#ifdef S_IFLNK
- {
-
-   struct stat filestatus;
-   int islinkcount=8;
-
-   if (lstat(filename, &filestatus) >= 0)
-
-	while (((filestatus.st_mode&S_IFMT) == S_IFLNK) && (--islinkcount>0)) {
-
-	  char newname[MAXPATHLEN];
-	  int newlen;
-
-	  newlen=readlink(filename,newname,MAXPATHLEN-1);
-	  if (newlen < 0)
-	    return((FEerror("Symlink broken at ~S.",1,pathname),Cnil));
-
-	  for (p = filename, q = 0;  *p != '\0';  p++)
-	    if (*p == '/') q = p;
-	  if (q == 0 || *newname == '/')
-	    q = filename;
-	  else
-	    q++;
-
-	  memcpy(q,newname,newlen);
-	  q[newlen]=0;
-	  if (lstat(filename, &filestatus) < 0) 
-	    islinkcount=0; /* It would be ANSI to do the following :
-			      return(file_error("Symlink broken at ~S.",pathname));
-			      but this would break DIRECTORY if a file points to nowhere */
-	}
- }
-#endif
-
-	for (p = filename, q = 0;  *p != '\0';  p++)
-		if (*p == '/')
-			q = p;
-	if (q == filename) {
-		q++;
-		p = "/";
-	} else if (q == 0) {
-		q = filename;
-		p = current_directory;
-	} else
-#ifdef __MINGW32__
-	   if ( ( q > filename ) && ( q[-1] == ':' ) ) {
-	     int current = (q++, q[0]);
-	     q[0]=0;
-	     if (chdir(filename) < 0)
-	       FEerror("Cannot get the truename of ~S.", 1, pathname);
-             current_directory_length =
-               GetCurrentDirectory ( MAXPATHLEN, directory );
-             if ( MAXPATHLEN < current_directory_length ) { 
-               FEerror ( "truename got a current directory name larger than MAXPATHLEN", 1, "" ); 
-             } 
-             if ( 0 == current_directory_length ) { 
-               FEerror ( "truename could not determine the current directory.", 1, "" ); 
-             } 
-             p = directory; 
-             if ( p[1]==':' && ( p[2]=='\\' || p[2]=='/' ) && p[3]==0 ) p[2]=0; 
-	     q[0]=current;
-          }
-	  else
-#endif	
-	  {
-		*q++ = '\0';
-		if (chdir(filename) < 0)
-		    FEerror("Cannot get the truename of ~S.", 1, pathname);
-#ifdef __MINGW32__ 
-                current_directory_length = GetCurrentDirectory ( MAXPATHLEN, directory ); 
-                if ( MAXPATHLEN < current_directory_length ) { 
-                    FEerror ( "truename got a current directory name larger than MAXPATHLEN", 1, "" ); 
-                } 
-                if ( 0 == current_directory_length ) { 
-                    FEerror ( "truename could not determine the current directory.", 1, "" ); 
-                } 
-                p = directory; 
-#else 
-		p = getcwd(directory,sizeof(directory));
-#endif                
-	}
-	if (p[0] == '/' && p[1] == '\0') {
-		if (strcmp(q, "..") == 0)
-			strcpy(truefilename, "/.");
-		else
-			sprintf(truefilename, "/%s", q);
-	} else if (strcmp(q, ".") == 0)
-		strcpy(truefilename, p);
-	else if (strcmp(q, "..") == 0) {
-		for (q = p + strlen(p);  *--q != '/';) ;
-		if (p == q)
-			strcpy(truefilename, "/.");
-		else {
-			*q = '\0';
-			strcpy(truefilename, p);
-			*q = '/';
-		}
-	} else
-		sprintf(truefilename, "%s/%s", p, q);
-	massert(!chdir(current_directory));
-	vs_push(make_simple_string(truefilename));
-	pathname = coerce_to_pathname(vs_head);
-	vs_popp;
-	return(pathname);
-}
 object sSAallow_gzipped_fileA;
 
 bool
@@ -429,41 +321,6 @@ file_len(FILE *fp)
 	else return 0;
 }
 
-LFD(Ltruename)(void)
-{
-	check_arg(1);
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	vs_base[0] = truename(vs_base[0]);
-}
-
-LFD(Lrename_file)(void)
-{
-	char filename[MAXPATHLEN];
-	char newfilename[MAXPATHLEN];
-
-	check_arg(2);
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	check_type_or_Pathname_string_symbol(&vs_base[1]);
-	coerce_to_filename(vs_base[0], filename);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-	vs_base[1] = coerce_to_pathname(vs_base[1]);
-	vs_base[1] = merge_pathnames(vs_base[1], vs_base[0], Cnil);
-	coerce_to_filename(vs_base[1], newfilename);
-#ifdef HAVE_RENAME
-	if (rename(filename, newfilename) < 0)
-		FEerror("Cannot rename the file ~S to ~S.",
-			2, vs_base[0], vs_base[1]);
-#else
-	sprintf(command, "mv %s %s", filename, newfilename);
-	msystem(command);
-#endif
-	vs_push(vs_base[1]);
-	vs_push(truename(vs_base[0]));
-	vs_push(truename(vs_base[1]));
-	vs_base += 2;
-}
-
-
 DEF_ORDINARY("DIRECTORY",sKdirectory,KEYWORD,"");
 DEF_ORDINARY("LINK",sKlink,KEYWORD,"");
 DEF_ORDINARY("FILE",sKfile,KEYWORD,"");
@@ -500,33 +357,28 @@ int gcl_putc(int i,void *v) {return putc
 
 
 
-DEFUN_NEW("STAT",object,fSstat,SI,1,1,NONE,OO,OO,OO,OO,(object path),"") {
+DEFUNM_NEW("STAT",object,fSstat,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
 
-  char filename[4096];
   struct stat ss;
-  
 
-  bzero(filename,sizeof(filename));
-  coerce_to_filename(path,filename);
+  check_type_string(&x);
+  coerce_to_filename(x,FN1);
+
 #ifdef __MINGW32__
   {
-    char *p=filename+strlen(filename)-1;
-    for (;p>filename && *p=='/';p--)
+    char *p=FN1+strlen(FN1)-1;
+    for (;p>FN1 && *p=='/';p--)
       *p=0;
   }
 #endif
-  if (lstat(filename,&ss))
+  if (lstat(FN1,&ss))
     RETURN1(Cnil);
-  else {/* ctime_r insufficiently portable */
-    /* int j;
-       ctime_r(&ss.st_ctime,filename);
-       j=strlen(filename);
-       if (isspace(filename[j-1]))
-       filename[j-1]=0;*/
-    RETURN1(list(3,S_ISDIR(ss.st_mode) ? sKdirectory : 
-		 (S_ISLNK(ss.st_mode) ? sKlink : sKfile),
-		 make_fixnum(ss.st_size),make_fixnum(ss.st_ctime)));
-  }
+  else
+    RETURN4(S_ISDIR(ss.st_mode) ? sKdirectory :
+	    (S_ISLNK(ss.st_mode) ? sKlink : sKfile),
+	    make_fixnum(ss.st_size),
+	    make_fixnum(ss.st_ctime),
+	    make_fixnum(ss.st_uid));
 }
 
 DEFUN_NEW("SETENV",object,fSsetenv,SI,2,2,NONE,OO,OO,OO,OO,(object variable,object value),"Set environment VARIABLE to VALUE")
@@ -551,266 +403,6 @@ DEFUN_NEW("SETENV",object,fSsetenv,SI,2,
   RETURN1((res == 0 ? Ct : Cnil ));
 }
 
-DEFUNO_NEW("DELETE-FILE",object,fLdelete_file,LISP
-   ,1,1,NONE,OO,OO,OO,OO,void,Ldelete_file,(object path),"")
-
-{
-	char filename[MAXPATHLEN];
-
-	/* 1 args */
-	check_type_or_pathname_string_symbol_stream(&path);
-	coerce_to_filename(path, filename);
-	if (unlink(filename) < 0 && rmdir(filename) < 0)
-		FEerror("Cannot delete the file ~S: ~s.", 2, path, make_simple_string(strerror(errno)));
-	path = Ct;
-	RETURN1(path);
-}
-#ifdef STATIC_FUNCTION_POINTERS
-object
-fLdelete_file(object path) {
-  return FFN(fLdelete_file)(path);
-}
-#endif
-
-LFD(Lprobe_file)(void)
-{
-	check_arg(1);
-
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	if (file_exists(vs_base[0]))
-		vs_base[0] = truename(vs_base[0]);
-	else
-		vs_base[0] = Cnil;
-}
-
-LFD(Lfile_write_date)(void)
-{
-	char filename[MAXPATHLEN];
-	struct stat filestatus;
-
-	check_arg(1);
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	coerce_to_filename(vs_base[0], filename);
-	if (stat(filename, &filestatus) < 0 || S_ISDIR(filestatus.st_mode))
-	  { vs_base[0] = Cnil; return;}
-	vs_base[0] = unix_time_to_universal_time(filestatus.st_mtime);
-}
-
-LFD(Lfile_author)(void)
-{
-#if !defined(NO_PWD_H) && !defined(STATIC_LINKING)
-	char filename[MAXPATHLEN];
-	struct stat filestatus;
-	struct passwd *pwent;
-#ifndef __STDC__
-	extern struct passwd *getpwuid();
-#endif
-
-	check_arg(1);
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	coerce_to_filename(vs_base[0], filename);
-	if (stat(filename, &filestatus) < 0 || S_ISDIR(filestatus.st_mode))
-	  { vs_base[0] = Cnil; return;}
-	pwent = getpwuid(filestatus.st_uid);
-	vs_base[0] = make_simple_string(pwent->pw_name);
-#else
-	vs_base[0] = Cnil; return;
-#endif	
-	
-}
-
-static void
-FFN(Luser_homedir_pathname)(void)
-{
-
-  char filename[MAXPATHLEN];
-
-  coerce_to_filename(make_simple_string("~/"),filename);
-  vs_base[0]=coerce_to_pathname(make_simple_string(filename));
-  vs_top = vs_base+1; 
-  
-}
-
-
-#ifdef BSD
-LFD(Ldirectory)(void)
-{
-	char filename[MAXPATHLEN];
-	char command[MAXPATHLEN * 2];
-	FILE *fp;
-	register int i, c;
-	object *top = vs_top;
-	char iobuffer[BUFSIZ];
-	extern FILE *popen(const char *, const char *);
-
-	check_arg(1);
-
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-	if (vs_base[0]->pn.pn_name==Cnil && vs_base[0]->pn.pn_type==Cnil) {
-		coerce_to_filename(vs_base[0], filename);
-		strcat(filename, "*");
-	} else if (vs_base[0]->pn.pn_name==Cnil) {
-		vs_base[0]->pn.pn_name = sKwild;
-		coerce_to_filename(vs_base[0], filename);
-		vs_base[0]->pn.pn_name = Cnil;
-	} else if (vs_base[0]->pn.pn_type==Cnil) {
-		coerce_to_filename(vs_base[0], filename);
-		strcat(filename, "*");
-	} else
-		coerce_to_filename(vs_base[0], filename);
-	sprintf(command, "ls -d %s 2> /dev/null", filename);
-	fp = popen(command, "r");
-	setbuf(fp, iobuffer);
-	for (;;) {
-		for (i = 0;  (c = getc(fp));  i++)
-			if (c <= 0)
-				goto L;
-			else if (c == '\n')
-				break;
-			else
-				filename[i] = c;
-		filename[i] = '\0';
-		vs_push(make_simple_string(filename));
-		vs_head = truename(vs_head);
-	}
-L:
-	pclose(fp);
-	vs_push(Cnil);
-	while (vs_top > top + 1)
-		stack_cons();
-	vs_base = top;
-}
-#endif
-
-
-#ifdef ATT
-LFD(Ldirectory)()
-{
-	object name, type;
-	char filename[MAXPATHLEN];
-	FILE *fp;
-	object *top = vs_top;
-	char iobuffer[BUFSIZ];
-	struct direct dir;
-	int i;
-
-	check_arg(1);
-
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-	vs_push(vs_base[0]->pn.pn_name);
-	vs_push(vs_base[0]->pn.pn_type);
-	vs_base[0]->pn.pn_name = Cnil;
-	vs_base[0]->pn.pn_type = Cnil;
-	coerce_to_filename(vs_base[0], filename);
-	type = vs_base[0]->pn.pn_type = vs_pop;
-	name = vs_base[0]->pn.pn_name = vs_pop;
-	i = strlen(filename);
-	if (i > 1 && filename[i-1] == '/')
-		filename[i-1] = '\0';
-	if (i == 0)
-		strcpy(filename, ".");
-	fp = fopen(filename, "r");
-	if (fp == NULL) {
-		vs_push(make_simple_string(filename));
-		FEerror("Can't open the directory ~S.", 1, vs_head);
-	}
-	setbuf(fp, iobuffer);
-	fread(&dir, sizeof(struct direct), 1, fp);
-	fread(&dir, sizeof(struct direct), 1, fp);
-	filename[DIRSIZ] = '\0';
-	for (;;) {
-		if (fread(&dir, sizeof(struct direct), 1, fp) <=0)
-			break;
-		if (dir.d_ino == 0)
-			continue;
-		strncpy(filename, dir.d_name, DIRSIZ);
-		vs_push(make_simple_string(filename));
-		vs_head = coerce_to_pathname(vs_head);
-		if ((name == Cnil || name == sKwild ||
-		     equal(name, vs_head->pn.pn_name)) &&
-		    (type == Cnil || type == sKwild ||
-		     equal(type, vs_head->pn.pn_type))) {
-			vs_head->pn.pn_directory
-			= vs_base[0]->pn.pn_directory;
-			vs_head = truename(vs_head);
-		} else
-			vs_pop;
-	}
-	fclose(fp);
-	vs_push(Cnil);
-	while (vs_top > top + 1)
-		stack_cons();
-	vs_base = top;
-}
-#endif
-
-
-#ifdef E15
-#include <sys/dir.h>
-
-LFD(Ldirectory)()
-{
-	object name, type;
-	char filename[MAXPATHLEN];
-	FILE *fp;
-	object *top = vs_top;
-	char iobuffer[BUFSIZ];
-	struct direct dir;
-	int i;
-
-	check_arg(1);
-
-	check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-	vs_base[0] = coerce_to_pathname(vs_base[0]);
-	vs_push(vs_base[0]->pn.pn_name);
-	vs_push(vs_base[0]->pn.pn_type);
-	vs_base[0]->pn.pn_name = Cnil;
-	vs_base[0]->pn.pn_type = Cnil;
-	coerce_to_filename(vs_base[0], filename);
-	type = vs_base[0]->pn.pn_type = vs_pop;
-	name = vs_base[0]->pn.pn_name = vs_pop;
-	i = strlen(filename);
-	if (i > 1 && filename[i-1] == '/')
-		filename[i-1] = '\0';
-	if (i == 0)
-		strcpy(filename, ".");
-	fp = fopen(filename, "r");
-	if (fp == NULL) {
-		vs_push(make_simple_string(filename));
-		FEerror("Can't open the directory ~S.", 1, vs_head);
-	}
-	setbuf(fp, iobuffer);
-	fread(&dir, sizeof(struct direct), 1, fp);
-	fread(&dir, sizeof(struct direct), 1, fp);
-	filename[DIRSIZ] = '\0';
-	for (;;) {
-		if (fread(&dir, sizeof(struct direct), 1, fp) <=0)
-			break;
-		if (dir.d_ino == 0)
-			continue;
-		strncpy(filename, dir.d_name, DIRSIZ);
-		vs_push(make_simple_string(filename));
-		vs_head = coerce_to_pathname(vs_head);
-		if ((name == Cnil || name == sKwild ||
-		     equal(name, vs_head->pn.pn_name)) &&
-		    (type == Cnil || type == sKwild ||
-		     equal(type, vs_head->pn.pn_type))) {
-			vs_head->pn.pn_directory
-			= vs_base[0]->pn.pn_directory;
-			vs_head = truename(vs_head);
-		} else
-			vs_pop;
-	}
-	fclose(fp);
-	vs_push(Cnil);
-	while (vs_top > top + 1)
-		stack_cons();
-	vs_base = top;
-}
-#endif
-
 #include <sys/types.h>
 #include <dirent.h>
 
@@ -840,17 +432,31 @@ DEFUN_NEW("D-TYPE-LIST",object,fSd_type_
 }
 #endif
 
-DEFUN_NEW("READDIR",object,fSreaddir,SI,2,2,NONE,OI,IO,OO,OO,(fixnum x,fixnum y),"") {
+DEFUN_NEW("READDIR",object,fSreaddir,SI,3,3,NONE,OI,IO,OO,OO,(fixnum x,fixnum y,object s),"") {
   struct dirent *e;
   object z;
+  long tl;
+  size_t l;
   if (!x) RETURN1(Cnil);
-  e=readdir((DIR *)x);
-  RETURN1(e ? make_simple_string(e->d_name) : Cnil);
+  tl=telldir((DIR *)x);
 #ifdef HAVE_D_TYPE
   for (;(e=readdir((DIR *)x)) && y!=DT_UNKNOWN && e->d_type!=y;);
 #endif
   if (!e) RETURN1(Cnil);
-  z=make_simple_string(e->d_name);
+  if (s==Cnil)
+    z=make_simple_string(e->d_name);
+  else {
+    check_type_string(&s);
+    l=strlen(e->d_name);
+    if (s->st.st_dim-s->st.st_fillp>=l) {
+      memcpy(s->st.st_self+s->st.st_fillp,e->d_name,l);
+      s->st.st_fillp+=l;
+      z=s;
+    } else {
+      seekdir((DIR *)x,tl);
+      RETURN1(make_fixnum(l));
+    }
+  }
 #ifdef HAVE_D_TYPE
   if (y==DT_UNKNOWN) z=MMcons(z,make_fixnum(e->d_type));
 #endif
@@ -882,7 +488,126 @@ DEFUN_NEW("MKDIR",object,fSmkdir,SI,1,1,
 
 }
 
+DEFUN_NEW("RMDIR",object,fSrmdir,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  check_type_string(&x);
+
+  coerce_to_filename(x,FN1);
+
+  RETURN1(rmdir(FN1) ? Cnil : Ct);
+
+}
+
+
+
+#include <sys/types.h>
+#include <dirent.h>
+#include <fcntl.h>
+#include <unistd.h>
+
+DEFUN_NEW("READLINKAT",object,fSreadlinkat,SI,2,2,NONE,OI,OO,OO,OO,(fixnum d,object s),"") {
+  char *b1,*b2=NULL;
+  ssize_t l,z1,z2;
+  check_type_string(&s);
+  /* l=s->st.st_hasfillp ? s->st.st_fillp : s->st.st_dim; */
+  z1=length(s);
+  massert((b1=alloca(z1+1)));
+  memcpy(b1,s->st.st_self,z1);
+  b1[z1]=0;
+  for (l=z2=0;l>=z2;) {
+    memset(b2,0,z2);
+    z2+=z2+10;
+    massert((b2=alloca(z2)));
+    massert((l=readlinkat(d ? dirfd((DIR *)d) : AT_FDCWD,b1,b2,z2))>=0);
+  }
+  b2[l]=0;
+  s=make_simple_string(b2);
+  memset(b1,0,z1);
+  memset(b2,0,z2);
+  RETURN1(s);
+}
+
+DEFUN_NEW("GETCWD",object,fSgetcwd,SI,0,0,NONE,OO,OO,OO,OO,(void),"") {
+  char *b=NULL;
+  size_t z;
+  object s;
+
+  for (z=0;!(errno=0) && !getcwd(b,z) && errno==ERANGE;b=memset(b,0,z),z+=z+10,({massert((b=alloca(z)));}));
+  massert((b=getcwd(b,z)));
+  s=make_simple_string(b);
+  memset(b,0,z);
+  RETURN1(s);
+
+}
+
+DEFUN_NEW("UID-TO-NAME",object,fSuid_to_name,SI,1,1,NONE,OI,OO,OO,OO,(fixnum uid),"") {
+  struct passwd *pwent,pw;
+  char *b;
+  long r;
+
+  massert((r=sysconf(_SC_GETPW_R_SIZE_MAX))>=0);
+  massert(b=alloca(r));
+
+  massert(!getpwuid_r(uid,&pw,b,r,&pwent));
+
+  RETURN1(make_simple_string(pwent->pw_name));
+
+}
+
+DEFUN_NEW("HOME-NAMESTRING",object,fShome_namestring,SI,1,1,NONE,OO,OO,OO,OO,(object nm),"") {
+
+  struct passwd *pwent,pw;
+  char *b;
+  long r;
+
+  massert((r=sysconf(_SC_GETPW_R_SIZE_MAX))>=0);
+  massert(b=alloca(r));
 
+  if (nm->st.st_fillp==1)
+
+    if ((pw.pw_dir=getenv("HOME")))
+      pwent=&pw;
+    else
+      massert(!getpwuid_r(getuid(),&pw,b,r,&pwent));
+
+  else {
+
+    char *name;
+
+    massert(name=alloca(nm->st.st_fillp));
+    memcpy(name,nm->st.st_self+1,nm->st.st_fillp-1);
+    name[nm->st.st_fillp-1]=0;
+
+    massert(!getpwnam_r(name,&pw,b,r,&pwent));
+
+  }
+
+  massert((b=alloca(strlen(pwent->pw_dir)+2)));
+  memcpy(b,pwent->pw_dir,strlen(pwent->pw_dir));
+  b[strlen(pwent->pw_dir)]='/';
+  b[strlen(pwent->pw_dir)+1]=0;
+  RETURN1(make_simple_string(b));
+
+}
+
+DEFUN_NEW("RENAME",object,fSrename,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") {
+
+  check_type_string(&x);
+  check_type_string(&y);
+
+  coerce_to_filename(x,FN1);
+  coerce_to_filename(y,FN2);
+
+  RETURN1(rename(FN1,FN2) ? Cnil : Ct);
+
+}
+
+DEFUN_NEW("UNLINK",object,fSunlink,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+
+  coerce_to_filename(x,FN1);
+
+  RETURN1(unlink(FN1) ? Cnil : Ct);
+
+}
 
 
 static void
@@ -900,16 +625,8 @@ FFN(siLchdir)(void)
 }
 
 void
-gcl_init_unixfsys(void)
-{
-	make_function("TRUENAME", Ltruename);
-	make_function("RENAME-FILE", Lrename_file);
-	make_function("DELETE-FILE", Ldelete_file);
-	make_function("PROBE-FILE", Lprobe_file);
-	make_function("FILE-WRITE-DATE", Lfile_write_date);
-	make_function("FILE-AUTHOR", Lfile_author);
-	make_function("USER-HOMEDIR-PATHNAME", Luser_homedir_pathname);
-	make_function("DIRECTORY", Ldirectory);
+gcl_init_unixfsys(void) {
+
+  make_si_function("CHDIR", siLchdir);
 
-	make_si_function("CHDIR", siLchdir);
 }
--- gcl-2.6.12.orig/o/usig.c
+++ gcl-2.6.12/o/usig.c
@@ -148,13 +148,15 @@ DEFUN_NEW("FLD",object,fSfld,SI,1,1,NONE
 
 #endif
 
-DEFUN_NEW("*FIXNUM",fixnum,fSAfixnum,SI,1,1,NONE,II,OO,OO,OO,(fixnum addr),"") {
-  RETURN1(*(fixnum *)addr);
+/* For now ignore last three args governing offsets and data modification, just to
+   support fpe sync with master*/
+DEFUN_NEW("*FIXNUM",object,fSAfixnum,SI,4,4,NONE,OI,OO,OO,OO,(fixnum addr,object x,object y,object z),"") {
+  RETURN1((object)*(fixnum *)addr);
 }
-DEFUN_NEW("*FLOAT",object,fSAfloat,SI,1,1,NONE,OI,OO,OO,OO,(fixnum addr),"") {
+DEFUN_NEW("*FLOAT",object,fSAfloat,SI,4,4,NONE,OI,OO,OO,OO,(fixnum addr,object x,object y,object z),"") {
   RETURN1(make_shortfloat(*(float *)addr));
 }
-DEFUN_NEW("*DOUBLE",object,fSAdouble,SI,1,1,NONE,OI,OO,OO,OO,(fixnum addr),"") {
+DEFUN_NEW("*DOUBLE",object,fSAdouble,SI,4,4,NONE,OI,OO,OO,OO,(fixnum addr,object x,object y,object z),"") {
   RETURN1(make_longfloat(*(double *)addr));
 }
 
@@ -264,7 +266,6 @@ sigpipe(void)
 	FEerror("Broken pipe", 0);
 }
 
-
 void
 sigint(void)
 {
@@ -272,8 +273,6 @@ sigint(void)
   terminal_interrupt(1);
 }
 
-
-
 static void
 sigalrm(void)
 {
--- gcl-2.6.12.orig/unixport/sys_ansi_gcl.c
+++ gcl-2.6.12/unixport/sys_ansi_gcl.c
@@ -41,7 +41,6 @@ gcl_init_system(object no_init)
 #ifdef HAVE_JAPI_H
   ar_check_init(gcl_japi,no_init);
 #endif
-  ar_check_init(gcl_iolib,no_init);
   ar_check_init(gcl_listlib,no_init);
   ar_check_init(gcl_mislib,no_init);
   ar_check_init(gcl_numlib,no_init);
@@ -56,9 +55,23 @@ gcl_init_system(object no_init)
   ar_check_init(gcl_defpackage,no_init);
   ar_check_init(gcl_make_defpackage,no_init);
   ar_check_init(gcl_sharp,no_init);
-  ar_check_init(gcl_fpe,no_init);
 
+  ar_check_init(gcl_sharp_uv,no_init);
+  ar_check_init(gcl_namestring,no_init);
+  ar_check_init(gcl_logical_pathname_translations,no_init);
+  ar_check_init(gcl_make_pathname,no_init);
+  ar_check_init(gcl_parse_namestring,no_init);
+  ar_check_init(gcl_translate_pathname,no_init);
+  ar_check_init(gcl_directory,no_init);
+  ar_check_init(gcl_merge_pathnames,no_init);
+  ar_check_init(gcl_truename,no_init);
+  ar_check_init(gcl_rename_file,no_init);
+  ar_check_init(gcl_wild_pathname_p,no_init);
+  ar_check_init(gcl_pathname_match_p,no_init);
 	
+  ar_check_init(gcl_iolib,no_init);
+  ar_check_init(gcl_fpe,no_init);
+
   ar_check_init(gcl_cmpinline,no_init);
   ar_check_init(gcl_cmputil,no_init);
 
@@ -107,6 +120,7 @@ gcl_init_system(object no_init)
   ar_check_init(gcl_index,no_init);
 #endif
   
+  lsp_init("../pcl/package.lisp");
   ar_check_init(gcl_pcl_pkg,no_init);
   ar_check_init(gcl_pcl_walk,no_init);
   ar_check_init(gcl_pcl_iterate,no_init);
@@ -142,6 +156,7 @@ gcl_init_system(object no_init)
   ar_check_init(gcl_pcl_precom1,no_init);
   ar_check_init(gcl_pcl_precom2,no_init);
 
+  lsp_init("../clcs/package.lisp");
   ar_check_init(gcl_clcs_precom,no_init);
   ar_check_init(gcl_clcs_handler,no_init);
   ar_check_init(gcl_clcs_conditions,no_init);
--- gcl-2.6.12.orig/unixport/sys_gcl.c
+++ gcl-2.6.12/unixport/sys_gcl.c
@@ -34,7 +34,6 @@ gcl_init_system(object no_init) {
 #ifdef HAVE_JAPI_H
   ar_check_init(gcl_japi,no_init);
 #endif
-  ar_check_init(gcl_iolib,no_init);
   ar_check_init(gcl_listlib,no_init);
   ar_check_init(gcl_mislib,no_init);
   ar_check_init(gcl_numlib,no_init);
@@ -49,9 +48,23 @@ gcl_init_system(object no_init) {
   ar_check_init(gcl_defpackage,no_init);
   ar_check_init(gcl_make_defpackage,no_init);
   ar_check_init(gcl_sharp,no_init);
-  ar_check_init(gcl_fpe,no_init);
 
+  ar_check_init(gcl_sharp_uv,no_init);
+  ar_check_init(gcl_namestring,no_init);
+  ar_check_init(gcl_logical_pathname_translations,no_init);
+  ar_check_init(gcl_make_pathname,no_init);
+  ar_check_init(gcl_parse_namestring,no_init);
+  ar_check_init(gcl_translate_pathname,no_init);
+  ar_check_init(gcl_directory,no_init);
+  ar_check_init(gcl_merge_pathnames,no_init);
+  ar_check_init(gcl_truename,no_init);
+  ar_check_init(gcl_rename_file,no_init);
+  ar_check_init(gcl_wild_pathname_p,no_init);
+  ar_check_init(gcl_pathname_match_p,no_init);
 	
+  ar_check_init(gcl_iolib,no_init);
+  ar_check_init(gcl_fpe,no_init);
+
   ar_check_init(gcl_cmpinline,no_init);
   ar_check_init(gcl_cmputil,no_init);
 
--- gcl-2.6.12.orig/unixport/sys_init.lsp.in
+++ gcl-2.6.12/unixport/sys_init.lsp.in
@@ -9,9 +9,6 @@
 (in-package :system)
 (use-package :fpe)
 
-#+(or pcl ansi-cl)(load "../pcl/package.lisp")
-#+ansi-cl(load "../clcs/package.lisp")
-
 (init-system) 
 (in-package :si)
 (gbc t)
@@ -20,7 +17,7 @@
   (setq *link-array* (make-array (ash 1 11) :element-type 'character :fill-pointer 0)))
 (use-fast-links t)
 
-(let* ((x (append (pathname-directory *system-directory*) (list :parent)))
+(let* ((x (append (pathname-directory *system-directory*) (list :back)))
        (lsp (append x (list "lsp")))
        (cmpnew (append x (list "cmpnew")))
        (h (append x (list "h")))
@@ -59,6 +56,7 @@
 
 (fmakunbound 'init-cmp-anon)
 (when (fboundp 'user-init) (user-init))
+
 (in-package :compiler)
 (setq *cc* @LI-CC@
       *ld* @LI-LD@
@@ -79,7 +77,9 @@
 #-ansi-cl(do-symbols (s :cltl1-compat) (export s :lisp)))
 
 #+ansi-cl (use-package :pcl :user)
-#+ansi-cl (import 'si::(clines defentry defcfun object void int double quit bye gbc system) :user)
+
+(import 'si::(clines defentry defcfun object void int double quit bye gbc system
+		     *lib-directory* *system-directory*) :user)
 
 (let* ((i 4096)(j (si::equal-tail-recursion-check i)))
   (unless (<= (ash i -1) j)
--- gcl-2.6.12.orig/unixport/sys_pcl_gcl.c
+++ gcl-2.6.12/unixport/sys_pcl_gcl.c
@@ -41,7 +41,6 @@ gcl_init_system(object no_init)
 #ifdef HAVE_JAPI_H
   ar_check_init(gcl_japi,no_init);
 #endif
-  ar_check_init(gcl_iolib,no_init);
   ar_check_init(gcl_listlib,no_init);
   ar_check_init(gcl_mislib,no_init);
   ar_check_init(gcl_numlib,no_init);
@@ -56,9 +55,23 @@ gcl_init_system(object no_init)
   ar_check_init(gcl_defpackage,no_init);
   ar_check_init(gcl_make_defpackage,no_init);
   ar_check_init(gcl_sharp,no_init);
-  ar_check_init(gcl_fpe,no_init);
 
+  ar_check_init(gcl_sharp_uv,no_init);
+  ar_check_init(gcl_namestring,no_init);
+  ar_check_init(gcl_logical_pathname_translations,no_init);
+  ar_check_init(gcl_make_pathname,no_init);
+  ar_check_init(gcl_parse_namestring,no_init);
+  ar_check_init(gcl_translate_pathname,no_init);
+  ar_check_init(gcl_directory,no_init);
+  ar_check_init(gcl_merge_pathnames,no_init);
+  ar_check_init(gcl_truename,no_init);
+  ar_check_init(gcl_rename_file,no_init);
+  ar_check_init(gcl_wild_pathname_p,no_init);
+  ar_check_init(gcl_pathname_match_p,no_init);
 	
+  ar_check_init(gcl_iolib,no_init);
+  ar_check_init(gcl_fpe,no_init);
+
   ar_check_init(gcl_cmpinline,no_init);
   ar_check_init(gcl_cmputil,no_init);
 
@@ -107,6 +120,7 @@ gcl_init_system(object no_init)
   ar_check_init(gcl_index,no_init);
 #endif
   
+  lsp_init("../pcl/package.lisp");
   ar_check_init(gcl_pcl_pkg,no_init);
   ar_check_init(gcl_pcl_walk,no_init);
   ar_check_init(gcl_pcl_iterate,no_init);
--- gcl-2.6.12.orig/unixport/sys_pre_gcl.c
+++ gcl-2.6.12/unixport/sys_pre_gcl.c
@@ -39,7 +39,6 @@ gcl_init_system(object no_init)
 #ifdef HAVE_JAPI_H
   lsp_init("../lsp/gcl_japi.lsp");
 #endif
-  lsp_init("../lsp/gcl_iolib.lsp");
 /*   lsp_init("../lsp/gcl_listlib.lsp"); */
   lsp_init("../lsp/gcl_mislib.lsp");
   lsp_init("../lsp/gcl_numlib.lsp");
@@ -54,6 +53,21 @@ gcl_init_system(object no_init)
   lsp_init("../lsp/gcl_defpackage.lsp");
   lsp_init("../lsp/gcl_make_defpackage.lsp");
   lsp_init("../lsp/gcl_sharp.lsp");
+
+  lsp_init("../lsp/gcl_sharp_uv.lsp");
+  lsp_init("../lsp/gcl_logical_pathname_translations.lsp");
+  lsp_init("../lsp/gcl_make_pathname.lsp");
+  lsp_init("../lsp/gcl_parse_namestring.lsp");
+  lsp_init("../lsp/gcl_namestring.lsp");
+  lsp_init("../lsp/gcl_translate_pathname.lsp");
+  lsp_init("../lsp/gcl_directory.lsp");
+  lsp_init("../lsp/gcl_merge_pathnames.lsp");
+  lsp_init("../lsp/gcl_truename.lsp");
+  lsp_init("../lsp/gcl_rename_file.lsp");
+  lsp_init("../lsp/gcl_wild_pathname_p.lsp");
+  lsp_init("../lsp/gcl_pathname_match_p.lsp");
+
+  lsp_init("../lsp/gcl_iolib.lsp");
   lsp_init("../lsp/gcl_fpe.lsp");
 
   lsp_init("../cmpnew/gcl_cmpinline.lsp");
--- gcl-2.6.12.orig/xbin/make-fn
+++ gcl-2.6.12/xbin/make-fn
@@ -6,10 +6,13 @@ TMP=/tmp/tmpd$$
 mkdir ${TMP}
 cp $@ ${TMP}
 
-for v in $@ ; 
+for v in $1 ;
 do
 echo '(load (format nil "~a~a" si::*system-directory* "../cmpnew/gcl_collectfn"))' \
    '(compiler::emit-fn t)'\
+   "(compile-file \"${TMP}/$v\" :o-file nil)"
+echo '(load (format nil "~a~a" si::*system-directory* "../cmpnew/gcl_collectfn"))' \
+   '(compiler::emit-fn t)'\
    "(compile-file \"${TMP}/$v\" :o-file nil)" | ${LISP}
 done