(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)
(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 "~@<A logical host can't be dumped as a constant: ~2I~_~S~:>"
+ 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)))
(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))))
(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)))
(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)
(/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")
(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))
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))))
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))
(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~%~
--- /dev/null
+;;;; 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*))
;;; 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"
projects / sbcl.git / commitdiff