From: William Harold Newman Date: Mon, 28 May 2001 23:44:10 +0000 (+0000) Subject: 0.6.12.18: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=dccfa0f4e378a267744c03b1416accdf9d888987;p=sbcl.git 0.6.12.18: added code to initialize *DEFAULT-PATHNAME-DEFAULTS*, to start making it a little more ANSI started documenting visible-in-the-interface variables whose old values are discarded when a core is saved and loaded (e.g. *DEFAULT-PATHNAME-DEFAULTS*) tweaked side-effectful-pathnames.test.sh so it accepts the new more-ANSI behavior of *DEFAULT-PATHNAME-DEFAULTS* hacked LOAD to physicalize pathnames before merging them, to work around apparent MERGE-PATHNAMES problems and let tests/filesys.pure.lisp work with new nontrivial *DEFAULT-PATHNAME-DEFAULTS*; also hacked COMPILE-FILE-PATHNAME similarly factored out DEFUN PHYSICALIZE-PATHNAME made FILE-LENGTH "work" (up to 32 bits) on OpenBSD again --- diff --git a/base-target-features.lisp-expr b/base-target-features.lisp-expr index 3ae733f..5aa58f7 100644 --- a/base-target-features.lisp-expr +++ b/base-target-features.lisp-expr @@ -3,9 +3,20 @@ ;;;; CL:*FEATURES* tags which have special meaning to SBCL or which ;;;; have a special conventional meaning ;;;; -;;;; Note that the preferred way to customize the features of a local -;;;; build of SBCL is not to edit this file, but to tweak -;;;; customize-target-features.lisp. +;;;; Note that the recommended way to customize the features of a +;;;; local build of SBCL is not to edit this file, but instead to +;;;; tweak customize-target-features.lisp. E.g. you can use code like +;;;; this: +;;;; (lambda (list) +;;;; (flet ((enable (x) (pushnew x list)) +;;;; (disable (x) (setf list (remove x list)))) +;;;; #+nil (enable :sb-show) +;;;; (enable :sb-after-xc-core) +;;;; #+nil (disable :sb-doc) +;;;; list)) +;;;; That way, because customize-target-features.lisp is in +;;;; .cvsignore, your local changes will remain local even if you use +;;;; "cvs diff" to submit patches to SBCL. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -29,7 +40,7 @@ :sbcl ;; Douglas Thomas Crosher's conservative generational GC (the only one - ;; we currently support) + ;; we currently support for X86) :gencgc ;; We're running under a UNIX. This is sort of redundant, and it was also @@ -257,14 +268,18 @@ ;; really, really know what you're doing): ;; ;; machine architecture features: - ;; :x86 ; any Intel 386 or better, or compatibles like the AMD K6 or K7 - ;; (No others are supported by SBCL as of 0.6.7, but :alpha or - ;; :sparc support could be ported from CMU CL if anyone is - ;; sufficiently motivated to do so.) - ;; (CMU CL also had a :pentium feature, which affected the definition - ;; of some floating point vops. It was present but not enabled in the - ;; CMU CL code that SBCL is derived from, and is present but stale - ;; in SBCL as of 0.6.7.) + ;; :x86 + ;; any Intel 386 or better, or compatibles like the AMD K6 or K7 + ;; :alpha + ;; DEC/Compaq Alpha CPU + ;; (No other CPUs are supported by SBCL as of 0.6.12.15, but SPARC or + ;; PowerPC support could be ported from CMU CL if anyone is + ;; sufficiently motivated to do so, or if you're *really* motivated, + ;; you could write a port from scratch for a new CPU architecture.) + ;; (CMU CL also had a :pentium feature, which affected the definition + ;; of some floating point vops. It was present but not enabled or + ;; documented in the CMU CL code that SBCL is derived from, and is + ;; present but stale in SBCL as of 0.6.12.) ;; ;; operating system features: ;; :linux = We're intended to run under some version of Linux. @@ -275,5 +290,6 @@ ;; :openbsd = We're intended to run under FreeBSD. ;; (No others are supported by SBCL as of 0.6.7, but :hpux or ;; :solaris support could be ported from CMU CL if anyone is - ;; sufficiently motivated to do so.) + ;; sufficiently motivated to do so, and it'd even be possible, + ;; though harder, to port the system to Microsoft Windows.) ) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index ee65d18..27f1be3 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -676,6 +676,7 @@ retained, possibly temporariliy, because it might be used internally." "CONSTANTLY-T" "CONSTANTLY-NIL" "CONSTANTLY-0" "PSXHASH" "%BREAK" + "PHYSICALIZE-PATHNAME" ;; ..and macros.. "COLLECT" diff --git a/src/code/bsd-os.lisp b/src/code/bsd-os.lisp index 8e30939..22edc57 100644 --- a/src/code/bsd-os.lisp +++ b/src/code/bsd-os.lisp @@ -31,12 +31,10 @@ (sb!ext:run-program "/usr/bin/uname" `("-r") :output stream)))))) -;;; OS-COLD-INIT-OR-REINIT initializes our operating-system interface. -;;; It sets the values of the global port variables to what they -;;; should be and calls the functions that set up the argument blocks -;;; for the server interfaces. (defun os-cold-init-or-reinit () - (setf *software-version* nil)) + (setf *software-version* nil) + (setf *default-pathname-defaults* + (pathname (sb!ext::default-directory)))) ;;; Return system time, user time and number of page faults. (defun get-system-info () diff --git a/src/code/extensions.lisp b/src/code/extensions.lisp index 4c6c4e2..7dd9b95 100644 --- a/src/code/extensions.lisp +++ b/src/code/extensions.lisp @@ -854,6 +854,14 @@ (print-unreadable-object (structure ,stream :type t) ,@(nreverse reversed-prints)))))) +;;;; etc. + +;;; Given a pathname, return a corresponding physical pathname. +(defun physicalize-pathname (possibly-logical-pathname) + (if (typep possibly-logical-pathname 'logical-pathname) + (translate-logical-pathname possibly-logical-pathname) + possibly-logical-pathname)) + #| ;;; REMOVEME when done testing byte cross-compiler (defun byte-compiled-foo (x y) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 5d6e867..583345f 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -858,12 +858,6 @@ (:charpos (fd-stream-char-pos fd-stream)) (:file-length - ;; FIXME: This is broken on OpenBSD until the FFI, or at least - ;; UNIX-FSTAT, learns to extract 64-bit values. (As of sbcl-0.6.12.8, - ;; UNIX-FSTAT returns a 0 placeholder instead.) - #!+openbsd - (error "FIXME: internal error, FILE-LENGTH is broken on OpenBSD") - #!-openbsd (multiple-value-bind (okay dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks) (sb!unix:unix-fstat (fd-stream-fd fd-stream)) @@ -882,8 +876,7 @@ (type (or index (member nil :start :end)) newpos)) (if (null newpos) (sb!sys:without-interrupts - ;; First, find the position of the UNIX file descriptor in the - ;; file. + ;; First, find the position of the UNIX file descriptor in the file. (multiple-value-bind (posn errno) (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr) (declare (type (or index null) posn)) diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 6985a3d..e33a94f 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -746,15 +746,9 @@ (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)) + (let* ((namestring (physicalize-pathname (pathname pathname-spec))) (matches nil)) ; an accumulator for actual matches - (enumerate-matches (match physical-pathname nil - :verify-existence for-input) + (enumerate-matches (match namestring nil :verify-existence for-input) (push match matches)) (case (length matches) (0 nil) @@ -1066,11 +1060,8 @@ 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) - pathname)) - (created-p nil)) + (let ((pathname (physicalize-pathname (pathname pathspec))) + (created-p nil)) (when (wild-pathname-p pathname) (error 'simple-file-error :format-control "bad place for a wild pathname" diff --git a/src/code/linux-os.lisp b/src/code/linux-os.lisp index df6ca15..1d87b6f 100644 --- a/src/code/linux-os.lisp +++ b/src/code/linux-os.lisp @@ -33,13 +33,12 @@ (sb!ext:run-program "/bin/uname" `("-r") :output stream)))))) -;;; OS-COLD-INIT-OR-REINIT initializes our operating-system interface. -;;; It sets the values of the global port variables to what they -;;; should be and calls the functions that set up the argument blocks -;;; for the server interfaces. (defun os-cold-init-or-reinit () ; KLUDGE: don't know what to do here #!+sparc ;; Can't use #x20000000 thru #xDFFFFFFF, but mach tries to let us. - (sb!sys:allocate-system-memory-at (sb!sys:int-sap #x20000000) #xc0000000)) + (sb!sys:allocate-system-memory-at (sb!sys:int-sap #x20000000) #xc0000000) + (setf *software-version* nil) + (setf *default-pathname-defaults* + (pathname (sb!ext::default-directory)))) ;;; Return system time, user time and number of page faults. (defun get-system-info () diff --git a/src/code/save.lisp b/src/code/save.lisp index beb9286..dfaa5cf 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -49,27 +49,31 @@ out early because of some argument error or something). The following &KEY args are defined: + :TOPLEVEL + The function to run when the created core file is resumed. + The default function handles command line toplevel option + processing and runs the top level read-eval-print loop. This + function should not return. + :PURIFY + If true (the default), do a purifying GC which moves all dynamically + allocated objects into static space so that they stay pure. This takes + somewhat longer than the normal GC which is otherwise done, but it's + only done once, and subsequent GC's will be done less often and will + take less time in the resulting core file. See PURIFY. + :ROOT-STRUCTURES + This should be a list of the main entry points in any newly loaded + systems. This need not be supplied, but locality and/or GC performance + may be better if they are. Meaningless if :PURIFY is NIL. See PURIFY. + :ENVIRONMENT-NAME + This is also passed to PURIFY when :PURIFY is T. (rarely used) - :TOPLEVEL - The function to run when the created core file is resumed. - The default function handles command line toplevel option - processing and runs the top level read-eval-print loop. This - function should not return. - - :PURIFY - If true (the default), do a purifying GC which moves all dynamically - allocated objects into static space so that they stay pure. This takes - somewhat longer than the normal GC which is otherwise done, but it's only - done once, and subsequent GC's will be done less often and will take less - time in the resulting core file. See PURIFY. - - :ROOT-STRUCTURES - This should be a list of the main entry points in any newly loaded - systems. This need not be supplied, but locality and/or GC performance - may be better if they are. Meaningless if :PURIFY is NIL. See PURIFY. - - :ENVIRONMENT-NAME - This is also passed to PURIFY when :PURIFY is T. (rarely used)" + The save/load process changes the values of some global variables: + *STANDARD-OUTPUT*, *DEBUG-IO*, etc. + Everything related to open streams is necessarily changed, since + the OS won't let us preserve a stream across save and load. + *DEFAULT-PATHNAME-DEFAULTS* + This is reinitialized to reflect the working directory where the + saved core is loaded." #!+mp (sb!mp::shutdown-multi-processing) (when (fboundp 'sb!eval:flush-interpreted-function-cache) diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index fe2bd03..bb82e38 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -186,28 +186,37 @@ '(unsigned-byte 8))) (load-as-fasl filespec verbose print) (load-as-source filespec verbose print)) - (let ((pn (merge-pathnames (pathname filespec) - *default-pathname-defaults*))) - (if (wild-pathname-p pn) - (let ((files (directory pn))) + (let (;; FIXME: MERGE-PATHNAMES doesn't work here for + ;; FILESPEC="TEST:Load-Test" and + ;; (LOGICAL-PATHNAME-TRANSLATIONS "TEST") + ;; = (("**;*.*.*" "/foo/bar/**/*.*")). + ;; Physicalizing the pathname before merging + ;; is a workaround, but the ANSI spec talks about + ;; MERGE-PATHNAMES accepting (and returning) + ;; logical pathnames, so a true fix would probably + ;; include fixing MERGE-PATHNAMES, then probably + ;; revisiting this code. + (ppn (physicalize-pathname (pathname filespec)))) + (if (wild-pathname-p ppn) + (let ((files (directory ppn))) #!+high-security (when (null files) (error 'file-error :pathname filespec)) (dolist (file files t) - (internal-load pn + (internal-load ppn file internal-if-does-not-exist verbose print))) - (let ((tn (probe-file pn))) - (if (or tn (pathname-type pn)) - (internal-load pn + (let ((tn (probe-file ppn))) + (if (or tn (pathname-type ppn)) + (internal-load ppn tn internal-if-does-not-exist verbose print) (internal-load-default-type - pn + ppn internal-if-does-not-exist verbose print))))))))) diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index f3dd156..cca3068 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -1198,9 +1198,7 @@ a host-structure or string." values) (defun %enumerate-search-list (pathname function) - (let* ((pathname (if (typep pathname 'logical-pathname) - (translate-logical-pathname pathname) - pathname)) + (let* ((pathname (physicalize-pathname pathname)) (search-list (extract-search-list pathname nil))) (cond ((not search-list) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index b2a99e3..4750013 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -562,24 +562,16 @@ (slot wrapped-stat 'st-uid) (slot wrapped-stat 'st-gid) (slot wrapped-stat 'st-rdev) - ;; FIXME: OpenBSD has a 64-bit st_size slot, which is - ;; basically a good thing, except that it is too - ;; 21st-century for sbcl-0.6.12.8's FFI to handle. As a - ;; quick kludgy workaround, we return a 0 placeholder from - ;; this function, and downstream we stub out the FILE-LENGTH - ;; operation (which is the only place that SBCL actually - ;; uses the SIZE value returned from any UNIX-STAT-ish call). - #!+openbsd 0 - #!-openbsd (slot wrapped-stat 'st-size) + (slot wrapped-stat 'st-size) (slot wrapped-stat 'st-atime) (slot wrapped-stat 'st-mtime) (slot wrapped-stat 'st-ctime) (slot wrapped-stat 'st-blksize) (slot wrapped-stat 'st-blocks))) -;;; Unix system calls in the stat(2) family are implemented as calls -;;; to C-level wrapper functions which copy all the raw "struct -;;; stat" slots into the system-independent wrapped_stat format. +;;; Unix system calls in the stat(2) family are handled by calls to +;;; C-level wrapper functions which copy all the raw "struct stat" +;;; slots into the system-independent wrapped_stat format. ;;; stat(2) <-> stat_wrapper() ;;; fstat(2) <-> fstat_wrapper() ;;; lstat(2) <-> lstat_wrapper() @@ -604,8 +596,8 @@ ;;;; time.h -;; the POSIX.4 structure for a time value. This is like a `struct -;; timeval' but has nanoseconds instead of microseconds. +;; the POSIX.4 structure for a time value. This is like a "struct +;; timeval" but has nanoseconds instead of microseconds. (def-alien-type nil (struct timespec (tv-sec long) ; seconds @@ -617,14 +609,14 @@ (tm-sec int) ; Seconds. [0-60] (1 leap second) (tm-min int) ; Minutes. [0-59] (tm-hour int) ; Hours. [0-23] - (tm-mday int) ; Day. [1-31] - (tm-mon int) ; Month. [0-11] - (tm-year int) ; Year - 1900. - (tm-wday int) ; Day of week. [0-6] - (tm-yday int) ; Days in year.[0-365] - (tm-isdst int) ; DST. [-1/0/1] - (tm-gmtoff long) ; Seconds east of UTC. - (tm-zone c-string))) ; Timezone abbreviation. + (tm-mday int) ; Day. [1-31] + (tm-mon int) ; Month. [0-11] + (tm-year int) ; Year - 1900. + (tm-wday int) ; Day of week. [0-6] + (tm-yday int) ; Days in year. [0-365] + (tm-isdst int) ; DST. [-1/0/1] + (tm-gmtoff long) ; Seconds east of UTC. + (tm-zone c-string))) ; Timezone abbreviation. (def-alien-routine get-timezone sb!c-call:void (when sb!c-call:long :in) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index e359b1a..3f7d8e5 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1605,7 +1605,17 @@ ;;; default to the appropriate implementation-defined default type for ;;; compiled files. (defun cfp-output-file-default (input-file) - (let* ((defaults (merge-pathnames input-file + (let* (;; FIXME: I think the PHYSICALIZE-PATHNAME wrapper here + ;; shouldn't really be necessary. Unfortunately + ;; sbcl-0.6.12.18's MERGE-PATHNAMES doesn't like logical + ;; pathnames very much, and doesn't get good results in + ;; tests/side-effectful-pathnames.sh for (COMPILE-FILE + ;; "TEST:$StudlyCapsStem"), unless I do this. It would be + ;; good to straighten out how MERGE-PATHNAMES is really + ;; supposed to work for logical pathnames, and add a bunch of + ;; test cases to check it, then get rid of this cruft. + (defaults (merge-pathnames (physicalize-pathname (pathname + input-file)) *default-pathname-defaults*)) (retyped (make-pathname :type *backend-fasl-file-type* :defaults defaults))) diff --git a/tests/filesys.pure.lisp b/tests/filesys.pure.lisp index 012bdbf..0356cd5 100644 --- a/tests/filesys.pure.lisp +++ b/tests/filesys.pure.lisp @@ -12,16 +12,17 @@ (in-package "CL-USER") ;;; In sbcl-0.6.9 FOO-NAMESTRING functions returned "" instead of NIL. -(let ((pathname0 (make-pathname :host nil - :directory - (pathname-directory - *default-pathname-defaults*) - :name "getty")) +(let ((pathname0 (make-pathname :host nil + :directory + (pathname-directory + *default-pathname-defaults*) + :name "getty")) (pathname1 (make-pathname :host nil :directory nil :name nil))) (assert (equal (file-namestring pathname0) "getty")) - (assert (equal (directory-namestring pathname0) "")) + (assert (equal (directory-namestring pathname0) + (directory-namestring *default-pathname-defaults*))) (assert (equal (file-namestring pathname1) "")) (assert (equal (directory-namestring pathname1) ""))) diff --git a/tests/side-effectful-pathnames.test.sh b/tests/side-effectful-pathnames.test.sh index 464f075..d5c50fb 100644 --- a/tests/side-effectful-pathnames.test.sh +++ b/tests/side-effectful-pathnames.test.sh @@ -35,6 +35,7 @@ $SBCL <