1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32)package "BOOT"
33
34-- This file contains the error printing code used in BOOT and SPAD.
35-- While SPAD only calls "error" (which is then labeled as an algebra
36-- error, BOOT calls "userError" and "systemError" when a problem is
37-- found.
38--
39-- The variable $BreakMode is set using the system command )set breakmode
40-- and can have one of the values:
41--   break    -- always enter a lisp break when an error is signalled
42--   nobreak  -- do not enter lisp break mode
43--   query    -- ask the user if break mode should be entered
44--   quit     -- quit on error with exit status 1
45
46DEFPARAMETER($SystemError, 'SystemError)
47DEFPARAMETER($UserError, 'UserError)
48DEFPARAMETER($AlgebraError, 'AlgebraError)
49
50DEFVAR($timedNameStack)
51
52BUMPCOMPERRORCOUNT() == nil
53
54argumentDataError(argnum, condit, funname) ==
55  msg := ['"The test",:bright pred2English condit,'"evaluates to",
56    :bright '"false",'%l,'"   for argument",:bright argnum,_
57    '"to the function",:bright funname,'"and this indicates",'%l,_
58    '"   that the argument is not appropriate."]
59  errorSupervisor($AlgebraError,msg)
60
61queryUser msg ==
62  -- display message and return reply
63  sayBrightly msg
64  read_line _*TERMINAL_-IO_*
65
66-- errorSupervisor is the old style error message trapper
67
68errorSupervisor(errorType,errorMsg) ==
69  $BreakMode = 'trapSpadErrors => THROW('trapSpadErrors, $numericFailure)
70  errorSupervisor1(errorType,errorMsg,$BreakMode)
71
72errorSupervisor1(errorType,errorMsg,$BreakMode) ==
73  BUMPCOMPERRORCOUNT()
74  errorLabel :=
75      errorType = $SystemError  => '"System error"
76      errorType = $UserError    => '"Apparent user error"
77      errorType = $AlgebraError =>
78        '"Error detected within library code"
79      STRINGP errorType         => errorType
80      '"Error with unknown classification"
81  msg :=
82    errorMsg is ['mathprint, :.] => errorMsg
83    not PAIRP errorMsg => ['"   ", errorMsg]
84    splitmsg := true
85    if member('%b,errorMsg) then splitmsg := nil
86      else if member('%d,errorMsg) then splitmsg := nil
87           else if member('%l,errorMsg) then splitmsg := nil
88    splitmsg => rest [:['%l, '"   ", u] for u in errorMsg]
89    ['"   ",:errorMsg]
90  sayErrorly(errorLabel, msg)
91  handleLispBreakLoop($BreakMode)
92
93handleLispBreakLoop($BreakMode) ==
94  TERPRI()
95  -- The next line is to try to deal with some reported cases of unwanted
96  -- backtraces appearing, MCD.
97  ENABLE_BACKTRACE(nil)
98  $BreakMode = 'break =>
99    sayBrightly '" "
100    BREAK()
101  $BreakMode = 'query =>
102    gotIt := nil
103    while not gotIt repeat
104      gotIt := true
105      msgQ :=
106       ['%l,'"   You have three options. Enter:",'%l,_
107        '"    ",:bright '"continue",'"  to continue processing,",'%l,_
108        '"    ",:bright '"top     ",'"  to return to top level, or",'%l,_
109        '"    ",:bright '"break   ",'"  to enter a LISP break loop.",'%l,_
110        '%l,'"   Please enter your choice now:"]
111      x := STRING2ID_N(queryUser(msgQ), 1)
112      x :=
113        selectOptionLC(x,'(top break continue),NIL)
114      null x =>
115        sayBrightly bright '"  That was not one of your choices!"
116        gotIt := NIL
117      x = 'top => returnToTopLevel()
118      x = 'break =>
119        $BreakMode := 'break
120        sayBrightly ['"   Enter",:bright '":C",
121            '"when you are ready to continue processing where you ",'%l,_
122            '"   interrupted the system, enter",:bright '"(TOP)",_
123            '"when you wish to return",'%l,'"   to top level.",'%l,'%l]
124        BREAK()
125      sayBrightly
126        '"   Processing will continue where it was interrupted."
127      THROW('SPAD_READER, nil)
128  $BreakMode = 'resume =>
129    returnToReader()
130  $BreakMode = 'throw_reader => THROW('SPAD_READER, nil)
131  $BreakMode = 'quit =>
132    EXIT_-WITH_-STATUS(1)
133  returnToTopLevel()
134
135TOP() == returnToTopLevel()
136
137returnToTopLevel() ==
138  SETQ(CHR, "ENDOFLINECHR")
139  SETQ(TOK, 'END_UNIT)
140  TOPLEVEL()
141
142TOPLEVEL() ==
143    THROW('top_level, 'restart)
144
145returnToReader() ==
146  not $ReadingFile => returnToTopLevel()
147  sayBrightly ['"   Continuing to read the file...", '%l]
148  THROW('SPAD_READER, nil)
149
150sayErrorly(errorLabel, msg) ==
151  sayErrorly1(errorLabel, msg)
152
153sayErrorly1(errorLabel, msg) ==
154  sayBrightly '" "
155  if $testingSystem then sayMSG $testingErrorPrefix
156  sayBrightly ['"   >> ",errorLabel,'":"]
157  m := msg
158  msg is ['mathprint, mathexpr] =>
159    mathprint mathexpr
160  sayBrightly msg
161
162-- systemError is being phased out. Please use keyedSystemError.
163systemError(x) == errorSupervisor($SystemError, x)
164
165userError x == errorSupervisor($UserError,x)
166
167error(x) == errorSupervisor($AlgebraError,x)
168
169nice_failure_msg(val, branch, umode) ==
170    uname := devaluate(umode)
171    of1 := coerceUn2E(val, uname);
172    str1 := prefix2String(of1);
173    STRCONC(str1,
174            '" of mode ", outputDomainConstructor(umode),
175              '" cannot be coerced to mode ",
176                outputDomainConstructor(branch))
177
178check_union_failure_msg(val, branch, umode) ==
179    got_str1 := false
180    CATCH('top_level, CATCH('SPAD_READER, (
181           str1 := nice_failure_msg(val, branch, umode);
182           got_str1 := true)))
183    got_str1 => str1
184    str1 := MAKE_REASONABLE(STRINGIMAGE(val))
185    STRCONC(str1,
186            '" of mode ", STRINGIMAGE(devaluate(umode)),
187              '" cannot be coerced to mode ",
188                STRINGIMAGE(devaluate(branch)))
189
190coerce_failure_msg(val, submode, mode) ==
191    check_union_failure_msg(val, submode, mode)
192
193IdentityError(op) ==
194    error(["No identity element for reduce of empty list using operation",op])
195
196throwMessage(:msg) ==
197  if $compilingMap then clearCache $mapName
198  msg' := mkMessage concatList msg
199  sayMSG msg'
200  if $printMsgsToFile then sayMSG2File msg'
201  spadThrow()
202