This is funny since sbcl-0.6.12.34 knows
(SUBTYPEP '(EQL 0) 'NUMBER) => T
+107:
+ (reported as a CMU CL bug by Erik Naggum on comp.lang.lisp
+ 2001-06-11:)
+ * (write #*101 :radix t :base 36)
+ #*#36r1#36r0#36r1
+ #*101
+ *
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
support for (AND ..) types, among other things)
changes in sbcl-0.6.13 relative to sbcl-0.6.12:
-* a port to the Alpha CPU, thanks to Dan Barlow
+* a port to the Compaq/DEC Alpha CPU, thanks to Dan Barlow
* Martin Atzmueller ported Tim Moore's marvellous CMU CL DISASSEMBLE
patch, so that DISASSEMBLE output is much nicer.
* better error handling in CLOS method combination, thanks to
is now a supported extension again, since the consensus is that
it can be useful for ordinary development work, not just for
debugging SBCL itself.
-?? more overflow fixes for >16Mbyte i/o buffers
+* At Dan Barlow's suggestion, TRUENAME on a dangling symbolic
+ link now returns the dangling link itself, and for similar reasons,
+ TRUENAME on a cyclic symbolic link returns the cyclic link itself.
+ (In these cases the old code signalled an error and looped
+ endlessly, respectively.) As a consequence of this change,
+ DIRECTORY now works even in the presence of dangling and cyclic
+ symbolic links.
+* more overflow fixes for >16Mbyte i/o buffers
* There's a new slam.sh hack to shorten the edit/compile/debug
cycle for low-level changes to SBCL itself, and a new
:SB-AFTER-XC-CORE target feature to control the generation of
the after-xc.core file needed by slam.sh.
-* minor incompatible change: The ENTRY-POINTS &KEY argument to
- COMPILE-FILE is no longer supported, so that now every function
- gets an entry point, so that block compilation looks a little
- more like the plain vanilla ANSI section 3.2.2.3 scheme.
* Fasl file version numbers are now independent of the target CPU,
since historically most system changes which required version
number changes have affected all CPUs equally. Similarly,
the byte fasl file version is now equal to the ordinary
fasl file version.
+* minor incompatible change: The ENTRY-POINTS &KEY argument to
+ COMPILE-FILE is no longer supported, so that now every function
+ gets an entry point, so that block compilation looks a little
+ more like the plain vanilla ANSI section 3.2.2.3 scheme.
?? minor incompatible change: SB-EXT:GET-BYTES-CONSED now
returns the number of bytes consed since the system started,
rather than the number consed since the first time the function
was called. (The new definition parallels ANSI functions like
CL:GET-INTERNAL-RUN-TIME.)
+* minor incompatible change: The old CMU-CL-style DIRECTORY options,
+ i.e. :ALL, :FOLLOW-LINKS, and :CHECK-FOR-SUBDIRS, are no longer
+ supported. Now DIRECTORY always does the abstract Common-Lisp-y
+ thing, i.e. :ALL T :FOLLOW-LINKS T :CHECK-FOR-SUBDIRS T.
planned incompatible changes in 0.7.x:
* The debugger prompt sequence now goes "5]", "5[2]", "5[3]", etc.
"LOCAL-ALIEN-INFO-P" "LOCAL-ALIEN-INFO-TYPE"
"MAKE-ALIEN-FUNCTION-TYPE" "MAKE-ALIEN-POINTER-TYPE"
"MAKE-ALIEN-VALUE"
- "MAKE-LOCAL-ALIEN" "NATURALIZE" "NOTE-LOCAL-ALIEN-TYPE"
+ "MAKE-LOCAL-ALIEN" "NATURALIZE"
+ "NOTE-LOCAL-ALIEN-TYPE"
"PARSE-ALIEN-TYPE" "UNPARSE-ALIEN-TYPE"))
#s(sb-cold:package-data
"UNIX-EXECVE" "UNIX-EXIT" "UNIX-FCHMOD" "UNIX-FCHOWN"
"UNIX-FCNTL" "UNIX-FD" "UNIX-FILE-MODE" "UNIX-FORK" "UNIX-FSTAT"
"UNIX-FSYNC" "UNIX-FTRUNCATE" "UNIX-GETDTABLESIZE" "UNIX-GETEGID"
- "UNIX-GETGID" "UNIX-GETHOSTID" "UNIX-GETHOSTNAME"
+ "UNIX-GETGID" "UNIX-GETHOSTNAME"
"UNIX-GETPAGESIZE" "UNIX-GETPEERNAME" "UNIX-GETPGRP"
"UNIX-GETPID" "UNIX-GETPPID" "UNIX-GETRUSAGE"
"UNIX-GETSOCKNAME" "UNIX-GETTIMEOFDAY" "UNIX-GETUID" "UNIX-GID"
#!+sb-doc
"Return the pathname for the actual file described by PATHNAME.
An error of type FILE-ERROR is signalled if no such file exists,
- or the pathname is wild."
+ or the pathname is wild.
+
+ Under Unix, the TRUENAME of a broken symlink is considered to be
+ the name of the broken symlink itself."
(if (wild-pathname-p pathname)
(error 'simple-file-error
:format-control "can't use a wild pathname here"
pathname
(sane-default-pathname-defaults)))
(namestring (unix-namestring defaulted-pathname t)))
- (when (and namestring (sb!unix:unix-file-kind namestring))
- (let ((truename (sb!unix:unix-resolve-links namestring)))
- (when truename
+ (when (and namestring (sb!unix:unix-file-kind namestring t))
+ (let ((trueishname (sb!unix:unix-resolve-links namestring)))
+ (when trueishname
(let ((*ignore-wildcards* t))
- (pathname (sb!unix:unix-simplify-pathname truename))))))))
+ (pathname (sb!unix:unix-simplify-pathname trueishname))))))))
\f
;;;; miscellaneous other operations
(defun file-author (file)
#!+sb-doc
- "Returns the file author as a string, or nil if the author cannot be
- determined. Signals an error of type file-error if file doesn't exist,
- or file is a wild pathname."
+ "Return the file author as a string, or nil if the author cannot be
+ determined. Signal an error of type FILE-ERROR if FILE doesn't exist,
+ or FILE is a wild pathname."
(if (wild-pathname-p file)
(error 'simple-file-error
:pathname file
(/show0 "filesys.lisp 800")
-(defun directory (pathname &key (all t) (check-for-subdirs t)
- (follow-links t))
+(defun directory (pathname &key)
#!+sb-doc
- "Returns a list of pathnames, one for each file that matches the given
- pathname. Supplying :ALL as NIL causes this to ignore Unix dot files. This
- never includes Unix dot and dot-dot in the result. If :FOLLOW-LINKS is NIL,
- then symbolic links in the result are not expanded. This is not the
- default because TRUENAME does follow links, and the result pathnames are
- defined to be the TRUENAME of the pathname (the truename of a link may well
- be in another directory.)"
- (let ((results nil))
+ "Return a list of PATHNAMEs, each the TRUENAME of a file that matched the
+ given pathname. Note that the interaction between this ANSI-specified
+ TRUENAMEing and the semantics of the Unix filesystem (symbolic links..)
+ means this function can sometimes return files which don't have the same
+ directory as PATHNAME."
+ (let ((truenames nil))
(enumerate-search-list
(pathname (merge-pathnames pathname
(make-pathname :name :wild
:type :wild
:version :wild)))
- (enumerate-matches (name pathname)
- (when (or all
- (let ((slash (position #\/ name :from-end t)))
- (or (null slash)
- (= (1+ slash) (length name))
- (char/= (schar name (1+ slash)) #\.))))
- (push name results))))
- (let ((*ignore-wildcards* t))
- (mapcar (lambda (name)
- (let ((name (if (and check-for-subdirs
- (eq (sb!unix:unix-file-kind name)
- :directory))
- (concatenate 'string name "/")
- name)))
- (if follow-links (truename name) (pathname name))))
- (sort (delete-duplicates results :test #'string=) #'string<)))))
+ (enumerate-matches (match pathname)
+ (let ((*ignore-wildcards* t))
+ (push (truename (if (eq (sb!unix:unix-file-kind match) :directory)
+ (concatenate 'string match "/")
+ match))
+ truenames))))
+ ;; FIXME: The DELETE-DUPLICATES here requires quadratic time,
+ ;; which is unnecessarily slow. That might not be an issue,
+ ;; though, since the time constant for doing TRUENAME on every
+ ;; directory entry is likely to be (much) larger, and the cost of
+ ;; all those TRUENAMEs on a huge directory might even be quadratic
+ ;; in the directory size. Someone who cares about enormous
+ ;; directories might want to check this. -- WHN 2001-06-19
+ (sort (delete-duplicates truenames :test #'string= :key #'pathname-name)
+ #'string< :key #'pathname-name)))
\f
;;;; translating Unix uid's
;;;;
(defun room (&optional (verbosity :default))
#!+sb-doc
- "Prints to *STANDARD-OUTPUT* information about the state of internal
+ "Print to *STANDARD-OUTPUT* information about the state of internal
storage and its management. The optional argument controls the
- verbosity of ROOM. If it is T, ROOM prints out a maximal amount of
+ verbosity of output. If it is T, ROOM prints out a maximal amount of
information. If it is NIL, ROOM prints out a minimal amount of
information. If it is :DEFAULT or it is not supplied, ROOM prints out
- an intermediate amount of information. See also VM:MEMORY-USAGE and
- VM:INSTANCE-USAGE for finer report control."
+ an intermediate amount of information."
(fresh-line)
(ecase verbosity
((t)
;;; Presumably someone will call GC-ON later to collect the garbage.
(defvar *gc-inhibit-hook* nil
#!+sb-doc
- "Should be bound to a function or NIL. If it is a function, this
+ "This should be bound to a function or NIL. If it is a function, this
function should take one argument, the current amount of dynamic
usage. The function should return NIL if garbage collection should
continue and non-NIL if it should be inhibited. Use with caution.")
(defvar *gc-run-time* 0
#!+sb-doc
- "The total CPU time spent doing garbage collection (as reported by
- GET-INTERNAL-RUN-TIME.)")
+ "the total CPU time spent doing garbage collection (as reported by
+ GET-INTERNAL-RUN-TIME)")
(declaim (type index *gc-run-time*))
;;; a limit to help catch programs which allocate too much memory,
(defun gc (&key (gen 0) (full nil) &allow-other-keys)
#!+(and sb-doc gencgc)
- "Initiates a garbage collection. GEN controls the number of generations to garbage collect"
+ "Initiate a garbage collection. GEN controls the number of generations
+ to garbage collect."
#!+(and sb-doc (not gencgc))
- "Initiates a garbage collection. GEN may be provided for compatibility, but is ignored"
+ "Initiate a garbage collection. GEN may be provided for compatibility, but
+ is ignored."
(sub-gc :force-p t :gen (if full 6 gen)))
\f
(defun gc-on ()
#!+sb-doc
- "Enables the garbage collector."
+ "Enable the garbage collector."
(setq *gc-inhibit* nil)
(when *need-to-collect-garbage*
(sub-gc))
(defun gc-off ()
#!+sb-doc
- "Disables the garbage collector."
+ "Disable the garbage collector."
(setq *gc-inhibit* t)
nil)
\f
(let ((residual-objects (- total-objects printed-objects))
(residual-bytes (- total-bytes printed-bytes)))
(unless (zerop residual-objects)
- (format t " Other types: ~:D bytes, ~D: object~:P.~%"
+ (format t " Other types: ~:D bytes, ~D object~:P.~%"
residual-bytes residual-objects))))
(format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
;;; Return the real user-id associated with the current process.
(def-alien-routine ("getuid" unix-getuid) int)
-;;; Invoke readlink(2) on the file name specified by the simple string
-;;; PATH. Return up to two values: the contents of the symbolic link
-;;; if the call is successful, or NIL and the Unix error number.
+;;; Invoke readlink(2) on the file name specified by PATH. Return
+;;; (VALUES LINKSTRING NIL) on success, or (VALUES NIL ERRNO) on
+;;; failure.
(defun unix-readlink (path)
(declare (type unix-pathname path))
- (with-alien ((buf (array char 1024)))
- (syscall ("readlink" c-string (* char) int)
- (let ((string (make-string result)))
- (sb!kernel:copy-from-system-area
- (alien-sap buf) 0
- string (* sb!vm:vector-data-offset sb!vm:word-bits)
- (* result sb!vm:byte-bits))
- string)
- path (cast buf (* char)) 1024)))
+ (with-alien ((ptr (* char)
+ (alien-funcall (extern-alien
+ "wrapped_readlink"
+ (function (* char) c-string))
+ path)))
+ (if (null-alien ptr)
+ (values nil (get-errno))
+ (multiple-value-prog1
+ (values (with-alien ((c-string c-string ptr)) c-string)
+ nil)
+ (free-alien ptr)))))
;;; UNIX-UNLINK accepts a name and deletes the directory entry for that
;;; name and the file if this is the last link.
((eql kind s-iflnk) :link)
(t :special))))))
-;;; Return the pathname with all symbolic links resolved.
-;;;
-;;; FIXME: Could we just use Unix readlink(2) instead?
+;;; Is the Unix pathname PATHNAME relative, instead of absolute? (E.g.
+;;; "passwd" or "etc/passwd" instead of "/etc/passwd"?)
+(defun relative-unix-pathname? (pathname)
+ (declare (type simple-string pathname))
+ (or (zerop (length pathname))
+ (char/= (schar pathname 0) #\/)))
+
+;;; Return PATHNAME with all symbolic links resolved. PATHNAME should
+;;; already be a complete absolute Unix pathname, since at least in
+;;; sbcl-0.6.12.36 we're called only from TRUENAME, and only after
+;;; paths have been converted to absolute paths, so we don't need to
+;;; try to handle any more generality than that.
(defun unix-resolve-links (pathname)
- (declare (simple-string pathname))
- (let ((len (length pathname))
- (pending pathname))
- (declare (fixnum len) (simple-string pending))
- (if (zerop len)
- pathname
- (let ((result (make-string 1024 :initial-element (code-char 0)))
- (fill-ptr 0)
- (name-start 0))
- (loop
- (let* ((name-end (or (position #\/ pending :start name-start) len))
- (new-fill-ptr (+ fill-ptr (- name-end name-start))))
- (replace result pending
- :start1 fill-ptr
- :end1 new-fill-ptr
- :start2 name-start
- :end2 name-end)
- (let ((kind (unix-file-kind (if (zerop name-end) "/" result) t)))
- (unless kind (return nil))
- (cond ((eq kind :link)
- (multiple-value-bind (link err) (unix-readlink result)
- (unless link
- (error 'simple-file-error
- :pathname pathname
- :format-control
- "~@<error reading link ~S: ~2I~_~A~:>"
- :format-arguments (list (subseq
- result 0 fill-ptr)
- (strerror err))))
- (cond ((or (zerop (length link))
- (char/= (schar link 0) #\/))
- ;; It's a relative link.
- (fill result (code-char 0)
- :start fill-ptr
- :end new-fill-ptr))
- ((string= result "/../" :end1 4)
- ;; It's across the super-root.
- (let ((slash (or (position #\/ result :start 4)
- 0)))
- (fill result (code-char 0)
- :start slash
- :end new-fill-ptr)
- (setf fill-ptr slash)))
- (t
- ;; It's absolute.
- (and (> (length link) 0)
- (char= (schar link 0) #\/))
- (fill result (code-char 0) :end new-fill-ptr)
- (setf fill-ptr 0)))
- (setf pending
- (if (= name-end len)
- link
- (concatenate 'simple-string
- link
- (subseq pending name-end))))
- (setf len (length pending))
- (setf name-start 0)))
- ((= name-end len)
- (return (subseq result 0 new-fill-ptr)))
- ((eq kind :directory)
- (setf (schar result new-fill-ptr) #\/)
- (setf fill-ptr (1+ new-fill-ptr))
- (setf name-start (1+ name-end)))
- (t
- (return nil))))))))))
+ (declare (type simple-string pathname))
+ (aver (not (relative-unix-pathname? pathname)))
+ (/show "entering UNIX-RESOLVE-LINKS")
+ (loop with previous-pathnames = nil do
+ (/show pathname previous-pathnames)
+ (let ((link (unix-readlink pathname)))
+ (/show link)
+ ;; Unlike the old CMU CL code, we handle a broken symlink by
+ ;; returning the link itself. That way, CL:TRUENAME on a
+ ;; broken link returns the link itself, so that CL:DIRECTORY
+ ;; can return broken links, so that even without
+ ;; Unix-specific extensions to do interesting things with
+ ;; them, at least Lisp programs can see them and, if
+ ;; necessary, delete them. (This is handy e.g. when your
+ ;; managed-by-Lisp directories are visited by Emacs, which
+ ;; creates broken links as notes to itself.)
+ (if (null link)
+ (return pathname)
+ (let ((new-pathname
+ (unix-simplify-pathname
+ (if (relative-unix-pathname? link)
+ (let* ((dir-len (1+ (position #\/
+ pathname
+ :from-end t)))
+ (dir (subseq pathname 0 dir-len)))
+ (/show dir)
+ (concatenate 'string dir link))
+ link))))
+ (if (unix-file-kind new-pathname)
+ (setf pathname new-pathname)
+ (return pathname)))))
+ ;; To generalize the principle that even if portable Lisp code
+ ;; can't do anything interesting with a broken symlink, at
+ ;; least it should be able to see and delete it, when we
+ ;; detect a cyclic link, we return the link itself. (So even
+ ;; though portable Lisp code can't do anything interesting
+ ;; with a cyclic link, at least it can see it and delete it.)
+ (if (member pathname previous-pathnames :test #'string=)
+ (return pathname)
+ (push pathname previous-pathnames))))
(defun unix-simplify-pathname (src)
- (declare (simple-string src))
+ (declare (type simple-string src))
(let* ((src-len (length src))
(dst (make-string src-len))
(dst-len 0)
(dots 0)
(last-slash nil))
(macrolet ((deposit (char)
- `(progn
- (setf (schar dst dst-len) ,char)
- (incf dst-len))))
+ `(progn
+ (setf (schar dst dst-len) ,char)
+ (incf dst-len))))
(dotimes (src-index src-len)
(let ((char (schar src src-index)))
(cond ((char= char #\.)
((char= char #\/)
(case dots
(0
- ;; Either ``/...' or ``...//...'
+ ;; either ``/...' or ``...//...'
(unless last-slash
(setf last-slash dst-len)
(deposit char)))
(1
- ;; Either ``./...'' or ``..././...''
+ ;; either ``./...'' or ``..././...''
(decf dst-len))
(2
;; We've found ..
(setf last-slash dst-len)
(deposit char))))
(t
- ;; Something other than a dot between slashes.
+ ;; something other than a dot between slashes
(setf last-slash dst-len)
(deposit char)))
(setf dots 0))
(declaim (ftype (function (&rest t) nil) sb!kernel::do-arg-count-error))
(let ((reversed-target-object-file-names nil))
- (for-stems-and-flags (stem flags)
- (unless (find :not-target flags)
- ;; FIXME: Remove these GC calls after fixing the problem of ridiculous
- ;; bootstrap memory bloat.
+ (do-stems-and-flags (stem flags)
+ (unless (position :not-target flags)
(push (target-compile-stem stem
:assem-p (find :assem flags)
:ignore-failure-p (find :ignore-failure-p
;; with the ordinary Lisp compiler, and this is intentional, in
;; order to make the compiler aware of the definitions of assembly
;; routines.
- (for-stems-and-flags (stem flags)
+ (do-stems-and-flags (stem flags)
(unless (find :not-host flags)
(funcall load-or-cload-stem
stem
(defparameter *stems-and-flags* (read-from-file "stems-and-flags.lisp-expr"))
-(defmacro for-stems-and-flags ((stem flags) &body body)
+(defmacro do-stems-and-flags ((stem flags) &body body)
(let ((stem-and-flags (gensym "STEM-AND-FLAGS-")))
`(dolist (,stem-and-flags *stems-and-flags*)
(let ((,stem (first ,stem-and-flags))
;;; Check for stupid typos in FLAGS list keywords.
(let ((stems (make-hash-table :test 'equal)))
- (for-stems-and-flags (stem flags)
+ (do-stems-and-flags (stem flags)
(if (gethash stem stems)
(error "duplicate stem ~S in stems-and-flags data" stem)
(setf (gethash stem stems) t))
(:external-format (member :default)))
t)
-(defknown directory (pathname-designator &key
- (:check-for-subdirs t)
- (:all t)
- (:follow-links t))
+(defknown directory (pathname-designator &key)
list (flushable))
\f
;;;; from the "Errors" chapter:
LDSO_STUBIFY(getegid)
LDSO_STUBIFY(getenv)
LDSO_STUBIFY(getgid)
- LDSO_STUBIFY(gethostid)
LDSO_STUBIFY(gethostbyaddr)
LDSO_STUBIFY(gethostbyname)
LDSO_STUBIFY(gethostname)
F(geteuid)
F(getgid)
F(getgroups)
-#if !defined (SOLARIS) || defined(SOLARIS25)
-F(gethostid)
-#endif
F(gethostname)
F(getitimer)
#if !defined(hpux) && !defined(SVR4) || defined(SOLARIS25)
}
\f
/*
+ * readlink(2) stuff
+ */
+
+/* a wrapped version of readlink(2):
+ * -- If path isn't a symlink, or is a broken symlink, return 0.
+ * -- If path is a symlink, return a newly allocated string holding
+ * the thing it's linked to.
+ */
+char *
+wrapped_readlink(char *path)
+{
+ int strlen_path = strlen(path);
+ int bufsiz = strlen(path) + 16;
+ while (1) {
+ char *result = malloc(bufsiz);
+ int n_read = readlink(path, result, n_read);
+ if (n_read < 0) {
+ return 0;
+ } else if (n_read < bufsiz) {
+ result[n_read] = 0;
+ return result;
+ } else {
+ free(result);
+ bufsiz *= 2;
+ }
+ }
+}
+\f
+/*
* stat(2) stuff
*/
;;;
;;; (Peter Van Eynde's ansi-test suite caught this, and Eric Marsden
;;; reported a fix for CMU CL, which was ported to sbcl-0.6.12.35.)
-(assert (subtypep (nth-value 1 (ignore-errors (file-length *terminal-io*)))
- 'type-error))
+(assert (typep (nth-value 1 (ignore-errors (file-length *terminal-io*)))
+ 'type-error))
--- /dev/null
+#!/bin/sh
+
+# This software is part of the SBCL system. See the README file for
+# more information.
+#
+# While most of SBCL is derived from the CMU CL system, the test
+# files (like this one) were written from scratch after the fork
+# from CMU CL.
+#
+# This software is in the public domain and is provided with
+# absolutely no warranty. See the COPYING and CREDITS files for
+# more information.
+
+# Test DIRECTORY and TRUENAME.
+testdir=`pwd`"/filesys-test-$$"
+mkdir $testdir
+echo this is a test > $testdir/test-1.tmp
+echo this is a test > $testdir/test-2.tmp
+cd $testdir
+ln -s test-1.tmp link-1
+ln -s `pwd`/test-2.tmp link-2
+ln -s i-do-not-exist link-3
+ln -s link-4 link-4
+ln -s link-5 link-6
+ln -s `pwd`/link-6 link-5
+expected_truenames=\
+"'(#p\"$testdir/link-3\"\
+ #p\"$testdir/link-4\"\
+ #p\"$testdir/link-5\"\
+ #p\"$testdir/link-6\"\
+ #p\"$testdir/test-1.tmp\"\
+ #p\"$testdir/test-2.tmp\")"
+$SBCL <<EOF
+ (in-package :cl-user)
+ (let* ((directory (directory "./*"))
+ (truenames (sort directory #'string< :key #'pathname-name)))
+ (format t "~&TRUENAMES=~S~%" truenames)
+ (finish-output)
+ (assert (equal truenames $expected_truenames)))
+ (assert (equal (truename "test-1.tmp") #p"$testdir/test-1.tmp"))
+ (assert (equal (truename "link-1") #p"$testdir/test-1.tmp"))
+ (assert (equal (truename "link-2") #p"$testdir/test-2.tmp"))
+ (assert (equal (truename "link-3") #p"$testdir/link-3"))
+ (assert (equal (truename "link-4") #p"$testdir/link-4"))
+ (assert (equal (truename "link-5") #p"$testdir/link-5"))
+ (assert (equal (truename "link-6") #p"$testdir/link-6"))
+ (sb-ext:quit :unix-status 52)
+EOF
+if [ $? != 52 ]; then
+ echo DIRECTORY/TRUENAME test part 1 failed, unexpected SBCL return code=$?
+ exit 1
+fi
+cd ..
+$SBCL <<EOF
+ (in-package :cl-user)
+ (let* ((directory (directory "$testdir/*"))
+ (truenames (sort directory #'string< :key #'pathname-name)))
+ (format t "~&TRUENAMES=~S~%" truenames)
+ (finish-output)
+ (assert (equal truenames $expected_truenames)))
+ (assert (equal (truename "$testdir/test-1.tmp") #p"$testdir/test-1.tmp"))
+ (assert (equal (truename "$testdir/link-1") #p"$testdir/test-1.tmp"))
+ (assert (equal (truename "$testdir/link-2") #p"$testdir/test-2.tmp"))
+ (assert (equal (truename "$testdir/link-3") #p"$testdir/link-3"))
+ (assert (equal (truename "$testdir/link-4") #p"$testdir/link-4"))
+ (assert (equal (truename "$testdir/link-5") #p"$testdir/link-5"))
+ (assert (equal (truename "$testdir/link-6") #p"$testdir/link-6"))
+ (sb-ext:quit :unix-status 52)
+EOF
+if [ $? != 52 ]; then
+ echo DIRECTORY/TRUENAME test part 2 failed, unexpected SBCL return code=$?
+ exit 1
+fi
+rm -r $testdir
+
+# success convention for script
+exit 104
;;;
;;; (Peter Van Eynde's ansi-test suite caught this, and Eric Marsden
;;; reported a fix for CMU CL, which was ported to sbcl-0.6.12.35.)
-(assert (subtypep (nth-value 1 (ignore-errors (float-radix "notfloat")))
- 'type-error))
\ No newline at end of file
+(assert (typep (nth-value 1 (ignore-errors (float-radix "notfloat")))
+ 'type-error))
\ No newline at end of file
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.12.35"
+"0.6.12.36"
projects / sbcl.git / commitdiff