home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 7 / 07.iso / c / c221 / 5.ddi / MWHC.005 / 34 < prev    next >
Encoding:
Text File  |  1992-12-09  |  2.1 KB  |  78 lines
  1. {*********************************************************************
  2. (C) Copyright 1983-1992; MetaWare Incorporated;  Santa Cruz, CA 95060.
  3. *********************************************************************}
  4. pragma on(Optimize_for_space);
  5. Export(Here);
  6. pragma include('system.pf');
  7. pragma include('lineterm.pf');
  8. pragma C_include('Implement.pf');
  9. pragma C_include('Interrupts.pf');
  10. pragma C_include('Portio.pf');
  11. package Here;
  12.    pragma Routine_aliasing_convention(Implement.RTE_aliasing);
  13.    procedure Display(const S:string); external;
  14.    procedure Pascal_abort(const Msg:String; RC:Integer); external;
  15.    pragma Alias(Pascal_abort,Implement.RTE || 'abort');
  16.    procedure Stack_overflow;    External;
  17.    procedure Stkerr;        External;
  18.    end;
  19. with Loopholes:[Adr,Retype,Longptr,Sizeof,Address,Pointer_arithmetic];
  20. package Elsewhere;
  21.    pragma Routine_aliasing_convention(Implement.RTE_aliasing);
  22.    procedure FTERM; external;
  23.    procedure CFTERM; external;
  24.    procedure Restore_interrupts;External;
  25.    end;
  26.  
  27. -- Imports:
  28. with Lineterm,Elsewhere,Interrupts,Portio;
  29. pragma Off(With_warnings);
  30. with System;
  31. pragma Pop(With_warnings);
  32.  
  33. program Implement_term;
  34. pragma Alias(Implement_term,Implement.RTE || 'term2');
  35.  
  36. pragma off(Emit_names);
  37.  
  38. { Termination procedures & write to terminal on error.            }
  39.  
  40. procedure Display;
  41.    begin
  42.    Write(System_stderr,Adr(S[1]),Length(S));
  43.    Write(System_stderr,Adr(Ltconv_out[1]),Length(LTconv_out));
  44.    end;
  45.  
  46. var _Retcode: 0..255;
  47. value _Retcode := 0;
  48.  
  49. -- Routines called from ints.p.
  50.  
  51. procedure Pascal_abort;
  52.    begin
  53.    Display(Msg);
  54.    Display('***Program aborted.***');
  55. #ifndef DAISY
  56.    FTERM; CFTERM;
  57. #ifndef CDOS   
  58.    Restore_interrupts;
  59. #endif   
  60. #endif
  61.    Dos_exit(_Retcode);
  62.    end;
  63.  
  64. procedure Stkerr;
  65.    begin
  66.    Display('***STACK/HEAP OVERFLOW***');
  67.    end;
  68.  
  69. procedure Stack_overflow;
  70.    begin
  71.    Stkerr();
  72.    Fstackdump(Stderr);
  73.    Halt(-3);
  74.    end;
  75.  
  76. { (C) Copyright 1983-1985;  unpublished property and trade secret of }
  77. { MetaWare Incorporated; Santa Cruz, CA 95060; detailed notice above.}
  78.