g-error.boot

-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--     - Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--
--     - Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in
--       the documentation and/or other materials provided with the
--       distribution.
--
--     - Neither the name of The Numerical Algorithms Group Ltd. nor the
--       names of its contributors may be used to endorse or promote products
--       derived from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


import diagnostics
import g_-util
namespace BOOT

-- This file contains the error printing code used in BOOT and SPAD.
-- While SPAD only calls "error" (which is then labeled as an algebra
-- error, BOOT calls "userError" and "systemError" when a problem is
-- found.
--
-- The variable $BreakMode is set using the system command )set breakmode
-- and can have one of the values:
--   break    -- always enter a lisp break when an error is signalled
--   nobreak  -- do not enter lisp break mode
--   query    -- ask the user if break mode should be entered

$SystemError == 'SystemError
$UserError == 'UserError
$AlgebraError =='AlgebraError

$ReadingFile := false


-- REDERR is used in BFLOAT LISP, should be a macro
-- REDERR msg == error msg

-- BFLERRMSG func ==
--  errorSupervisor($AlgebraError,strconc(
--    '"BigFloat: invalid argument to ",func))

argumentDataError(argnum, condit, funname) ==
  msg := ['"The test",:bright pred2English condit,'"evaluates to",
    :bright '"false",'"%l",'"   for argument",:bright argnum,_
    '"to the function",:bright funname,'"and this indicates",'"%l",_
    '"   that the argument is not appropriate."]
  errorSupervisor($AlgebraError,msg)

queryUser msg ==
  -- display message and return reply
  sayBrightly msg
  line := readLine $InputStream
  line ~= %nothing => line
  nil

-- errorSupervisor is the old style error message trapper

errorSupervisor(errorType,errorMsg) ==
  errorSupervisor1(errorType,errorMsg,$BreakMode)

needsToSplitMessage msg ==
  member("%b",msg) or member('"%b",msg) => false
  member("%d",msg) or member('"%d",msg) => false
  member("%l",msg) or member('"%l",msg) => false
  true

errorSupervisor1(errorType,errorMsg,$BreakMode) ==
  BUMPERRORCOUNT "semantic"
  errorLabel :=
      errorType = $SystemError  => '"System error"
      errorType = $UserError    => '"Apparent user error"
      errorType = $AlgebraError =>
        '"Error detected within library code"
      string? errorType         => errorType
      '"Error with unknown classification"
  msg :=
    errorMsg is ['mathprint, :.] => errorMsg
    errorMsg isnt [.,:.] => ['"   ", errorMsg]
    needsToSplitMessage errorMsg => rest [:['"%l",'"   ",u] for u in errorMsg]
    ['"   ",:errorMsg]
  sayErrorly(errorLabel, msg)
  handleLispBreakLoop($BreakMode)

enterBreak() ==
  SETQ(_*PRINT_-ARRAY_*,true)
  SETQ(_*PRINT_-CIRCLE_*,true)
  SETQ(_*PRINT_-LENGTH_*,6)
  SETQ(_*PRINT_-READABLY_*,false)
  BREAK()

handleLispBreakLoop($BreakMode) ==
  finishLine $OutputStream
  $BreakMode = 'break =>
    sayBrightly '" "
    enterBreak()
  $BreakMode = 'query =>
    gotIt := nil
    while not gotIt repeat
      gotIt := true
      msgQ := 
       ['"%l",'"   You have three options. Enter:",'"%l",_
        '"    ",:bright '"continue",'"  to continue processing,",'"%l",_
        '"    ",:bright '"top     ",'"  to return to top level, or",'"%l",_
        '"    ",:bright '"break   ",'"  to enter a LISP break loop.",'"%l",_
        '"%l",'"   Please enter your choice now:"]
      x := STRING2ID_-N(queryUser msgQ,1)
      x := selectOptionLC(x,'(top break continue),nil)
      null x =>
        sayBrightly bright '"  That was not one of your choices!"
        gotIt := nil
      x = 'top => returnToTopLevel()
      x = 'break =>
        $BreakMode := 'break
	sayBrightly ['"   Enter",:bright '":C",
	  '"when you are ready to continue processing where you ",'"%l",_
	  '"   interrupted the system, enter",:bright '"(TOP)",_
	  '"when you wish to return",'"%l",'"   to top level.",'"%l",'"%l"]
        enterBreak()
      sayBrightly
        '"   Processing will continue where it was interrupted."
      THROW($SpadReaderTag, nil)
  $BreakMode = 'resume or $ReadingFile =>
    returnToReader()
  returnToTopLevel()

TOP() == returnToTopLevel()

returnToTopLevel() ==
  THROW($intTopLevel,'restart)

returnToReader() ==
  not $ReadingFile => returnToTopLevel()
  sayBrightly ['"   Continuing to read the file...", '"%l"]
  THROW($SpadReaderTag, nil)

sayErrorly(errorLabel, msg) ==
  sayBrightly '" "
  if $testingSystem then sayMSG $testingErrorPrefix
  sayBrightly ['"   >> ",errorLabel,'":"]
  m := msg
  msg is ['mathprint, mathexpr] =>
    mathprint mathexpr
  sayBrightly msg

-- systemError is being phased out. Please use keyedSystemError.
systemError(:x) == 
  errorSupervisor($SystemError,IFCAR x)

-- unexpectedSystemError() ==
--  systemError '"Oh, no.  Unexpected internal error."

userError x == 
  errorSupervisor($UserError,x)

error(x) == 
  errorSupervisor($AlgebraError,x)

IdentityError(op) ==
    error(["No identity element for reduce of empty list using operation",op])

throwMessage(:msg) ==
  if $compilingMap then clearCache $mapName
  msg' := mkMessage concatList msg
  sayMSG msg'
  if $printMsgsToFile then sayMSG2File msg'
  spadThrow()


++ Error handler for Lisp systems that support Common Lisp conditions.
++ We don't want users to get dropped into the Lisp debugger.
systemErrorHandler c ==
  $NeedToSignalSessionManager := true
  $BreakMode = "validate" => 
    systemError ERROR_-FORMAT('"~a",[c])
  not $inLispVM and $BreakMode in '(nobreak query resume) =>
    TYPEP(c,'CONTROL_-ERROR) => keyedSystemError('S2GE0020,nil)
    LET(($inLispVM true)(), systemError ERROR_-FORMAT('"~a",[c]))
  $BreakMode = "letPrint2" =>
    $BreakMode := nil
    THROW("letPrint2",nil)