-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2008, 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"
)package "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
  read_-line $InputStream

-- errorSupervisor is the old style error message trapper

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

errorSupervisor1(errorType,errorMsg,$BreakMode) ==
  BUMPERRORCOUNT "semantic"
  errorLabel :=
      errorType = $SystemError  => '"System error"
      errorType = $UserError    => '"Apparent user error"
      errorType = $AlgebraError =>
        '"Error detected within library code"
      STRINGP errorType         => errorType
      '"Error with unknown classification"
  msg :=
    errorMsg is ['mathprint, :.] => errorMsg
    not PAIRP errorMsg => ['"   ", errorMsg]
    splitmsg := true
    if member('%b,errorMsg) then splitmsg := nil
      else if member('%d,errorMsg) then splitmsg := nil
           else if member('%l,errorMsg) then splitmsg := nil
    splitmsg => CDR [:['%l,'"   ",u] for u in errorMsg]
    ['"   ",:errorMsg]
  sayErrorly(errorLabel, msg)
  handleLispBreakLoop($BreakMode)

handleLispBreakLoop($BreakMode) ==
  TERPRI()
  $BreakMode = 'break =>
    sayBrightly '" "
    BREAK()
  $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]
        BREAK()
      sayBrightly
        '"   Processing will continue where it was interrupted."
      THROW('SPAD__READER, nil)
  $BreakMode = 'resume =>
    returnToReader()
  returnToTopLevel()

TOP() == returnToTopLevel()

returnToTopLevel() ==
  SETQ(CHR, "ENDOFLINECHR")
  SETQ(TOK, 'END__UNIT)
  TOPLEVEL()

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

sayErrorly(errorLabel, msg) ==
  $saturn => saturnSayErrorly(errorLabel, msg)
  sayErrorly1(errorLabel, msg)

saturnSayErrorly(errorLabel, msg) ==
  SETQ($OutputStream, $texOutputStream)
  old := pushSatOutput("line")
  sayString '"\bgroup\color{red}"
  sayString '"\begin{verbatim}"
  sayErrorly1(errorLabel, msg)
  sayString '"\end{verbatim}"
  sayString '"\egroup"
  popSatOutput(old)

sayErrorly1(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()