-- ***************************************************************************** -- $Id: debug_b.m4,v 1.3 1993/12/24 15:09:19 courtel Exp $ -- -- Kind: Package body -- Abstract: Intelligent output of debug informations -- Review: -- Portable: NO -- Short/rename: -- -- Copyright 1990 - 1993 Centre d'Etudes de la Navigation Aerienne (CENA) -- -- PARADISE is free software; you can redistribute it and/or modify it -- under the terms of the GNU Library General Public License -- as published by the Free Software Foundation; -- -- PARADISE is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Library General Public License for more details. -- -- You should have received a copy of the GNU Library General Public License -- along with PARADISE; see the file COPYING.LIB. If not, write to -- the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- ***************************************************************************** changequote([,])dnl changecom(--)dnl -- ***************************************************************************** -- As this package is intended to be used by high level packages, it only calls -- system and library routines. This way, no infinite recursion may ever happen. -- ***************************************************************************** with SYSTEM, C_TYPES, SYSTEM_CALLS, SUBROUTINES; use C_TYPES; -- For pointer comparison package body DEBUG is package C renames C_TYPES; package SYS renames SYSTEM_CALLS; package LIB renames SUBROUTINES; package STR renames LIB.STRING; -- ***************************************************************************** VARIABLE : constant STRING := "PARADISE_DEBUG_MODE" & ASCII.nul; C_VALUE : C.C_STRING; LEN : NATURAL; CURRENT_MODE: MODE_TYPE := ERROR; -- ************************************************************************** function SET_MODE (MODE: MODE_TYPE) return MODE_TYPE is PREVIOUS_MODE: MODE_TYPE := CURRENT_MODE; begin CURRENT_MODE := MODE; return PREVIOUS_MODE; end SET_MODE; -- ************************************************************************** procedure WRITE (MSG: in STRING; MODE: in MODE_TYPE) is begin if CURRENT_MODE >= MODE then declare C_MSG: constant STRING := MSG & ASCII.LF; RVAL: C.SSIZE_T; begin RVAL := C.SSIZE_T (SYS.WRITE (2, C_MSG'address, C.SIZE_T (C_MSG'length))); end; end if; end WRITE; -- ************************************************************************** procedure PRINT (MSG: in STRING) is begin WRITE (MSG, NONE); end PRINT; procedure ERROR (MSG: in STRING) is begin WRITE ("E - " & MSG, ERROR); end ERROR; procedure WARNING (MSG: in STRING) is begin WRITE ("W - " & MSG, WARNING); end WARNING; procedure INFO (MSG: in STRING) is begin WRITE ("I - " & MSG, INFO); end INFO; procedure TASKING (MSG: in STRING) is begin WRITE ("T - " & MSG, TASKING); end TASKING; begin C_VALUE := LIB.PROCESS.GETENV (VARIABLE'address); if C_VALUE /= C.C_NULL_STRING then LEN := NATURAL (STR.LEN (C_VALUE.all'address)); -- Check whether value is a number (0 to 4) if LEN = 1 and then (C_VALUE.all (1) >= '0' and C_VALUE.all (1) <= '4') then CURRENT_MODE := MODE_TYPE'val (INTEGER'value (C_VALUE.all (1 .. 1))); else CURRENT_MODE := MODE_TYPE'value (C_VALUE.all (1 .. LEN)); end if; end if; exception when CONSTRAINT_ERROR => -- invalid mode ERROR ("DEBUG: Invalid mode: " & C_VALUE.all (1 .. LEN)); end DEBUG;