source: branches/qres/ccl/lib/case-error.lisp @ 14308

Last change on this file since 14308 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 2.5 KB
Line 
1; -*- Mode:Lisp; Package:CCL; -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20;I wanted a read that would not error even when given a #<
21; and also allow backspace and such.
22(defun read-line-no-error (&optional (stream *standard-output*) &aux result)
23  (ignore-errors
24     (setq result (read-from-string (read-line stream) nil))
25     (return-from read-line-no-error (values result t)))
26  (values nil nil))
27
28
29
30;;;; Assert & Check-Type
31
32;;; Assert-Value-Prompt  --  Internal
33;;;
34;;;    Prompt for a new value to set a place to.   We do a read-line,
35;;; and if there is anything there, we eval it and return the second
36;;; value true, otherwise it is false.
37;;;
38(defun assertion-value-prompt (place)
39  (let* ((nvals (length (nth-value 2 (get-setf-method-multiple-value place))))
40         (vals nil))
41    (dotimes (i nvals)
42      (if (eq nvals 1)
43        (format *query-io* "Value for ~S: " place)
44        (format *query-io* "Value ~D for ~S: " i place))
45      (let* ((line (read-line *query-io*))
46             (object  (read-from-string line nil *eof-value*)))
47        (if (eq object *eof-value*)
48            (return)
49            (push (eval object) vals))))
50    (values (nreverse vals) (not (null vals)))))
51
52(defun %assertion-failure (setf-places-p test-form string &rest condition-args)
53  (cerror 
54   (if setf-places-p 
55     "allow some places to be set and test the assertion again."
56     "test the assertion again.")
57   (cond
58    ((stringp string)
59     (make-condition 'simple-error
60                     :format-control string
61                     :format-arguments  condition-args))
62    ((null string)
63     (make-condition 'simple-error
64                     :format-control "Failed assertion: ~S"
65                     :format-arguments (list test-form)))
66    ((typep string 'condition)
67     (when  condition-args (error "No args ~S allowed with a condition ~S"  condition-args string))
68     string)
69    (t (apply #'make-condition string  condition-args)))))
70
Note: See TracBrowser for help on using the repository browser.