From 6fa0ad323b5031017e62ee5d7e016eae2cf79efd Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sun, 6 May 2001 18:37:58 +0000 Subject: [PATCH] 0.6.12.1: MNA dumping-a-logical-host patch sbcl-devel/2001-05-02 MNA catch-init-file-errors patch sbcl-devel/2001-05-03 MNA port of DTC UNREAD-CHAR/CLEAR-INPUT patch for encapsulated streams sbcl-devel/2001-05-03 --- src/code/pathname.lisp | 7 +++++ src/code/stream.lisp | 19 ++++++----- src/code/toplevel.lisp | 68 ++++++++++++++++++++++++++-------------- src/pcl/boot.lisp | 8 ++--- tests/stream.impure-cload.lisp | 62 ++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 130 insertions(+), 36 deletions(-) create mode 100644 tests/stream.impure-cload.lisp diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index 2498723..94a9cfb 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -26,6 +26,7 @@ (customary-case (required-argument) :type (member :upper :lower))) (def!struct (logical-host + (:make-load-form-fun make-logical-host-load-form-fun) (:include host (:parse #'parse-logical-namestring) (:unparse #'unparse-logical-namestring) @@ -44,6 +45,12 @@ (print-unreadable-object (logical-host stream :type t) (prin1 (logical-host-name logical-host) stream))) +;;; What would it mean to dump a logical host and reload it into +;;; another Lisp image? It's not clear, so we don't support it. +(defun make-logical-host-load-form-fun (logical-host) + (error "~@" + logical-host)) + ;;; A PATTERN is a list of entries and wildcards used for pattern ;;; matches of translations. (sb!xc:defstruct (pattern (:constructor make-pattern (pieces))) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 6422ecc..696e65e 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -783,16 +783,19 @@ (in-fun synonym-bin read-byte eof-error-p eof-value) (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-error-p)) -;;; We have to special-case the operations which could look at stuff in -;;; the in-buffer. (defun synonym-misc (stream operation &optional arg1 arg2) (declare (optimize (safety 1))) (let ((syn (symbol-value (synonym-stream-symbol stream)))) (if (lisp-stream-p syn) - (case operation + ;; We have to special-case some operations which interact with + ;; the in-buffer of the wrapped stream, since just calling + ;; LISP-STREAM-MISC on them + (case operation (:listen (or (/= (the fixnum (lisp-stream-in-index syn)) +in-buffer-length+) (funcall (lisp-stream-misc syn) syn :listen))) + (:clear-input (clear-input syn)) + (:unread (unread-char arg1 syn)) (t (funcall (lisp-stream-misc syn) syn operation arg1 arg2))) (stream-misc-dispatch syn operation arg1 arg2)))) @@ -878,10 +881,8 @@ (if out-lisp-stream-p (funcall (lisp-stream-misc out) out operation arg1 arg2) (stream-misc-dispatch out operation arg1 arg2))) - ((:clear-input :unread) - (if in-lisp-stream-p - (funcall (lisp-stream-misc in) in operation arg1 arg2) - (stream-misc-dispatch in operation arg1 arg2))) + (:clear-input (clear-input in)) + (:unread (unread-char arg1 in)) (:element-type (let ((in-type (stream-element-type in)) (out-type (stream-element-type out))) @@ -1001,7 +1002,9 @@ (t ;; Nothing is available yet. (return nil)))))) - (:close + (:clear-input (clear-input current)) + (:unread (unread-char arg1 current)) + (:close (set-closed-flame stream)) (t (if (lisp-stream-p current) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index ce022f2..02504a2 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -291,11 +291,11 @@ (/show0 "entering TOPLEVEL-INIT") - (let ((sysinit nil) ; value of --sysinit option - (userinit nil) ; value of --userinit option - (evals nil) ; values of --eval options (in reverse order) - (noprint nil) ; Has a --noprint option been seen? - (noprogrammer nil) ; Has a --noprogammer option been seen? + (let ((sysinit nil) ; value of --sysinit option + (userinit nil) ; value of --userinit option + (reversed-evals nil) ; values of --eval options, in reverse order + (noprint nil) ; Has a --noprint option been seen? + (noprogrammer nil) ; Has a --noprogammer option been seen? (options (rest *posix-argv*))) ; skipping program name (/show0 "done with outer LET in TOPLEVEL-INIT") @@ -339,7 +339,7 @@ (error "more than one expression in ~S" eval-as-string)) (t - (push eval evals))))))) + (push eval reversed-evals))))))) ((string= option "--noprint") (pop-option) (setf noprint t)) @@ -411,23 +411,45 @@ user-home "/.sbclrc")))) (/show0 "assigned SYSINIT-TRUENAME and USERINIT-TRUENAME") - (when sysinit-truename - (unless (load sysinit-truename) - (error "~S was not successfully loaded." sysinit-truename)) - (flush-standard-output-streams)) - (/show0 "loaded SYSINIT-TRUENAME") - (when userinit-truename - (unless (load userinit-truename) - (error "~S was not successfully loaded." userinit-truename)) - (flush-standard-output-streams)) - (/show0 "loaded USERINIT-TRUENAME")) - - ;; Handle --eval options. - (/show0 "handling --eval options in TOPLEVEL-INIT") - (dolist (eval (reverse evals)) - (/show0 "handling one --eval option in TOPLEVEL-INIT") - (eval eval) - (flush-standard-output-streams)) + + + ;; We wrap all the pre-REPL user/system customized startup code + ;; in a restart. + ;; + ;; (Why not wrap everything, even the stuff above, in this + ;; restart? Errors above here are basically command line or + ;; Unix environment errors, e.g. a missing file or a typo on + ;; the Unix command line, and you don't need to get into Lisp + ;; to debug them, you should just start over and do it right + ;; at the Unix level. Errors below here are usually errors in + ;; user Lisp code, and it might be helpful to let the user + ;; reach the REPL in order to help figure out what's going on.) + (restart-case + (flet ((process-init-file (truename) + (when truename + (unless (load truename) + (error "~S was not successfully loaded." truename)) + (flush-standard-output-streams)))) + (process-init-file sysinit-truename) + (process-init-file userinit-truename) + + ;; Process --eval options. + (/show0 "handling --eval options in TOPLEVEL-INIT") + (dolist (eval (reverse reversed-evals)) + (/show0 "handling one --eval option in TOPLEVEL-INIT") + (eval eval) + (flush-standard-output-streams))) + (continue () + :report "Continue anyway (skipping to toplevel read/eval/print loop)." + (values)) ; (no-op, just fall through) + (quit () + :report "Quit SBCL (calling #'QUIT, killing the process)." + (quit)))) + + ;; one more time for good measure, in case we fell out of the + ;; RESTART-CASE above before one of the flushes in the ordinary + ;; flow of control had a chance to operate + (flush-standard-output-streams) (/show0 "falling into TOPLEVEL-REPL from TOPLEVEL-INIT") (toplevel-repl noprint)))) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 9249bde..1152cec 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -1537,7 +1537,7 @@ bootstrapping. method gf (apply #'format nil string args))) - (compare (x y) + (comparison-description (x y) (if (> x y) "more" "fewer"))) (let ((gf-nreq (arg-info-number-required arg-info)) (gf-nopt (arg-info-number-optional arg-info)) @@ -1546,11 +1546,11 @@ bootstrapping. (unless (= nreq gf-nreq) (lose "the method has ~A required arguments than the generic function." - (compare nreq gf-nreq))) + (comparison-description nreq gf-nreq))) (unless (= nopt gf-nopt) (lose - "the method has ~S optional arguments than the generic function." - (compare nopt gf-nopt))) + "the method has ~A optional arguments than the generic function." + (comparison-description nopt gf-nopt))) (unless (eq (or keysp restp) gf-key/rest-p) (error "The method and generic function differ in whether they accept~%~ diff --git a/tests/stream.impure-cload.lisp b/tests/stream.impure-cload.lisp new file mode 100644 index 0000000..0075908 --- /dev/null +++ b/tests/stream.impure-cload.lisp @@ -0,0 +1,62 @@ +;;;; tests related to Lisp streams + +;;;; 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. + +(in-package :cl-user) + +;;; The unread and clear-input functions on input streams need to +;;; sneak past the old CMU CL encapsulation. As explained by DTC in +;;; the checkin message for his CMU CL patch ca. April 2001, +;;; These streams encapsulate other input streams which may +;;; have an input buffer so they need to call unread-char +;;; and clear-input on the encapsulated stream rather than +;;; directly calling the encapsulated streams misc method +;;; as the misc methods are below the layer of the input buffer. +;;; +;;; The code below tests only UNREAD-CHAR. It would be nice to test +;;; CLEAR-INPUT too, but I'm not sure how to do it cleanly and +;;; portably in a noninteractive test. -- WHN 2001-05-05 +(defparameter *scratch-file-name* "sbcl-wrapped-stream-test-data.tmp") +(defvar *scratch-file-stream*) +(dolist (scratch-file-length '(1 ; everyone's favorite corner case + 200123)) ; hopefully much bigger than buffer + (format t "/SCRATCH-FILE-LENGTH=~D~%" scratch-file-length) + (with-open-file (s *scratch-file-name* :direction :output) + (dotimes (i scratch-file-length) + (write-char #\x s))) + (dolist (wrap-named-stream-fn + ;; All kinds of wrapped input streams have the same issue. + (list (lambda (wrapped-stream-name) + (make-synonym-stream wrapped-stream-name)) + (lambda (wrapped-stream-name) + (make-two-way-stream (symbol-value wrapped-stream-name) + *standard-output*)) + (lambda (wrapped-stream-name) + (make-concatenated-stream (symbol-value wrapped-stream-name) + (make-string-input-stream ""))))) + (format t "/WRAP-NAMED-STREAM-FN=~S~%" wrap-named-stream-fn) + (with-open-file (*scratch-file-stream* *scratch-file-name* + :direction :input) + (let ((ss (funcall wrap-named-stream-fn '*scratch-file-stream*))) + (flet ((expect (thing-expected) + (let ((thing-found (read-char ss nil nil))) + (unless (eql thing-found thing-expected) + (error "expected ~S, found ~S" + thing-expected thing-found))))) + (dotimes (i scratch-file-length) + (expect #\x) + (unread-char #\y ss) + (expect #\y) + (unread-char #\z ss) + (expect #\z)) + (expect nil))))) ; i.e. end of file + (delete-file *scratch-file-name*)) diff --git a/version.lisp-expr b/version.lisp-expr index 53ff3dd..1f4af4f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; 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" +"0.6.12.1" -- 1.7.10.4