;; used in the normal build, but can be handy for experimenting
;; with the system.
- ;; REMOVEME: should be conditional on :SB-SHOW again
- ;;(when (find :sb-show *shebang-features*)
+ (when (find :sb-show *shebang-features*)
#+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil)
#+sbcl (sb-ext:save-lisp-and-die "output/after-xc.core")
- ;;)
+ )
EOF
# Run GENESIS (again) in order to create cold-sbcl.core. (The first
# files for more information.
-export SBCL_XC_HOST="${1:-sbcl --noprogrammer}"
+# We don't try to be general about this in this script the way we are
+# in make.sh, since (1) we use our command line args as names of files
+# to recompile, and (2) the idiosyncrasies of SBCL command line
+# argument order dependence, the meaninglessness of duplicate --core
+# arguments, and the SBCL-vs-CMUCL dependence of --core/-core argument
+# syntax make it too messy to try deal with arbitrary SBCL commands.
+# So you have no choice:
+export SBCL_XC_HOST='sbcl --noprogrammer'
# (We don't do make-host-1.sh at all. Hopefully nothing relevant has
# changed.)
# though, make a point of not calling after-xc.core, since it might
# not exist, and there's no point in causing a fatal failure (by
# unsuccessfully trying to execute it) unnecessarily.
-if [ "$*" != "" ] ; then
- # Actually, I wrote this script when I needed to do a lot of
- # tweaking in src/runtime/*.c, and I haven't tried to make it
- # work for src/code/*.c yet. -- WHN 2001-05-12
- echo stub: no support yet for after-xc.core
- exit 1
-fi
+for f in $*; do echo "(target-compile-stem \"$f\")"; done \
+ | sbcl --core output/after-xc.core || exit 1
sh make-genesis-2.sh || exit 1
sh make-target-2.sh || exit 1
(/show0 "entering !COLD-INIT")
- (%primitive print "//entering !COLD-INIT") ; REMOVEME
-
;; FIXME: It'd probably be cleaner to have most of the stuff here
;; handled by calls like !GC-COLD-INIT, !ERROR-COLD-INIT, and
;; !UNIX-COLD-INIT. And *TYPE-SYSTEM-INITIALIZED* could be changed to
(setf *cold-init-complete-p* nil)
(setf *type-system-initialized* nil)
- (%primitive print "//done with SETFs") ; REMOVEME
-
;; Anyone might call RANDOM to initialize a hash value or something;
;; and there's nothing which needs to be initialized in order for
;; this to be initialized, so we initialize it right away.
;; functions are called in the same relative order as the toplevel
;; forms of the corresponding source files.
- (%primitive print "//about to !POLICY-COLD-INIT-OR-RESANIFY") ; REMOVEME
-
;;(show-and-call !package-cold-init)
(show-and-call !policy-cold-init-or-resanify)
(/show0 "back from !POLICY-COLD-INIT-OR-RESANIFY")
(/primitive-print hexstr)))
(let (#!+sb-show (index-in-cold-toplevels 0))
#!+sb-show (declare (type fixnum index-in-cold-toplevels))
- (%primitive print "//about to DOLIST TOPLEVEL-THING") ; REMOVEME
(dolist (toplevel-thing (prog1
(nreverse *!reversed-cold-toplevels*)
(!cold-lose "bogus fixup code in *!REVERSED-COLD-TOPLEVELS*"))))
(t (!cold-lose "bogus function in *!REVERSED-COLD-TOPLEVELS*")))))
(/show0 "done with loop over cold toplevel forms and fixups")
- (%primitive print "//done with DOLIST TOPLEVEL-THING") ; REMOVEME
;; Set sane values again, so that the user sees sane values instead
;; of whatever is left over from the last DECLAIM/PROCLAIM.
:invalid
:divide-by-zero))
- (%primitive print "//about to !CLASS-FINALIZE") ; REMOVEME
(show-and-call !class-finalize)
;; The reader and printer are initialized very late, so that they
(/show0 "done initializing, setting *COLD-INIT-COMPLETE-P*")
(setf *cold-init-complete-p* t)
- (%primitive print "//set *COLD-INIT-COMPLETE-P*") ; REMOVEME
;; The system is finally ready for GC.
#!-gengc (setf *already-maybe-gcing* nil)
(gc :full t)
(/show0 "back from first GC")
- (%primitive print "//back from first GC") ; REMOVEME
-
;; The show is on.
(terpri)
(/show0 "going into toplevel loop")
\f
;;;; UNIX-NAMESTRING
-(defun unix-namestring (pathname &optional (for-input t) executable-only)
- #!+sb-doc
- "Convert PATHNAME into a string that can be used with UNIX system calls.
- Search-lists and wild-cards are expanded."
- ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical
- ;; pathnames too.
- ;; FIXME: What does this ^ mean? A bug? A remark on a change already made?
- (let ((path (let ((lpn (pathname pathname)))
- (if (typep lpn 'logical-pathname)
- (namestring (translate-logical-pathname lpn))
- pathname))))
- (enumerate-search-list
- (pathname path)
- (collect ((names))
- (enumerate-matches (name pathname nil :verify-existence for-input)
- (when (or (not executable-only)
- (and (eq (sb!unix:unix-file-kind name)
- :file)
- (sb!unix:unix-access name
- sb!unix:x_ok)))
- (names name)))
- (let ((names (names)))
- (when names
- (when (cdr names)
- (error 'simple-file-error
- :format-control "~S is ambiguous:~{~% ~A~}"
- :format-arguments (list pathname names)))
- (return (car names))))))))
+(defun empty-relative-pathname-spec-p (x)
+ (or (equal x "")
+ (and (pathnamep x)
+ (or (equal (pathname-directory x) '(:relative))
+ ;; KLUDGE: I'm not sure this second check should really
+ ;; have to be here. But on sbcl-0.6.12.7,
+ ;; (PATHNAME-DIRECTORY (PATHNAME "")) is NIL, and
+ ;; (PATHNAME "") seems to act like an empty relative
+ ;; pathname, so in order to work with that, I test
+ ;; for NIL here. -- WHN 2001-05-18
+ (null (pathname-directory x)))
+ (null (pathname-name x))
+ (null (pathname-type x)))
+ ;; (The ANSI definition of "pathname specifier" has
+ ;; other cases, but none of them seem to admit the possibility
+ ;; of being empty and relative.)
+ ))
+
+;;; Convert PATHNAME into a string that can be used with UNIX system
+;;; calls, or return NIL if no match is found. Search-lists and
+;;; wild-cards are expanded.
+(defun unix-namestring (pathname-spec &optional (for-input t))
+ ;; The ordinary rules of converting Lispy paths to Unix paths break
+ ;; down for the current working directory, which Lisp thinks of as
+ ;; "" (more or less, and modulo ANSI's *DEFAULT-PATHNAME-DEFAULTS*,
+ ;; which unfortunately SBCL, as of sbcl-0.6.12.8, basically ignores)
+ ;; and Unix thinks of as ".". Since we're at the interface between
+ ;; Unix system calls and things like ENSURE-DIRECTORIES-EXIST which
+ ;; think the Lisp way, we perform the conversion.
+ ;;
+ ;; (FIXME: The *right* way to deal with this special case is to
+ ;; merge PATHNAME-SPEC with *DEFAULT-PATHNAME-DEFAULTS* here, after
+ ;; which it's not a relative pathname any more so the special case
+ ;; is no longer an issue. But until *DEFAULT-PATHNAME-DEFAULTS*
+ ;; works, we use this hack.)
+ (if (empty-relative-pathname-spec-p pathname-spec)
+ "."
+ ;; Otherwise, the ordinary rules apply.
+ (let* ((possibly-logical-pathname (pathname pathname-spec))
+ (physical-pathname (if (typep possibly-logical-pathname
+ 'logical-pathname)
+ (namestring (translate-logical-pathname
+ possibly-logical-pathname))
+ possibly-logical-pathname))
+ (matches nil)) ; an accumulator for actual matches
+ (enumerate-matches (match physical-pathname nil
+ :verify-existence for-input)
+ (push match matches))
+ (case (length matches)
+ (0 nil)
+ (1 (first matches))
+ (t (error 'simple-file-error
+ :format-control "~S is ambiguous:~{~% ~A~}"
+ :format-arguments (list pathname-spec matches)))))))
\f
;;;; TRUENAME and PROBE-FILE
-;;; Another silly file function trivially different from another function.
+;;; This is only trivially different from PROBE-FILE, which is silly
+;;; but ANSI.
(defun truename (pathname)
#!+sb-doc
- "Return the pathname for the actual file described by the pathname
- An error of type file-error is signalled if no such file exists,
+ "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."
(if (wild-pathname-p pathname)
(error 'simple-file-error
- :format-control "bad place for a wild pathname"
+ :format-control "can't use a wild pathname here"
:pathname pathname)
(let ((result (probe-file pathname)))
(unless result
;;; If PATHNAME exists, return its truename, otherwise NIL.
(defun probe-file (pathname)
#!+sb-doc
- "Return a pathname which is the truename of the file if it exists, NIL
+ "Return a pathname which is the truename of the file if it exists, or NIL
otherwise. An error of type FILE-ERROR is signaled if pathname is wild."
- (if (wild-pathname-p pathname)
- (error 'simple-file-error
- :pathname pathname
- :format-control "bad place for a wild pathname")
- (let ((namestring (unix-namestring pathname t)))
- (when (and namestring (sb!unix:unix-file-kind namestring))
- (let ((truename (sb!unix:unix-resolve-links
- (sb!unix:unix-maybe-prepend-current-directory
- namestring))))
- (when truename
- (let ((*ignore-wildcards* t))
- (pathname (sb!unix:unix-simplify-pathname truename)))))))))
+ (when (wild-pathname-p pathname)
+ (error 'simple-file-error
+ :pathname pathname
+ :format-control "can't use a wild pathname here"))
+ (let ((namestring (unix-namestring pathname t)))
+ (when (and namestring (sb!unix:unix-file-kind namestring))
+ (let ((truename (sb!unix:unix-resolve-links
+ (sb!unix:unix-maybe-prepend-current-directory
+ namestring))))
+ (when truename
+ (let ((*ignore-wildcards* t))
+ (pathname (sb!unix:unix-simplify-pathname truename))))))))
\f
;;;; miscellaneous other operations
\f
(defun ensure-directories-exist (pathspec &key verbose (mode #o777))
#!+sb-doc
- "Tests whether the directories containing the specified file
- actually exist, and attempts to create them if they do not.
- Portable programs should avoid using the :MODE argument."
+ "Test whether the directories containing the specified file
+ actually exist, and attempt to create them if they do not.
+ The MODE argument is a CMUCL/SBCL-specific extension to control
+ the Unix permission bits."
(let* ((pathname (pathname pathspec))
(pathname (if (typep pathname 'logical-pathname)
(translate-logical-pathname pathname)
environment (\"man environ\") definitions for the invocation of the linker.
The default is the environment that Lisp is itself running in. Instead of
using the ENVIRONMENT argument, it is also possible to use the ENV argument,
- using the alternate, lossy representation used by CMU CL."
+ using the older, lossy CMU CL representation."
(when (and env-p environment-p)
(error "can't specify :ENV and :ENVIRONMENT simultaneously"))
(let ((output-file (pick-temporary-file-name
*dso-linker*
(append *dso-linker-options*
(list output-file)
- (append (mapcar #'(lambda (name)
- (unix-namestring name nil))
+ (append (mapcar (lambda (name)
+ (unix-namestring name nil))
(if (atom files)
(list files)
files))
(stdout sb-c-call:int)
(stderr sb-c-call:int))
+;;; Is UNIX-FILENAME the name of a file that we can execute?
+(defun unix-filename-is-executable-p (unix-filename)
+ (declare (type simple-string unix-filename))
+ (values (and (eq (sb-unix:unix-file-kind unix-filename) :file)
+ (sb-unix:unix-access unix-filename sb-unix:x_ok))))
+
;;; FIXME: There shouldn't be two semiredundant versions of the
;;; documentation. Since this is a public extension function, the
;;; documentation should be in the doc string. So all information from
;; (I don't want to do it with search lists the way
;; that CMU CL did, because those are a non-ANSI
;; extension which I'd like to get rid of. -- WHN)
- (pfile (unix-namestring program t t))
+ (pfile (unix-namestring program t))
(cookie (list 0)))
(unless pfile
(error "no such program: ~S" program))
+ (unless (unix-filename-is-executable-p pfile)
+ (error "not executable: ~S" program))
(multiple-value-bind (stdin input-stream)
(get-descriptor-for input cookie
:direction :input
(defun toplevel-init ()
(/show0 "entering TOPLEVEL-INIT")
- (%primitive print "//entering TOPLEVEL-INIT") ; REMOVEME
-
(let ((sysinit nil) ; value of --sysinit option
(userinit nil) ; value of --userinit option
os_install_interrupt_handlers(void)
{
SHOW("os_install_interrupt_handlers()/bsd-os/defined(GENCGC)");
- SHOW("**1"); /* REMOVEME */
#if defined __FreeBSD__
- SHOW("**2"); /* REMOVEME */
SHOW("__FreeBSD__ case");
interrupt_install_low_level_handler(SIGBUS, memory_fault_handler);
#elif defined __OpenBSD__
- SHOW("**3"); /* REMOVEME */
FSHOW((stderr, "/__OpenBSD__ case, SIGSEGV=%d\n", SIGSEGV));
interrupt_install_low_level_handler(SIGSEGV, memory_fault_handler);
#else
#error unsupported BSD variant
#endif
- SHOW("**4"); /* REMOVEME */
SHOW("leaving os_install_interrupt_handlers()");
}
# more information.
# how we invoke SBCL in the tests
-export SBCL="${1:-../src/runtime/sbcl --core ../output/sbcl.core --noinform --sysinit /dev/null --userinit /dev/null --noprint --noprogrammer}"
+#
+# Until sbcl-0.6.12.8, the shell variable SBCL was bound to a relative
+# pathname, but now we take care to bind it to an absolute pathname (still
+# generated relative to `pwd` in the tests/ directory) so that tests
+# can chdir before invoking SBCL and still work.
+export SBCL="${1:-`pwd`/../src/runtime/sbcl --core `pwd`/../output/sbcl.core --noinform --sysinit /dev/null --userinit /dev/null --noprint --noprogrammer}"
echo /running tests on SBCL=\'$SBCL\'
# "Ten four" is the closest numerical slang I can find to "OK", so
if [ $? = 104 ]; then
echo ok
else
- echo test failed: $?
+ echo test failed, expected 104 return code, got $?
exit 1
fi
}
# absolutely no warranty. See the COPYING and CREDITS files for
# more information.
+original_pwd=`pwd`
+
# LOADing and COMPILEing files with logical pathnames
testdir=`pwd`"/side-effectful-pathnames-test-$$"
testfilestem="load-test"
(sb-ext:quit :unix-status 52)
EOF
if [ $? != 52 ]; then
- echo test failed: $?
+ echo LOAD/COMPILE test failed, unexpected Lisp return code=$?
exit 1
fi
+# We don't need the test directory any more.
rm -r $testdir
-# success
+# In the flaky1 branch, Dan Barlow pointed out that
+# ENSURE-DIRECTORIES-EXIST failed for these relative pathname
+# operations when the mysterious special case handling of "" pathnames
+# was removed from UNIX-STAT. Let's make sure that it works now.
+#
+# Set up an empty directory to work with.
+testfilestem=$TMPDIR/sbcl-mkdir-test-$$
+if ! rm -rf $testfilestem ; then
+ echo "$testfilestem already exists and cannot be deleted"
+ exit 1;
+fi
+mkdir $testfilestem
+cd $testfilestem
+#
+# Provoke failure.
+$SBCL <<EOF
+(let ((rel-name #p"foo/bar/")
+ (abs-name (merge-pathnames #p"baz/quux/" (truename "."))))
+ (and
+ (ensure-directories-exist abs-name)
+ (ensure-directories-exist rel-name)
+ (sb-ext:quit :unix-status 52)))
+EOF
+if [ $? != 52 ]; then
+ echo ENSURE-DIRECTORIES-EXIST test failed, unexpected SBCL return code=$?
+ find $testfilestem -print
+ exit 1
+fi
+if [ ! -d $testfilestem/foo/bar ] ; then
+ echo test failed: $testfilestem/foo/bar is not a directory
+ find $testfilestem -print
+ exit 1
+fi;
+if [ ! -d $testfilestem/baz/quux ] ; then
+ echo test failed: $testfilestem/baz/quux is not a directory
+ find $testfilestem -print
+ exit 1
+fi;
+#
+# We succeeded, life is good. Now we don't need the test directory
+# any more; and come back home.
+rm -r $testfilestem
+cd $original_pwd
+
+# success convention for script
exit 104
;;; 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.7.flaky1.1"
+"0.6.12.7.flaky1.2"
projects / sbcl.git / commitdiff