Crawly Crypt Collection 2/crawlyvol2.bin/program/pascal/pascalm/pascalm.pas

Pascal/Delphi Source File | 1988-05-01 | 68.2 KB | 2,176 lines

{$S40,P+,T+}
PROGRAM Pas_Main ;

(* Program:     PASCALM.PAS
   By:          Jinfu Chen, based on OSS' PASCAL 1.x source code
   Rev:         0.93, 1/1/88, Enhancements added 4/88 by Phillip R. Poulos
*)

(*$I auxsubs.pas*)

  CONST
    {$I gemconst.pas}
    {$I pascalm.i}          (* resource file definition *)
    max_option = 30 ;       (* Maximum number of options in one dialog *)
    chunk = 10240 ;         (* size to be copy at one time *)
    HIDE = TRUE;            (* just name them for the ease of reading *)
    NOHIDE = FALSE;
    GEM_O = 1 ;
    TOS_O = 2 ;
    TTP_O = 3 ;
    ACC_O = 4 ;
    console=2 ;
    bell=7 ;
    BEG_Mctrl = 3 ;     {Mouse Control constants to try to stop MENU foulups}
    END_Mctrl = 2 ;
    LA_Intin  = 8 ;

  TYPE
    opt_range = 1..max_option ;
    opt_array = PACKED ARRAY [ opt_range ] OF Boolean ;
    environment = C_String ;
    env_ptr = ^environment ;
    buf_type = PACKED ARRAY [1..chunk] OF BYTE ;
    drive_array = PACKED ARRAY[1..4] OF Long_Integer ;
    time_buf = ARRAY[1..2] OF Integer ;
    C_Path_Type = PACKED ARRAY [1..80] OF CHAR ;
    DTA = PACKED RECORD                 {DTA record format for GEMDOS stuff}
        rsvd   : PACKED ARRAY[0..19] OF BYTE ;
        rsvd2  : BYTE ;
        attrib : BYTE ;
        time   : Integer ;
        date   : Integer ;
        size   : Long_Integer ;
        name   : C_Path_Type ;
      END ;
    Object = RECORD             {GEM Object record definition}
        ob_next    : Integer ;
        ob_head    : Integer ;
        ob_tail    : Integer ;
        ob_type    : Integer ;
        ob_flags   : Integer ;
        ob_state   : Integer ;
        ob_spec    : Long_Integer ;
        ob_x       : Integer ;
        ob_y       : Integer ;
        ob_width   : Integer ;
        ob_height  : Integer ;
      END ;
    Tree = ARRAY[0..100] OF Object ; {Yes, a Tree is an array of OBJECTS}
    Dialog_Ptr = ^Tree ; {The correct and USEFUL redefinition of a Dialog Ptr}
    Average_Array = ARRAY[0..500] of Integer;
    Aver_Array_Ptr = ^AVERAGE_ARRAY;

    {$I gemtype.pas}

  VAR
    envp : env_ptr ;
    rez  : integer ;                (* screen resolution *)
    menu : Menu_Ptr ;
    info_x,
    info_y,
    info_w,
    info_h,
    dummy : integer ;
    for_gem : Integer ;        (* 1 for gem, 2 for tos, 3 for acc *)
    cmp_opts : opt_array ;
    Prog_DTA : DTA ;
    bad_res,
    temp_path,
    backup_path,
    addl_files,
    addl_libs : Str255 ;
    work_path,                  (* path for FILE menu *)
    file_path1,                  (* path for SPECIALS menu *)
    file_path2,                  (* path for SPECIALS menu *)
    def_path,
    compiler_name,
    linker_name,
    editor_name,
    paslib_name,
    pasgem_name,
    printer_name,
    src_name,                   (* source filename for COPY *)
    des_name,                   (* destination filename for COPY *)
    cmp_name,
    link_name,
    edit_name,                  {Notice separate paths for EDIT file}
    compile_name,               {  and COMPILE file}
    run_name : Path_Name ;
    info_dial : Dialog_Ptr ;
    Intin : Aver_Array_Ptr;


  {$I gemsubs.pas}

FUNCTION Ptr( where : long_integer ) : Aver_Array_Ptr ;
  External;


PROCEDURE Obj_Size( dial : dialog_ptr ; Root : integer ;
  VAR x, y, w, h: integer ) ;   {Returns an OBJECT's size; however boxes}
  EXTERNAL ;                    {are frequently sized too SMALL by GEM}


PROCEDURE Obj_Draw( dial : dialog_ptr ; start,depth,x,y,w,h:integer) ;
  EXTERNAL;                {Needed to draw only a part of a Object Tree}


PROCEDURE FORM_DIAL(flag,x_sm,y_sm,w_sm,h_sm,x_lg,y_lg,w_lg,
                   h_lg:integer) ;
  EXTERNAL;


PROCEDURE Grow_Shrink( cmd, small_x, small_y, small_w, small_h,
                        big_x, big_y, big_w, big_h : integer ) ;
  VAR
    int_in   : Int_In_Parms ;
    int_out  : Int_Out_Parms ;
    addr_in  : Addr_In_Parms ;
    addr_out : Addr_Out_Parms ;
  BEGIN
    int_in[0] := small_x ;
    int_in[1] := small_y ;
    int_in[2] := small_w ;
    int_in[3] := small_h ;
    int_in[4] := big_x ;
    int_in[5] := big_y ;
    int_in[6] := big_w ;
    int_in[7] := big_h ;
    AES_Call( cmd, int_in, int_out, addr_in, addr_out ) ;
    END ;


PROCEDURE Grow_Box( s_x, s_y, s_w, s_h,
                      b_x, b_y, b_w, b_h : integer ) ;
  BEGIN
      Grow_Shrink( 73, s_x, s_y, s_w, s_h, b_x, b_y, b_w, b_h ) ;
    END ;


PROCEDURE Shrink_Box( big_x, big_y, big_w, big_h,
                        small_x, small_y, small_w, small_h : integer ) ;
  BEGIN
    Grow_Shrink( 74, small_x, small_y, small_w, small_h,
              big_x, big_y, big_w, big_h ) ;
  END ;


PROCEDURE WIND_Update ( ctrl : Integer ) ; {Use this call for MOUSE control}
VAR
  int_in   : Int_In_Parms ;
  int_out  : Int_Out_Parms ;
  addr_in  : Addr_In_Parms ;
  addr_out : Addr_Out_Parms ;
BEGIN
  int_in[0] := ctrl ;
  AES_Call( 107, int_in, int_out, addr_in, addr_out ) ;
END ;


{  Returns address of LINEA variables  }
FUNCTION Linea_init : Long_integer;
  External;


{  LineA Show Mouse Routine  }
Procedure Linea_Showms;
  External;


FUNCTION Dsetdrv( drive : INTEGER ) : Long_INTEGER ; (* Set Default Drive *)
  GEMDOS($0E) ;


FUNCTION Dgetdrv : integer ; {Get Default Drive}
  GEMDOS( $19 ) ;

FUNCTION FCreate( VAR fname : C_Path_Type ; mode : INTEGER ) : INTEGER ;
  GEMDOS( $3C ) ;

PROCEDURE Dfree( VAR buf : DRIVE_ARRAY ; driveno : INTEGER ) ;
  GEMDOS($36) ;
(* Get Drive Free Space *)
(* Some Information :
  buf[1] : number of free clusters ;
  buf[2] : total number of clusters ;
  buf[3] : sector size in bytes ;
  buf[4] : cluster size in bytes.
*)

FUNCTION Mkdir( VAR Folder : C_Path_Type) : Integer ;
  GEMDOS( $39 ) ;               {Make a new directory or folder}

FUNCTION DDelete( VAR pathname : C_Path_Type ) : INTEGER ;
  GEMDOS( $3A ) ;
(* Delete Directory *)

FUNCTION FOpen( VAR fname : C_Path_Type ; mode : INTEGER ) : INTEGER ;
  GEMDOS( $3D ) ;

PROCEDURE FClose( fhandle : INTEGER ) ;
  GEMDOS( $3E ) ;

FUNCTION FRead( fhandle : INTEGER ; n_bytes : Long_INTEGER ;
                 VAR buf : buf_type ) : Long_Integer ;
  GEMDOS( $3F ) ;

FUNCTION FWrite( fhandle : INTEGER ; n_bytes : Long_INTEGER ;
                 VAR buf : buf_type ) : Long_Integer ;
  GEMDOS( $40 ) ;

FUNCTION FDelete( VAR fname : C_Path_Type ) : INTEGER ;
  GEMDOS( $41 ) ;
(* Delete File *)

PROCEDURE Dgetpath( VAR path_buf : C_Path_Type ; drive : integer ) ;
  GEMDOS( $47 ) ;       {Get current file path}

FUNCTION Dsetpath( VAR path_buf : C_Path_Type ) : Integer ;
  GEMDOS( $3B ) ;       {Set new default path}

FUNCTION FRename( zero : INTEGER; VAR oldname,
                  newname : C_Path_TYPE ) : INTEGER ;
  GEMDOS( $56 ) ;
(* Rename File *)

FUNCTION SFirst( VAR fn : C_Path_Type ; attribute : Integer ) : Integer ;
  GEMDOS( $4E ) ;       {Get first file name match in current directory}

FUNCTION SNext : Integer ; {Get NEXT file name match in current path}
  GEMDOS( $4F ) ;

FUNCTION Chmod( VAR Fname : C_Path_Type ; mode, attribute : Integer ) : Integer ;
  GEMDOS( $43 ) ;       {Change attributes of file - used to make write}
                        {enabled}
PROCEDURE SetDTA( VAR DTA_Buf : DTA ) ;
  GEMDOS( $1A ) ;       {Set up our own DTA area for GEMDOS to use}

PROCEDURE FDaTime( VAR buf : time_buf ; handle, flag : Integer ) ;
  GEMDOS( $57 ) ;       {Get or Set File Date/Time Stamp}

FUNCTION get_rez : integer ;
  XBIOS( 4 ) ;

PROCEDURE bconin( dev : integer ) ;     (* Really a function! *)
  BIOS( 2 ) ;

PROCEDURE bconout( dev, c : integer ) ;
  BIOS( 3 ) ;


PROCEDURE P_To_CPath( VAR P_Path : Path_Name ; VAR C_Path : C_Path_Type ) ;
(* convert Pascal string to C string, the built-in routines only work for
   long string *)
VAR
  len,
  i     : INTEGER;
BEGIN
  len := Length( p_path ) ;
  FOR i := 1 TO len DO c_path[i] := p_path[i] ;
  c_path[ len + 1 ] := chr(0) ;
END ;


PROCEDURE C_To_PPath( VAR C_Path : C_Path_Type ; VAR P_Path : Path_Name ) ;
(* convert C string to Pascal string *)
VAR
  i     : INTEGER;
BEGIN
  i := 1 ;
  While (C_Path[i] <> CHR(0)) AND (C_Path[i] <> ' ') AND ( i <= 80 ) DO BEGIN
    P_Path[i] := C_Path[i] ;
    i := i + 1 ;
  END ;
  P_Path[0] := Chr( i - 1 ) ;
END ;


PROCEDURE IO_Error( err : Integer ) ;
{Display I/O error in alert box}
VAR err_str : Str255 ;
    c1 : Integer ;
BEGIN
  IF err <> 0 THEN
    BEGIN
      CASE err OF
        -1  : err_str := 'TOS system error' ;
        -2  : err_str := 'Drive not ready' ;
        -3  : err_str := 'Unknown error' ;
        -4  : err_str := 'CRC error' ;
        -5  : err_str := 'Bad request' ;
        -6  : err_str := 'Drive seek error' ;
        -7  : err_str := 'Unknown media' ;
        -8  : err_str := 'Drive sector not found' ;
        -9  : err_str := 'No paper' ;
        -10 : err_str := 'Drive write fault' ;
        -11 : err_str := 'Drive read fault' ;
        -12 : err_str := 'General error' ;
        -13 : err_str := 'Drive write protect' ;
        -14 : err_str := 'Drive media change' ;
        -15 : err_str := 'Unknown device' ;
        -16 : err_str := 'Bad sectors on format' ;
        -17 : err_str := 'Disk change' ;
        -18 : err_str := 'Disk Full' ;
        -32 : err_str := 'Invalid function number' ;
        -33 : err_str := 'File not found' ;
        -34 : err_str := 'Path not found' ;
        -35 : err_str := 'Too many open files' ;
        -36 : err_str := 'Access not possible' ;
        -37 : err_str := 'Cannot copy, rename, or|move file to self' ;
        -38 : err_str := 'Cannot rename or move|to/from null string' ;
        -39 : err_str := 'Insufficient memory' ;
        -40 : err_str := 'Invalid memory block address' ;
        -46 : err_str := 'Invalid drive' ;
        -49 : err_str := 'No more files' ;
        -64 : err_str := 'Range error' ;
        -65 : err_str := 'Internal error' ;
        -66 : err_str := 'Invalid program load format' ;
        -67 : err_str := 'Setblock failure ' ;
        OTHERWISE : WriteV( err_str, 'I/O error #', err ) ;
      END ;
      err_str := Concat( '[3][ |', err_str, '][ OK ]' ) ;
      bconout( console, bell ) ;
      c1 := Do_Alert( err_str, 1 ) ;
    END ;
END ;


PROCEDURE Redraw_Screen ;
{Redraw screen by forcing a redraw message to GEM}
VAR
  x, y, w, h : integer;
BEGIN
  Work_Rect( 0, x, y, w, h ) ;
  Form_Dial( 3, 0, 0, 0, 0, x, y, w, h ) ;  (* a dirty and quick way *)
END ;


FUNCTION Is_Gem_Name( fname : Path_Name ) : boolean ;
(* check if the program is a GEM program *)
VAR
  i : integer ;
BEGIN
  Is_Gem_Name := false ;
  IF length( fname ) > 3 THEN  BEGIN
    i := length( fname ) - 3 ;
    IF ( fname[i]='.') AND (fname[i+1]='P') AND (fname[i+2]='R')
      AND (fname[i+3]='G') THEN
        Is_Gem_name := true ;
  END
END ;


FUNCTION Is_TTP_Name( fname : Path_Name ) : boolean ;
(* check if the program is a TTP program *)
VAR
  i : integer ;
BEGIN
  Is_TTP_Name := false ;
  IF length( fname ) > 3 THEN  BEGIN
    i := length( fname ) - 3 ;
    IF ( fname[i]='.') AND (fname[i+1]='T') AND (fname[i+2]='T')
      AND (fname[i+3]='P') THEN
        Is_TTP_name := true ;
  END
END ;


PROCEDURE Strip_Filename( VAR Pth, fn : Path_Name ) ;
{Strip_Filename - Remove the File Name/Extension from a Path_Name variable.}
{also process input path to remove redundant characters}
  VAR
    i : integer ;
    done : boolean ;
  BEGIN
    i := Length( pth ) ;
    fn := '' ;
    IF i=0 THEN done := TRUE
    ELSE done := FALSE ;
    WHILE NOT done DO
      BEGIN
        IF i < 1 THEN
          BEGIN
            fn := pth ;
            pth := '' ;
            done := true ;
          END
        ELSE IF pth[i] = '\' THEN
          BEGIN
            IF (pth[i-1]='\') AND (i>1) THEN
              BEGIN
                Delete( pth, i, 1 ) ;
                i := i - 1 ;
              END
            ELSE
              BEGIN
                fn := Copy( pth, i+1, length(pth)-i ) ;
                pth[0] := chr(i) ;
                done := true ;
              END ;
          END
        ELSE IF pth[i] = ':' THEN
          BEGIN
            fn := Copy( pth, i+1, length(pth)-i ) ;
            pth[0] := chr(i) ;
            done := true ;
          END
        ELSE
          i := i - 1 ;
      END ;
    i := Length(pth) ;
    IF i>1 THEN
      REPEAT
        IF (pth[i]='\') AND (pth[i-1]='\') THEN Delete( pth, i, 1 ) ;
        i := i - 1 ;
      UNTIL i<2 ;
  END ;


PROCEDURE SetupFName( VAR Src, Des : Path_Name ; AddPeriod : Boolean ) ;
{Setup File Name to be displayed in conflict dialog box}
VAR i,
    j : Integer ;
BEGIN
  des := '            ' ;
  i := 1 ;
  j := 1 ;
  IF Length(Src)>0 THEN
    BEGIN
      REPEAT
        Des[j] := Src[i] ;
        i := i + 1 ;
        j := j + 1 ;
      UNTIL (Src[i]='.') OR (i>Length(Src)) ;
      i := i + 1 ;
      IF i <= Length(Src) THEN
        BEGIN
          IF AddPeriod THEN
            BEGIN
              des[9] := '.' ;
              j := 10 ;
            END
          ELSE j := 9 ;
          REPEAT
            Des[j] := Src[i] ;
            i := i + 1 ;
            j := j + 1 ;
          UNTIL i>Length(Src) ;
        END ;
      IF j>8 THEN des[0] := Chr(j-1) ;
    END ;
END ;


FUNCTION Get_CMD( fname : Path_Name; VAR  cmd_line : Str255 ) : BOOLEAN ;
(* get the command line for TTP program, the box looks exactly the same as
   the one in DESKTOP *)
VAR
  i : integer ;
  btn : Integer ;
  t_box : Dialog_Ptr ;
  name : Path_Name ;
BEGIN
  cmd_line[0] := chr(0) ;              (* zero length the cmd_line *)
  Get_CMD := TRUE ;
  Find_Dialog( TTPBOX, t_box ) ;
  Center_Dialog( t_box ) ;
  Strip_Filename( fname, name ) ;
  fname := name ;
  SetupFName( fname, name, TRUE ) ;
  Set_DText( t_box, TTPNAME, name, System_Font, TE_LEFT ) ;
  Set_DText( t_box, CMDLINE, cmd_line, System_Font, TE_LEFT ) ;
  btn := Do_Dialog( t_box, CMDLINE ) ;
  Obj_SetState( t_box, btn, NORMAL, TRUE ) ;
  IF btn = TTPCAN THEN
    Get_CMD := FALSE ;
  Get_DEdit( t_box, CMDLINE, cmd_line ) ;
  End_Dialog( t_box ) ;
END ;


PROCEDURE Wait(waittime : Long_Integer);
(* just wait for  n seconds. Note that TOS clock is in 2 second interval *)
VAR
  starttime : Long_Integer;
BEGIN
  starttime := Clock;
  WHILE ((Clock - starttime) < waittime ) DO
    ;
END;


{$P-}

PROCEDURE info_msg( msg : String ) ;
{Display title in BOX over File Selector Box}
BEGIN
  Find_Dialog(LOCATION, info_dial);
  Center_Dialog( info_dial ) ;
  Obj_Size( info_dial, ROOT, info_x, info_y, info_w, info_h ) ;
  info_y := 12 * rez ;
  info_dial^[0].ob_y := info_y ;   {Change y position of parent object after}
  info_x := info_x - 5 ;           {object centered, then widen out clip}
  info_y := info_y - 5 ;           {rectangle before display}
  info_w := info_w + 20 ;
  info_h := info_h + 20 ;
  Set_DText( info_dial, INFONAME, msg, System_Font, TE_CENTER ) ;
  Obj_Draw( info_dial, ROOT, max_depth, info_x, info_y, info_w, info_h ) ;
END ;

{$P=}


PROCEDURE EraseInfo ;
BEGIN
  Form_Dial( 3, 0, 0, 0, 0, info_x, info_y, info_w, info_h ) ;
END ;


PROCEDURE formdo(index : INTEGER; hide : BOOLEAN) ;
{Displays beginning information about program}
VAR
  x, y, w, h    : Integer ;
  dia_obj       : Dialog_Ptr;
BEGIN (* formdo *)
  Find_Dialog(index, dia_obj);
  Center_Dialog(dia_obj);
  Obj_Size(dia_obj, Root, x, y, w, h ) ;
  x := x - 5 ;
  y := y - 5 ;
  w := w + 10 ;
  h := h + 10 ;
  IF hide THEN
    BEGIN
      Grow_Box( 3*8, 0, 4*8, rez*8, x, y, w, h ) ;
      Show_Dialog(dia_obj, Root);          (* no interaction *)
      Wait(2);                             (* 2 seconds later close down *)
      Form_Dial(3, 0, 0, 0, 0, x, y, w, h);  (* close the box *)
      Shrink_Box( x, y, w, h, 3*8, 0, 4*8, rez*8 ) ;
    END
  ELSE
    BEGIN
      Grow_Box( 3*8, 0, 4*8, rez*8, x, y, w, h ) ;
      dummy := Do_Dialog(dia_obj, 0);      (* no need to hide the buttom *)
      End_Dialog(dia_obj);
      Shrink_Box( x, y, w, h, 3*8, 0, 4*8, rez*8 ) ;
      Obj_Setstate(dia_obj, dummy, NORMAL, FALSE);
    END ;
END;  (* formdo *)


PROCEDURE Set_Defaults ;
(* initialize some variables *)
  VAR
    opt : opt_range ;
    path : C_Path_Type ;
    p_path : Path_Name ;
    Table : Long_Integer ;
  BEGIN
    Table := Linea_init;      { Get table of linea variables }
    Intin  := ptr(lpeek(Table + LA_Intin));  { Setup Intin array pointer! }
    FOR opt := 1 TO max_option DO
      IF opt IN [ ERRPAUSE,CHNLINK,DBGOPT,STKOPT,RNGOPT,EDITCOMP ]
        THEN cmp_opts[ opt ] := true ;
    work_path[1] := chr( ord('A') + Dgetdrv ) ;
    work_path[2] := ':' ;
    work_path[0] := chr(2) ;
    Dgetpath( path, 0 ) ;      (* Get default path *) ;
    C_To_PPath(path, p_path);     (* convert C string to Pas string *)
    work_path := concat( work_path, p_path, '\' ) ; (* used by FILE *)
    def_path := work_path ;     {Default path where PASCALM.PRG found}
    file_path1 := concat( work_path, '*.*' ) ; {Used by SPECIALS - "FROM"}
    file_path2 := file_path1 ;  {Used by specials - "TO" pathway}
    editor_name := concat( work_path, 'EDITOR.PRG  ') ;
    compiler_name  := concat( work_path, 'COMPILER.PRG  ' ) ;
    linker_name := concat( work_path, 'LINKER.PRG  ' ) ;
    paslib_name := concat ( work_path, 'PASLIB' ) ;
    pasgem_name := concat ( work_path, 'GEMLIB' ) ;
    printer_name := concat( work_path, 'LISTPAS.PRG' ) ;
    backup_path := work_path ;
    work_path := concat( work_path, '*.PAS' ) ; {Source program path}
    for_gem := GEM_O ;
  END ;


FUNCTION Chdir( VAR PPath : Path_Name ) : Boolean ;
{Change current default pathway - a necessity in running programs with}
{resource files}
VAR
   errstr : Str255 ;
   CPath : C_Path_Type ;
   driveID,
   i : Integer ;
BEGIN
  driveID := Ord(PPath[1]) - Ord('A') ;
  IF (ShR(Dsetdrv(driveID),driveID)&$0001)<>1 THEN
    BEGIN
      IO_Error( -15 ) ;
      Chdir := FALSE ;
    END
  ELSE
    BEGIN
      FOR i := 3 TO Length( PPath ) DO CPath[i-2] := PPath[i] ;
      CPath[i-2] := Chr(0) ;
      i := Dsetpath( CPath ) ;
      IF i=0 THEN Chdir := TRUE
      ELSE
        BEGIN
          IO_Error( i ) ;
          Chdir := FALSE ;
        END ;
    END ;
END ;


FUNCTION Copy_Files( src_file, des_file : Path_Name ) : Boolean ;
(* a generic routine to copy file *)
{The success of the operation is returned}
VAR
  i,
  infile,                      (* file handle for input file *)
  outfile       : INTEGER ;    (* file handle for output file *)
  w_bytes,
  n_bytes       : Long_INTEGER ; (* number of bytes for read/write *)
  write_error   : BOOLEAN ;
  cnvrt_str     : C_Path_Type ;
  buf           : buf_type ;
BEGIN
  IF src_file=des_file THEN
    BEGIN
      IO_Error( -37 ) ;
      Copy_Files := FALSE ;
    END
  ELSE
    BEGIN
      write_error := FALSE ;
      P_To_CPath(src_file, cnvrt_str) ;      (* convert to C string *)
      Set_Mouse( M_BEE ) ;               (* busy copying file *)
      infile := FOpen( cnvrt_str, 0 ) ;      (* open file to read *)
      IF infile >= 0 THEN
        BEGIN              (* open success *)
          P_To_CPath(des_file, cnvrt_str) ;
          outfile := FCreate( cnvrt_str, 0 ) ; (* open a file regardless *)
          IF outfile >= 0 THEN                 (* of its existence *)
            BEGIN           (* open success *)
              REPEAT
                n_bytes := FRead( infile, chunk, buf ) ;
                IF n_bytes > 0 THEN
                  BEGIN        (* we read something *)
                    w_bytes := FWrite( outfile, n_bytes, buf ) ;
                    IF w_bytes <> n_bytes THEN
                      BEGIN
                        write_error := TRUE ;        (* write error *)
                        IF w_bytes < 0 THEN IO_Error( w_bytes )
                        ELSE IO_Error( -18 ) ;   {Presume it is a disk full}
                      END ; (* write *)          {error}
                  END (* read *)
                ELSE IF n_bytes < 0 THEN
                  BEGIN
                    write_error := TRUE ;
                    IO_Error( n_bytes ) ;
                  END ;
              UNTIL ((n_bytes = 0) OR write_error ) ;
              FClose( outfile ) ;
            END   (* outfile *)
          ELSE
            BEGIN
              IO_Error( outfile ) ;
              write_error := TRUE ;
            END ;
          FClose( infile ) ;
        END  (* infile *)
      ELSE
        BEGIN
          IO_Error( infile ) ;
          write_error := TRUE ;
        END ;
      Set_Mouse( M_ARROW ) ;             (* copy is done *)
      Copy_Files := NOT write_error ;
    END ;
END ;



FUNCTION FileConflict( VAR OldPath, NewPath : Path_Name ;
  copy : Boolean ) : Boolean ;
{This routine will display a File Conflict box if necessary}
{AND give the user a chance to "chicken" out}
VAR
  tsource,
  destin  : Path_Name ;
  i,
  btn     : Integer ;
  conflict_box : Dialog_Ptr ;
  C_Name  : C_Path_Type ;
  cont : Boolean ;
BEGIN
  SetupFname( des_name, destin, FALSE ) ;
  i := NAMEOK ;
  cont := Chdir( NewPath ) ;
  P_To_CPath( des_name, C_name ) ;
  SetDTA( Prog_DTA ) ;
  IF (SFirst(C_Name,$37)=0) AND cont THEN {Check to see if conflict box needed}
    BEGIN
      Find_Dialog( NAMECONF, conflict_box ) ;
      Center_Dialog( conflict_box ) ;
      SetupFName( des_name, tsource, TRUE ) ;
      Set_DText( conflict_box, SNAME, tsource, System_Font, TE_LEFT ) ;
      Set_DText( conflict_box, FNAME, destin, System_Font, TE_LEFT ) ;
      IF copy THEN {Display appropriate title for MOVE or COPY}
        Set_DText( conflict_box, CONFTITL, 'NAME CONFICT DURING COPY',
          System_Font, TE_CENTER )
      ELSE
        Set_DText( conflict_box, CONFTITL, 'NAME CONFICT DURING MOVE',
          System_Font, TE_CENTER ) ;
      i := Do_Dialog( conflict_box, FNAME ) ;
      Get_DEdit( conflict_box, FNAME, temp_path ) ;
      End_Dialog( conflict_box ) ;
      Obj_SetState( conflict_box, i, NORMAL, FALSE ) ;
      IF (Prog_DTA.attrib=$10) AND (temp_path=destin) AND (i=NAMEOK) THEN
        BEGIN
          IO_Error( -36 ) ;
          cont := FALSE
        END
      ELSE destin := temp_path ;
    END ;
  IF (i=NAMEOK) AND cont THEN
    BEGIN
      des_name := '' ;
      FOR i := 1 TO Length(destin) DO
        BEGIN
          IF destin[i]<>' ' THEN
            BEGIN
              IF i=9 THEN des_name := Concat( des_name, '.' ) ;
              des_name := Concat( des_name, destin[i] ) ;
            END ;
        END ;
      src_name := Concat( OldPath, src_name ) ;
      des_name := Concat( NewPath, des_name ) ;
    END
  ELSE IF i=NAMECANC THEN cont := FALSE ;
  FileConflict := NOT cont ;
END ;


PROCEDURE Do_Copy;
(* get source and destination names and call copy_file routine *)
VAR
  TempPath,
  NewPath,
  OldPath : Path_Name ;
  dumy    : Boolean ;

BEGIN
  Info_Msg('Select File To Be Copied FROM...') ;
  OldPath := src_name ;
  IF Get_In_File( file_path1, OldPath ) AND (length(OldPath) <> 0) THEN
    BEGIN
      EraseInfo ;
      Info_Msg('Select File To Be Copied TO...') ;
      TempPath := OldPath ;
      Strip_Filename( TempPath, NewPath ) ;
      dumy := Get_In_File( file_path2, NewPath ) ;
      EraseInfo ;
      IF dumy AND (Length(NewPath)<>0) THEN
        BEGIN
          Strip_Filename( OldPath, src_name ) ;
          Strip_Filename( NewPath, des_name ) ;
          IF (Length(src_name)<>0) AND (Length(des_name)<>0) THEN
            BEGIN
              IF NOT FileConflict( OldPath, NewPath, TRUE ) THEN
                BEGIN
                  dumy := Copy_Files( src_name, des_name ) ;
                  dumy := Chdir( def_path ) ;
                END ;
            END
          ELSE IO_Error( -33 ) ;
        END ;
    END
  ELSE EraseInfo ;
  Menu_Normal( menu, MSPECIAL ) ;
END;


PROCEDURE Disk_Space ;
(* check free space of a drive *)
VAR
  space_box     : Dialog_Ptr ;
  x, y, w, h,
  btn           : Integer ;
  drive_char,
  byte_used,
  byte_available : Str255 ;
  hold_map,
  temp,
  drive_map     : Long_Integer ;    (* an array with all available drives *)
  drive_id      : Integer ;
  drive_buf     : DRIVE_ARRAY ;
  dumy : Boolean ;
BEGIN
  byte_used := '';
  byte_available := '' ;
  drive_id := Dgetdrv ;                        (* used current drv first *)
  drive_char[1] := CHR(ORD('A') + drive_id) ;  (* convert to char *)
  drive_char[0] := CHR(1) ;                    (* force string length to 1 *)
  hold_map := Dsetdrv(drive_id) ;
  Find_Dialog( DISKSP, space_box ) ;
  Center_Dialog( space_box ) ;
  Obj_Size( space_box, DISKID, x, y, w, h ) ;
  Set_DText( space_box, DISKID, drive_char, System_Font, TE_CENTER ) ;
  Set_DText( space_box, BYTEAVL, '________', System_Font, TE_RIGHT ) ;
  Set_DText( space_box, BYTEUSED,'________', System_Font, TE_RIGHT ) ;
  btn := Do_Dialog( space_box, DISKID ) ;
  LOOP
    WHILE (btn<>DSOKBTN) AND (btn<>DSCANBTN) DO
      BEGIN
        IF btn=DSKLEFT THEN  {Process Left Arrow Presses to decrement Drives}
          BEGIN
            REPEAT
              drive_id := drive_id - 1 ;
              IF drive_id<0 THEN drive_id := 15 ;
            UNTIL (ShR(hold_map,drive_id)&$0001)=1 ;
            drive_char[1] := Chr(Ord('A') + drive_id ) ;
            Set_DText( space_box, DISKID, drive_char, System_Font, TE_CENTER ) ;
            Obj_Draw( space_box, DISKID, DISKID, x, y, w, h ) ;
          END
        ELSE IF btn=DSKRIGHT THEN {Process Right Arrow Presses to advance}
          BEGIN                   {drives}
            REPEAT
              drive_id := drive_id + 1 ;
              IF drive_id>15 THEN drive_id := 0 ;
            UNTIL (ShR(hold_map,drive_id)&$0001)=1 ;
            drive_char[1] := Chr(Ord('A') + drive_id ) ;
            Set_DText( space_box, DISKID, drive_char, System_Font, TE_CENTER ) ;
            Obj_Draw( space_box, DISKID, DISKID, x, y, w, h ) ;
          END ;
        btn := Redo_Dialog( space_box, DISKID ) ;
      END ;
    IF btn=DSOKBTN THEN
      BEGIN
        Set_Mouse(M_BEE) ;    (* it takes a while for disk-free routine *)
        Get_DEdit( space_box, DISKID, drive_char ) ;
        drive_id := ORD(drive_char[1]) - ORD('A') ;  (* get drive user wants *)
        (* check if the requested drive in system *)
        drive_map := ShR( Dsetdrv(drive_id), drive_id ) & $0001; (* check bit *)
        IF drive_map = 1 THEN
          BEGIN
            Dfree(drive_buf, drive_id + 1 ) ;       (* it's a valid drive *)
            temp := drive_buf[3] * drive_buf[4];    (* bytes per cluster *)
            WriteV( byte_available, (drive_buf[1] * temp) : 8 ) ;
            WriteV( byte_used, ((drive_buf[2] - drive_buf[1])* temp) : 8 ) ;
            Set_DText( space_box, BYTEAVL, byte_available, System_Font,
              TE_RIGHT ) ;
            Set_DText( space_box, BYTEUSED, byte_used, System_Font, TE_RIGHT ) ;
            Set_Mouse(M_Arrow) ;
            Obj_SetState( space_box, btn, Normal, TRUE ) ;
            Show_Dialog( space_box, ROOT ) ;
          END
        ELSE
          BEGIN
            Set_Mouse(M_ARROW) ;
            End_Dialog( space_box ) ;
            IO_Error( -15 ) ;
            Obj_SetState( space_box, btn, Normal, FALSE ) ;
            btn := DSCANBTN ;
          END ;
      END ;
    EXIT IF btn=DSCANBTN ;
    btn := Redo_Dialog( space_box, DISKID ) ;
  END ;
  Obj_SetState( space_box, btn, Normal, FALSE ) ;
  dumy := Chdir( def_path ) ;
  End_Dialog( space_box ) ;
END ;


PROCEDURE Rename_File ;
(* renaming file *)
VAR
  old, new      : C_Path_Type ;
  fhandle,
  i             : Integer ;
  tbuf          : time_buf ;
  NewPath,
  OldPath       : Path_Name ;
  cont          : Boolean ;
BEGIN
  info_msg( 'Select file to be renamed FROM...' ) ;
  OldPath := src_name ;
  cont := Get_In_File( file_path1, OldPath ) ;
  EraseInfo ;
  IF cont AND (length(OldPath) <> 0) THEN
    BEGIN
      info_msg( 'Select file to be rename TO...' ) ;
      temp_path := OldPath ;
      Strip_Filename( temp_path, des_name ) ;
      NewPath := des_name ;
      cont := Get_In_File( file_path2, NewPath ) ;
      EraseInfo ;
      IF cont AND (length(NewPath) <> 0) THEN
        BEGIN            {Don't allow renamming to Self}
          IF OldPath=NewPath THEN
            BEGIN
              IO_Error( -37 ) ;
              cont := FALSE ;
            END ;
        END ;
      IF cont THEN
        BEGIN
          Strip_Filename( OldPath, src_name ) ;
          Strip_Filename( NewPath, des_name ) ;
          IF (src_name='') OR (des_name='') THEN
            BEGIN        {Don't allow null file names}
              IO_Error(-38) ;
              cont := FALSE ;
            END ;
        END ;
      IF cont THEN cont := Chdir( OldPath ) ;
      IF cont THEN  {Check if source file is read only - if so, error out}
        BEGIN
          SetDTA( Prog_DTA ) ;
          P_To_CPath( src_name, old ) ;
          i := SFirst( old, $01 ) ;
          IF (i=0) AND cont THEN
            BEGIN
              IF Prog_DTA.attrib = $01 THEN
                BEGIN
                  IO_Error( -36 ) ;
                  cont := FALSE ;
                END ;
            END
          ELSE IF (i<>0) AND cont THEN {Error out if cannot find source}
            BEGIN
              IO_Error( i ) ;
              cont := FALSE ;
            END ;
        END ;
      IF cont THEN cont := NOT FileConflict( OldPath, NewPath, FALSE ) ;
      IF cont THEN
        BEGIN
          IF OldPath[1]<>NewPath[1] THEN {Simulate MOVE between drives}
            BEGIN            {First copy the file}
              cont := Copy_Files( src_name, des_name ) ;
              IF cont THEN   {Get Source File's time/date stamp}
                BEGIN
                  P_To_CPath( src_name, old ) ;
                  fhandle := FOpen( old, 0 ) ;
                  IF fhandle<0 THEN
                    BEGIN
                      IO_Error( fhandle ) ;
                      cont := FALSE ;
                    END
                  ELSE
                    BEGIN
                      FDaTime( tbuf, fhandle, 0 ) ;
                      FClose( fhandle ) ;
                    END ;
                END ;
              IF cont THEN {Set copy's time/date stamp to source's}
                BEGIN
                  P_To_CPath( des_name, new ) ;
                  fhandle := FOpen( new, 2 ) ;
                  IF fhandle<0 THEN
                    BEGIN
                      IO_Error( fhandle ) ;
                      cont := FALSE ;
                    END
                  ELSE
                    BEGIN
                      FDaTime( tbuf, fhandle, 1 ) ;
                      FClose( fhandle ) ;
                    END ;
                END ;
              IF cont THEN {If move successful then Delete source}
                BEGIN
                  P_To_CPath(src_name, old) ;
                  IO_Error( FDelete(old) ) ;
                END ;
            END
          ELSE    {Let GEMDOS do the MOVE/RENAME within a drive}
            BEGIN
              P_To_CPath( des_name, new ) ;
              i := FDelete( new ) ; {Delete preexisting new file}
              IF (i=0) OR (i=-33) THEN  {for convenience}
                BEGIN
                  P_To_CPath( src_name, old ) ;
                  IO_Error( FRename( 0, old, new ) ) ;
                END
              ELSE IO_Error( i ) ;
            END ;
          cont := Chdir( def_path ) ;
        END ;
    END ;
END ;


PROCEDURE Delete_File ;
{Delete file - No prompt but File selector - be sure you want to delete file!!!}
VAR
  fname : Path_name ;
  c_str : C_Path_Type ;
  continue : Boolean ;
BEGIN
  Info_Msg('Select File To Be Deleted...') ;
  continue := Get_In_File( file_path1, src_name ) ;
  EraseInfo ;
  IF continue AND (length(src_name) <> 0) THEN
    BEGIN
      Strip_Filename( src_name, fname ) ;
      continue := Chdir( src_name ) ;
      IF continue THEN
        BEGIN        {Check for tries to Delete Folders, and deny access}
          SetDTA( Prog_DTA ) ;
          P_To_CPath(fname, c_str) ;
          IF SFirst( c_str, $37 ) = 0 THEN
            BEGIN
              IF Prog_DTA.attrib = $10 THEN
                BEGIN
                  continue := FALSE ;
                  IO_Error( -36 ) ;
                END ;
            END ;
        END ;
      IF continue THEN IO_Error( FDelete(c_str) ) ;
      continue := Chdir( def_path ) ;
    END ;
  Menu_Normal( menu, MSPECIAL ) ;
END ;


PROCEDURE Set_Source ;
{Set working path to file to be edited and compiled}
VAR fname : Path_Name ;
BEGIN
  fname := '' ;
  info_msg( 'Set path to SOURCE files...' ) ;
  IF Get_In_File( file_path1, fname ) THEN work_path := file_path1 ;
  EraseInfo ;
END ;


PROCEDURE Locate_Programs ;
(* local filenames, similar to Pascal version 2. *)
VAR
  fpath,
  fname : Path_Name ;
  msg : Str255 ;
  l_box : Dialog_Ptr ;
  btn : Integer ;
BEGIN
  Find_Dialog( LOCATE, l_box ) ;
  Center_Dialog( l_box ) ;
  REPEAT
    btn := Do_Dialog( l_box, 0 ) ;
    CASE btn OF
      LEDIT   : BEGIN
                  msg := 'Select the EDITOR filename...' ;
                  fname := 'EDITOR.' ;
                END ;
      LCMP    : BEGIN
                  msg := 'Select the COMPILER filename...' ;
                  fname := 'COMPILER.PRG' ;
                END ;
      LLINK   : BEGIN
                  msg := 'Select the LINKER filename...' ;
                  fname := 'LINKER.PRG' ;
                END ;
      LPASGEM : BEGIN
                  msg := 'Select the PASGEM filename...' ;
                  fname := 'PASGEM' ;
                END ;
      LPASLIB : BEGIN
                  msg := 'Select the PASLIB filename...' ;
                  fname := 'PASLIB' ;
                END ;
      LPRT    : BEGIN
                  msg := 'Select the PRINTER filename...' ;
                  fname := 'LISTPAS.PRG' ;
                END ;
    END ;
    IF btn <> LOKBTN THEN BEGIN
      Info_Msg( msg ) ;
      IF Get_In_File( file_path1, fname ) AND (length(fname) <> 0) THEN
        BEGIN
          EraseInfo ;
          CASE btn OF
            LEDIT   : editor_name := fname ;
            LCMP    : compiler_name := fname ;
            LLINK   : linker_name := fname ;
            LPASGEM : pasgem_name := fname ;
            LPASLIB : paslib_name := fname ;
            LPRT    : printer_name := fname ;
          END ;
        END
      ELSE EraseInfo ;
    END ;
    Obj_SetState( l_box, btn, Normal, TRUE ) ;
  UNTIL btn = LOKBTN ;
  End_Dialog( l_box ) ;
END ;


PROCEDURE Read_Options( Fname : Path_name ; ShowError : Boolean ) ;
(* read options from the .INF file *)
  VAR
    f : text ;
    version : integer ;
    temp : integer ;
    opt : opt_range ;
  BEGIN
    IO_Check( false ) ;
    reset( f, Fname ) ;
    IO_Check( true ) ;
    temp := IO_Result ;
    IF temp = 0 THEN
      BEGIN
        readln( f, version ) ;
        FOR opt := 1 TO max_option DO
          IF opt IN [ ERRPAUSE,CHNLINK,DBGOPT,EDITCOMP,
                      STKOPT,RNGOPT,CLROPT,BAKOPT,NOCODE ]
           THEN
            BEGIN
              readln( f, temp ) ;
              cmp_opts[ opt ] := temp <> 0 ;
            END ;
        readln( f, for_gem ) ; (* 1 for GEM, 2 for TOS, 3 for TTP, 4 for ACC *)
        readln( f, addl_files ) ;
        readln( f, addl_libs ) ;
        readln( f, backup_path ) ;
        readln( f, editor_name ) ;
        readln( f, compiler_name ) ;
        readln( f, linker_name ) ;
        readln( f, pasgem_name ) ;
        readln( f, paslib_name ) ;
        readln( f, printer_name ) ;
        readln( f, work_path ) ;
        close( f ) ;
        file_path1 := work_path ;
        Strip_Filename( file_path1, temp_path ) ;
        file_path1 := concat( file_path1, '*.*' ) ;       (* used by SPECIALS *)
        file_path2 := file_path1 ;
      END
    ELSE IF ShowError THEN IO_Error( temp ) ;
  END ;


PROCEDURE Load_Options ;
{Load new option file from path given}
VAR
    NewPath,
    NewFile : Path_Name ;
    continue : Boolean ;
  BEGIN
    Info_Msg('Select Option Filename To Be LOADED...') ;
    NewFile := 'PASCALM.INF' ;
    NewPath := Concat( def_path, '*.INF' ) ;
    continue := Get_In_File( NewPath, NewFile ) ;
    EraseInfo ;
    IF continue AND (length(NewFile) <> 0) THEN
      BEGIN
        NewPath := NewFile ;
        Strip_Filename( NewPath, NewFile ) ;
        continue := Chdir( NewPath ) ;
        IF continue THEN
          BEGIN
            Read_Options( NewFile, TRUE ) ;
            continue := Chdir( def_path ) ;
          END ;
      END ;
  END ;


PROCEDURE Save_Options ;
(* sace options to the .INF file *)
  VAR
    NewPath,
    NewFile : Path_Name ;
    f : text ;
    opt : opt_range ;
    continue : Boolean ;
  BEGIN
    Info_Msg('Select Option Filename To Be SAVED...') ;
    NewFile := 'PASCALM.INF' ;
    NewPath := Concat( def_path, '*.INF' ) ;
    continue := Get_In_File( NewPath, NewFile ) ;
    EraseInfo ;
    IF continue AND (length(NewFile) <> 0) THEN
      BEGIN
        NewPath := NewFile ;
        Strip_Filename( NewPath, NewFile ) ;
        continue := Chdir( NewPath ) ;
        IF continue THEN
          BEGIN
            IO_Check( false ) ;
            rewrite( f, NewFile ) ;
            IO_Check( true ) ;
            IF (IO_Result <> 0) THEN IO_Error( IO_Result )
            ELSE
              BEGIN
                Set_Mouse( M_BEE ) ;         (* busy saving file *)
                writeln( f, $100:1 ) ;  (* Version 1.00 *)
                FOR opt := 1 TO max_option DO
                  IF opt IN [ ERRPAUSE,CHNLINK,DBGOPT,EDITCOMP,STKOPT,
                      RNGOPT,CLROPT,BAKOPT,NOCODE ]
                      THEN writeln( f, ord( cmp_opts[opt] ):1 ) ;
                writeln( f, for_gem ) ;
                writeln( f, addl_files ) ;
                writeln( f, addl_libs ) ;
                writeln( f, backup_path ) ;
                writeln( f, editor_name ) ;
                writeln( f, compiler_name ) ;
                writeln( f, linker_name ) ;
                writeln( f, pasgem_name ) ;
                writeln( f, paslib_name ) ;
                writeln( f, printer_name ) ;
                writeln( f, work_path ) ;
                close( f ) ;
                Set_Mouse( M_ARROW ) ;
              END ;
            continue := Chdir( def_path ) ;
          END
      END
  END ;


PROCEDURE out_esc( c : char ) ;
{For TOS screen control VT-52}
  BEGIN
    bconout( 2, 27 ) ;
    bconout( 2, ord(c) ) ;
  END ;


PROCEDURE Tos_Screen ;
  BEGIN
    Hide_Mouse ;
    out_esc( 'E' ) ;        (* Clear screen *)
    out_esc( 'e' ) ;        (* and cursor on *)
  END ;


PROCEDURE Gem_Screen ;
  BEGIN
    out_esc( 'f' ) ;        (* Cursor off *)
    Show_Mouse ;
  END ;


FUNCTION VerifyPath( prog : Path_Name ) : Boolean ;
{Verify program path name before attempt to run it}
VAR filename : Path_Name ;
    C_name : C_Path_Type ;
    cont : Boolean ;
    error : Integer ;
BEGIN
  Strip_Filename( prog, filename ) ;
  cont := Chdir( prog ) ;
  IF cont THEN
    BEGIN
      P_To_CPath( filename, C_name ) ;
      error := SFirst( C_name, $01 ) ;
      IF error<>0 THEN
        BEGIN
          Redraw_Screen ;
          IO_Error( error ) ;
          cont := FALSE ;
        END ;
    END ;
  VerifyPath := cont ;
  cont := Chdir( def_path ) ;
END ;


FUNCTION Call_Overlay( prog : Path_Name ; VAR cmd_line : Str255 ;
                            tos : boolean ) : integer ;
(* call editor, compiler, linker *)
  VAR
    i : integer ;
    prog_name : C_Path_Type ;
    tail : C_String ;

  FUNCTION p_exec( load : integer ; VAR name : C_Path_Type;
                   VAR tail : C_String ; VAR envp : env_ptr ) : integer ;
    GEMDOS( $4B ) ;

  BEGIN
    FOR i := 1 TO length( cmd_line ) DO
      tail[i] := cmd_line[i] ;
    tail[ length(cmd_line)+1 ] := chr(0) ;
    tail[0] := chr( length(cmd_line) ) ;
    P_To_CPath( prog, prog_name ) ;
    Erase_Menu( menu ) ;
    IF tos THEN Tos_Screen ;
    Call_Overlay := p_exec( 0, prog_name, tail, envp ) ;
    IF tos THEN Gem_Screen ;
    Redraw_Screen ;
    Draw_Menu( menu ) ;
  END ;


PROCEDURE Print_File ;
{Calls a generic PRINT file; no PARAMETERS are passed}
{default path switched to work path for the PRINT files usage}
VAR
    junk : integer ;
    prog_name : C_Path_Type ;
    tail : C_String ;
    gem : Boolean ;
    NewPath : Path_Name ;

  FUNCTION p_exec( load : integer ; VAR name : C_Path_Type;
                   VAR tail : C_String ; VAR envp : env_ptr ) : integer ;
    GEMDOS( $4B ) ;

BEGIN
  IF VerifyPath( printer_name ) THEN
    BEGIN
      tail[0] := Chr(0) ;
      tail[1] := chr(0) ;
      NewPath := work_path ;
      Strip_Filename( NewPath, temp_path ) ;
      gem := Chdir( NewPath ) ;
      P_To_CPath( printer_name, prog_name ) ;
      gem := Is_GEM_Name( printer_name ) ;
      IF NOT gem THEN Tos_Screen ;
      junk := p_exec( 0, prog_name, tail, envp ) ;
      IF NOT gem THEN Gem_Screen ;
      gem := Chdir( def_path ) ;
      Redraw_Screen ;
    END ;
END ;


PROCEDURE Create_Folder ;
{Make a new directory}
VAR
    Folder,
    NewPath : Path_Name ;
    continue : Boolean ;
    Cname : C_Path_Type ;

  BEGIN
    Info_Msg('Select Folder Name To Be CREATED...') ;
    NewPath := '' ;
    continue := Get_In_File( file_path1, NewPath ) ;
    EraseInfo ;
    IF continue AND (length(NewPath) <> 0) THEN
      BEGIN
        Strip_Filename( NewPath, Folder ) ;
        IF Folder='' THEN
          BEGIN
            IO_Error(-34) ;
            continue := FALSE ;
          END
        ELSE continue := Chdir( NewPath ) ;
        IF continue THEN
          BEGIN
            P_To_CPath( Folder, Cname ) ;
            IF SFirst(Cname, $37)=0 THEN IO_Error( -36 )
            ELSE IO_Error( Mkdir( Cname ) ) ;
            continue := Chdir( def_path ) ;
          END ;
      END ;
  END ;


FUNCTION Delete_Folder( VAR RPath, FPath, FldName : Path_Name ) : Boolean ;
{Delete Folder - this routine clears out all files and folders within}
{the folder to be deleted by calling itself}
VAR
    MoreFiles,
    return      : Integer ;
    dumy,
    continue    : Boolean ;
    ReturnPath,
    FolderPath,
    FolderName,
    Fname,
    FolderContents : Path_Name ;
    C_Temp,
    Cname       : C_Path_Type ;
BEGIN
  ReturnPath := RPath ;  {The paths to the folders are passed with pointers}
  FolderPath := FPath ;  {to save stack space. Those pointers can not be used}
  FolderName := FldName ; {in a recursive procedure, and have to be copied}
  FolderContents := Concat( FolderPath, FolderName, '\' ) ;
  continue := Chdir( FolderContents ) ;
  Fname := '*.*' ;
  P_To_CPath( Fname, Cname ) ;
  MoreFiles := SFirst(Cname,$37) ; {Get name and attribute of each file entry}
  WITH Prog_DTA DO                 {and delete it!}
    BEGIN
      WHILE (MoreFiles=0) AND continue DO
        BEGIN
          IF attrib=$10 THEN {Directory files}
            BEGIN
              IF name[1]<>'.' THEN {Ignore "." directory entries pointing to}
                BEGIN              {parent and subdirectories}
                  C_To_PPath( name, Fname ) ;
                  continue := Delete_Folder( FolderContents, FolderContents, Fname ) ;
                  MoreFiles := SFirst(Cname,$37) ;
                END
              ELSE MoreFiles := SNext ;
            END
          ELSE IF attrib=$01 THEN {Unprotect write protected files first}
            BEGIN                 {then delete them}
             return := Chmod( name, 1, 0 ) ;
             IF return>0 THEN return := -5 ;
             IF return<0 THEN
               BEGIN
                IO_Error( return ) ;
                continue := FALSE ;
               END
             ELSE
               BEGIN
                 return := FDelete( name ) ;
                 IF return<>0 THEN
                   BEGIN
                     IO_Error( return ) ;
                     continue := FALSE ;
                   END ;
               END ;
             MoreFiles := SNext ;
            END
          ELSE                  {Else delete all other files}
            BEGIN
              return := FDelete( name ) ;
              IF return<>0 THEN
                BEGIN
                  IO_Error( return ) ;
                  continue := FALSE ;
                END ;
              MoreFiles := SNext ;
            END ;
        END ;
    END ;
  IF continue THEN {If the folder has been cleared out, delete it then!}
    BEGIN
      continue := Chdir( FolderPath ) ;
      IF continue THEN
        BEGIN
          P_To_CPath( FolderName, Cname ) ;
          return := DDelete( Cname ) ;
          IF return<>0 THEN
            BEGIN
              IO_Error( return ) ;
              continue := FALSE ;
            END ;
        END ;
    END ;
  dumy := Chdir( ReturnPath ) ; {Return to starting pathway}
  Delete_Folder := continue ;
END ;


PROCEDURE Setup_DFolder ;
{Routine to ask which folder to delete - NOTE: only the PATH, not the}
{returned filename from the File Selector is examined}
VAR
    len,
    choice : Integer ;
    AlertStr : Str255 ;
    F_path,
    Folder : Path_Name ;
    continue : Boolean ;
BEGIN
  info_msg( 'Set Path To The FOLDER To Be DELETED...' ) ;
  F_path := '' ;
  continue := Get_In_File( file_path1, F_path ) ;
  EraseInfo ;
  IF continue THEN
    BEGIN
      F_path := file_path1 ;
      IF F_path[2]<>':' THEN
        BEGIN
          continue := FALSE ;
          IO_Error(-34) ;
        END
      ELSE
        BEGIN
          Strip_Filename( F_path, Folder ) ;
          len := Length( F_path ) ;
          IF (len<5) OR (F_path[len]<>'\') THEN
            BEGIN
              continue := FALSE ;
              IO_Error( -34 ) ;
            END
          ELSE continue := Chdir( F_path ) ;
        END ;
    END ;
  IF continue THEN  {If user wants to delete folder, give him a chance to}
    BEGIN           {back out, and list folder name for him!!!}
      F_path[0] := Chr(len-1) ;
      Strip_Filename( F_path, Folder ) ;
      file_path1 := F_path ;
      AlertStr := '[2][|Are you sure that you wish to|delete the entire ' ;
      AlertStr := Concat( AlertStr, 'contents of|folder "', FOLDER, '"...][ YES | NO ]' ) ;
      choice := Do_Alert( AlertStr, 1 ) ;
      IF choice <> 1 THEN continue := FALSE ;
    END ;
  IF continue THEN
    BEGIN
      Set_Mouse( M_Bee ) ;
      SetDTA( Prog_DTA ) ;
      continue := Delete_Folder( def_path, F_path, Folder ) ;
      Set_Mouse( M_Arrow ) ;
    END ;
  continue := Chdir( def_path ) ;
  Menu_Normal( menu, MSPECIAL ) ;
END ;


PROCEDURE Strip_Extension( VAR fn : Path_Name ) ;
(* Strip_Extension - Remove the extension from a Path_Name variable. *)
  VAR
    i : integer ;
    done : boolean ;
  BEGIN
    i := length( fn ) ;
    done := false ;
    WHILE NOT done DO
      BEGIN
        IF i < 1 THEN
          done := true
        ELSE IF (fn[i] = ':') OR (fn[i] = '\') THEN
          done := true
        ELSE IF fn[i] = '.' THEN
          BEGIN
            fn[0] := chr(i-1) ;
            done := true ;
          END
        ELSE
          i := i - 1 ;
      END ;
  END ;


PROCEDURE Do_Link( name : Path_Name ; for_gem : integer ) ;
(* Do_Link - Call the linker with a desired file as input. *)
  VAR
    run_save : Path_Name ;
    ReturnCode : integer ;
    extension : STRING [ 5 ] ;
    libs,
    cmd_line : Str255 ;
    x, y, w, h : integer ;
    dial : Dialog_Ptr ;
  BEGIN
    IF VerifyPath( linker_name ) THEN
      BEGIN
        Strip_Extension( name ) ;
        cmd_line := name ;
        run_save := name ;
        link_name := concat( name , '.O' ) ;
        CASE for_gem OF
          GEM_O : extension := '.PRG=' ;
          ACC_O : extension := '.ACC=' ;
          TOS_O : extension := '.TOS=' ;
          TTP_O : extension := '.TTP=' ;
        END ;
        CASE for_gem OF
          GEM_O, ACC_O : libs := concat(',', pasgem_name, ',', paslib_name) ;
          TOS_O, TTP_O : libs := concat(',', paslib_name) ;
        END ;
        cmd_line := concat( '! ', name, extension, name ) ;
        IF length(addl_files) > 0 THEN
          cmd_line := concat( cmd_line, ',', addl_files ) ;
        IF length(addl_libs) > 0 THEN
          cmd_line := concat( cmd_line, ',', addl_libs ) ;
        cmd_line := concat( cmd_line, libs ) ;
        Find_Dialog( LOADING, dial ) ;
        Set_DText( dial, LOADNAME, 'Loading overlay LINKER.PRG', System_Font, TE_Left ) ;
        Center_Dialog( dial ) ;
        Show_Dialog( dial, Root ) ;
        ReturnCode := Call_Overlay( linker_name, cmd_line, false ) ;
        IF ReturnCode = 0 THEN
          BEGIN
            CASE for_gem OF
              GEM_O : run_name := concat( run_save, '.PRG' ) ;
              ACC_O : run_name := '' ;
              TOS_O : run_name := concat( run_save, '.TOS' ) ;
              TTP_O : run_name := concat( run_save, '.TTP' ) ;
              END ;
          END ;
      END ;
  END ;


FUNCTION Do_Compile : integer ;
(* Do_Compile - Call the compiler with a desired file as input. *)
  VAR
    cmp_code : integer ;
    cmd_line : Str255 ;
    src,
    des,
    name : Path_Name ;
    x, y, w, h,
    i : integer ;
    dial : Dialog_Ptr ;
    dumy : Boolean ;
  BEGIN
    IF VerifyPath( compiler_name ) THEN
      BEGIN
        name := compile_name ;  {Note usage of separate file compile name from}
        Strip_Extension( name ) ; {file edit name}
        cmd_line := concat( name, '  /UGEM' ) ;
        CASE for_gem OF
          GEM_O : cmd_line := concat( cmd_line, ' /GEM' ) ;
          ACC_O : cmd_line := concat( cmd_line, ' /ACC' ) ;
        END ;
        IF cmp_opts[ ERRPAUSE ] THEN
          cmd_line := concat( cmd_line, ' /PAUSE' ) ;
        IF cmp_opts[ DBGOPT ] THEN
          cmd_line := concat( cmd_line, ' /DEBUG' ) ;
        IF NOT cmp_opts[ STKOPT ] THEN
          cmd_line := concat( cmd_line, ' /NOCHECK' ) ;
        IF cmp_opts[ RNGOPT ] THEN
          cmd_line := concat( cmd_line, ' /CHECK' ) ;
        IF cmp_opts[ CLROPT ] THEN
          cmd_line := concat( cmd_line, ' /CLEAR' ) ;
        IF cmp_opts[ NOCODE ] THEN
          cmd_line := concat( cmd_line, ' /NOCODE' ) ;
        Find_Dialog( LOADING, dial ) ;
        Set_DText( dial, LOADNAME, 'Loading overlay COMPILER.PRG', System_Font, TE_Left ) ;
        Center_Dialog( dial ) ;
        Show_Dialog( dial, Root ) ;
        cmp_code := Call_Overlay( compiler_name, cmd_line, false ) ;
        Do_Compile := 0 ;
        IF cmp_code = 2 THEN        (* User wants to edit! *)
         BEGIN
            Do_Compile := 1 ;
            i := 0 ;
            WHILE envp^[i] <> chr(0) DO
              BEGIN
                edit_name[i+1] := envp^[i] ;
                i := i + 1 ;
              END ;
            edit_name[0] := chr(i) ;
          END
        ELSE BEGIN
          IF (cmp_code = 0) AND (cmp_opts[ BAKOPT ]) THEN
            BEGIN {Copy back EDIT file only, unless not defined yet}
              Find_Dialog( LOADING, dial ) ;
              Set_DText( dial, LOADNAME, 'Automatic BACKUP in progress',
                System_Font, TE_Left ) ;    {Show our intentions to}
              Center_Dialog( dial ) ;       {do AUTO backup}
              Show_Dialog( dial, Root ) ;
              IF Length(edit_name)=0 THEN src := compile_name
              ELSE src := edit_name ;
              Strip_Filename( src, des ) ;
              src := Concat( src, des ) ;
              des := Concat( backup_path, des ) ;
              dumy := Copy_Files( src, des ) ;
            END ;
          IF (cmp_code = 0) AND (cmp_opts[ CHNLINK ]) THEN
            Do_Link( name, for_gem )
          ELSE End_Dialog( dial ) ;
        END ;
      END
    ELSE Do_Compile := 0 ;
  END ;


FUNCTION Do_Edit : integer ;
  VAR
    cmd_line : Str255 ;
    i : integer ;
    is_tos : boolean ;
    path : C_Path_Type ;
    fn,
    WorkPath : Path_Name ;
    dumy : Boolean ;

  BEGIN
    IF VerifyPath( editor_name ) THEN
      BEGIN
        cmd_line := edit_name ;
        is_tos := Is_TTP_Name( editor_name ) ;  (* allow using different type of
                                                 editors *)
        WorkPath := editor_name ;
        Strip_Filename( WorkPath, fn ) ;
        IF Chdir( WorkPath ) THEN  {Reset path to editor pathname for editor to}
          BEGIN                    {finds its resource file}
            Wind_Update( End_Mctrl ) ;
            IF Call_Overlay( editor_name, cmd_line, is_tos ) = 1 THEN
              Do_Edit := 2
            ELSE Do_Edit := 0 ;
            Wind_Update( Beg_Mctrl ) ;
            dumy := Chdir( def_path ) ;
          END
        ELSE Do_Edit := 0 ;
      END
    ELSE Do_Edit := 0 ;
  END ;


PROCEDURE Compile_Edit( which : integer ; GetFile : boolean ) ;
(* Compile_Edit - Loop for "compile-edit-link" process. *)
(* which : 1   Editor
           2   Compiler
*)
  VAR
    FileLen,
    i : integer ;
    cont : boolean ;
  BEGIN
    Strip_Extension( work_path ) ;
    work_path := concat( work_path, '.PAS' ) ;
    cont := TRUE ;
    IF which=1 THEN FileLen := Length(edit_name)
    ELSE FileLen := Length(compile_name ) ;
    IF GetFile OR (FileLen=0) THEN
      BEGIN
        IF which=1 THEN
          BEGIN
            info_msg('Select File To Be Edited...') ;
            cont := Get_In_File( work_path, edit_name ) ;
            FileLen := Length( edit_name ) ;
            GetFile := FALSE ;
          END
        ELSE IF which=2 THEN
          BEGIN
            info_msg('Select File To Be Compiled...') ;
            cont := Get_In_File( work_path, compile_name ) ;
            FileLen := Length( compile_name ) ;
          END ;
        EraseInfo ;
      END ;
    IF cont  AND (FileLen <> 0) THEN BEGIN
      WHILE which <> 0 DO
        BEGIN
          IF which = 1 THEN     (* Editor phase! *)
            BEGIN
              which := Do_Edit ;
            END (* IF *)
          ELSE
            BEGIN
              IF (Length(compile_name)=0) OR
                (cmp_opts[EDITCOMP] AND (Length(edit_name)>0)
                AND (NOT GETFILE)) THEN
                BEGIN
                  compile_name := edit_name ;
                  FOR i := length( compile_name ) DOWNTO 1 DO
                    IF compile_name[i] = ' ' THEN
                      compile_name[0] := chr( i-1 ) ;
                END ;
              which := Do_Compile ;
              GETFILE := FALSE ;
            END ;
        END ; (* WHILE *)
    END  (* IF *)
  END ;


PROCEDURE Call_Linker( GetFile : Boolean ) ;
{CAll linker program}
VAR cont : Boolean ;
  BEGIN
    Strip_Extension( work_path ) ;
    work_path := concat( work_path, '.O' ) ;
    cont := TRUE ;
    IF GetFile OR (length(link_name)=0) THEN
      BEGIN
        info_msg('Select File To Be Linked...') ;
        cont := Get_In_File( work_path, link_name ) ;
        EraseInfo ;
      END ;
    IF cont AND (length(link_name) <> 0)
    THEN BEGIN
      Do_Link( link_name, for_gem ) ;
    END  (* IF *)
    ELSE
  END ;

{$P-}

PROCEDURE Call_Program( GetFile : boolean ) ;
{Run another program}
  TYPE
    environment = PACKED ARRAY [ 1..9 ] OF char ;
  VAR
    cont,
    skip : boolean ;
    i : integer ;
    name : C_Path_Type ;
    tail : C_String ;
    cmd_line : Str255 ;
    env : environment ;
    run_gem : boolean ;
    ttp_box : Dialog_Ptr ;
    tmp_work_path,
    run_path : Path_Name ;

  PROCEDURE p_exec( load : integer ; VAR name : C_Path_Type ;
                    VAR tail : C_String ; VAR env : environment ) ;
    GEMDOS( $4B ) ;

  BEGIN
    tmp_work_path := work_path ;
    skip := FALSE ;
    Strip_Extension( tmp_work_path ) ;
    CASE for_gem OF
      GEM_O :  tmp_work_path := concat( tmp_work_path, '.PRG' ) ;
      TOS_O :  tmp_work_path := concat( tmp_work_path, '.TOS' ) ;
      TTP_O :  tmp_work_path := concat( tmp_work_path, '.TTP' ) ;
    END ;
    cont := TRUE ;
    IF GetFile OR (length(run_name)=0) THEN
      BEGIN
        info_msg('Select File To Be Run...') ;
        cont := Get_In_File( tmp_work_path, run_name ) ;
        EraseInfo ;
      END ;
    Wind_Update( End_Mctrl ) ;
    IF cont AND (length(run_name) <> 0) THEN
      BEGIN
        run_path := run_name ;
        IF VerifyPath( run_name ) THEN
          BEGIN
            Strip_Filename( run_path, tmp_work_path ) ;
            IF Chdir( run_path ) THEN {reset current path for file to be run}
              BEGIN
                P_To_CPath( run_name, name ) ;
                env := 'PATH=A:\ ' ;
                env[9] := chr(0) ;
                run_gem := Is_Gem_Name( run_name ) ;
                IF Is_TTP_Name( run_name ) THEN
                  BEGIN
                    IF Get_CMD( run_name, cmd_line ) THEN
                      BEGIN ; (* get command line *)
                        FOR i := 1 TO length( cmd_line ) DO
                          tail[i] := cmd_line[i] ;
                        tail[ length(cmd_line)+1 ] := chr(0) ;
                        tail[0] := chr( length(cmd_line) ) ;
                      END
                    ELSE
                      skip := TRUE ;
                  END
                ELSE
                  BEGIN
                    tail[0] := chr(0) ;
                    tail[1] := chr(0) ;
                  END ;
                IF NOT skip THEN BEGIN
                  Erase_Menu( menu ) ;
                  IF NOT run_gem THEN Tos_Screen ;
                  p_exec( 0, name, tail, env ) ;
                  IF NOT run_gem THEN
                    BEGIN
                      writeln( 'Hit any key to continue...' ) ;
                      bconin( 2 ) ;       (* Get a key from the BIOS! *)
                      Gem_Screen ;
                    END ;
                  cont := Chdir( def_path ) ; {Reset path back to default}
                  Redraw_Screen ;
                  i := Front_Window ; {Get rid of windows left on our screen by}
                  WHILE i>0 DO        {poorly designed programs - eg: ST Basic!}
                    BEGIN
                      Close_Window( i ) ;
                      Delete_Window( i ) ;
                      i := Front_Window ;
                    END ;
                  Draw_Menu( menu ) ;
                  Intin^[0] := 0 ; {More reliable routine to make sure Mouse}
                  Linea_Showms ;   {shows after running programs}
                  Set_Mouse( M_Arrow ) ;
              END ;
          END ;
        END ; (* not skip *)
      END ; (* get filename *)
  END ;

{$P=}

PROCEDURE Link_Options ;
{Read in link options}
  VAR
    dial : Dialog_Ptr ;
    opt,
    button : integer ;
  BEGIN
    Find_Dialog( LNKOPTS, dial ) ;
    Center_Dialog( dial ) ;
    FOR opt := 1 TO max_option DO
      IF opt IN [ LFORGEM,LFORTOS,LFORTTP,LFORACC ] THEN
        Obj_SetState( dial, opt, Normal, false ) ; (* reset every buttons *)
    CASE for_gem OF
      GEM_O :  Obj_SetState( dial, LFORGEM, Selected, false ) ;
      TOS_O :  Obj_SetState( dial, LFORTOS, Selected, false ) ;
      TTP_O :  Obj_SetState( dial, LFORTTP, Selected, false ) ;
      ACC_O :  Obj_SetState( dial, LFORACC, Selected, false ) ;
    END ;
    Set_DText( dial, LNKADDL, addl_files, System_Font, TE_Left ) ;
    Set_DText( dial, LNKLIBS, addl_libs, System_Font, TE_Left ) ;
    button := Do_Dialog( dial, LNKADDL ) ;
    End_Dialog( dial ) ;
    Obj_SetState( dial, button, Normal, FALSE ) ;
    IF button = LNKOK THEN
      BEGIN
        IF Obj_State( dial, LFORGEM ) = Selected THEN
          for_gem := GEM_O ;
        IF Obj_State( dial, LFORTOS ) = Selected THEN
          for_gem := TOS_O ;
        IF Obj_State( dial, LFORTTP ) = Selected THEN
          for_gem := TTP_O ;
        IF Obj_State( dial, LFORACC ) = Selected THEN
          for_gem := ACC_O ;
        Get_DEdit( dial, LNKADDL, addl_files ) ;
        Get_DEdit( dial, LNKLIBS, addl_libs ) ;
      END ;
  END ;


(* Compiler_Options - Allow the user to change various options within the
    compiler by activating the "Personal Pascal Compiler Options" dialog. *)

PROCEDURE Compiler_Options ;
  VAR
    dial : Dialog_Ptr ;
    button : integer ;
    opt : opt_range ;
  BEGIN
    Find_Dialog( CMPOPTS, dial ) ;
    Center_Dialog( dial ) ;
    (* First, we need to ensure that the state of various dialog objects
      matches the state of our internal variables! *)
    FOR opt := 1 TO max_option DO
      IF opt IN [ FORGEM,FORTOS,FORACC,ERRPAUSE,CHNLINK,DBGOPT,EDITCOMP,
                  STKOPT,RNGOPT,CLROPT,BAKOPT,NOCODE ] THEN
        Obj_SetState( dial, opt, Normal, false ) ;
    CASE for_gem OF
      GEM_O        :  Obj_SetState( dial, FORGEM, Selected, false ) ;
      TOS_O, TTP_O :  Obj_SetState( dial, FORTOS, Selected, false ) ;
      ACC_O        :  Obj_SetState( dial, FORACC, Selected, false ) ;
    END ;
    FOR opt := 1 TO max_option DO
      IF opt IN [ ERRPAUSE, CHNLINK, DBGOPT, EDITCOMP, STKOPT, RNGOPT,
        CLROPT, BAKOPT, NOCODE ] THEN
        IF cmp_opts[ opt ] THEN
          Obj_SetState( dial, opt, Checked, false ) ;
    IF cmp_opts[ NOCODE ] THEN BEGIN  (* no object code, so no link *)
      cmp_opts[ CHNLINK ] := FALSE ;
      Obj_SetState( dial, CHNLINK, Normal, false ) ;
      END ;
    Set_DText( dial, BACKPATH, backup_path, System_Font, TE_Left ) ;
    button := Do_Dialog( dial, BACKPATH ) ;
    WHILE (button <> CMPOK) AND (button <> CMPCAN) DO
      BEGIN
        IF Obj_State(dial, button) = Normal THEN
          Obj_SetState( dial, button, Checked, true )
        ELSE
          Obj_SetState( dial, button, Normal, true ) ;
        IF Obj_State(dial, NOCODE) = Checked THEN
          Obj_SetState( dial, CHNLINK, Normal, true ) ;
        button := Redo_Dialog( dial, BACKPATH ) ;
      END ;
    End_Dialog( dial ) ;
    Obj_SetState( dial, button, Normal, FALSE ) ;
    IF button = CMPOK THEN
      BEGIN
        FOR opt := 1 TO max_option DO
          IF opt IN [ ERRPAUSE,CHNLINK,DBGOPT,EDITCOMP,STKOPT,RNGOPT,
                      CLROPT,BAKOPT,NOCODE ] THEN
            cmp_opts[ opt ] := Obj_State( dial, opt ) = Checked ;
        IF Obj_State( dial, FORGEM ) = Selected THEN
          for_gem := GEM_O ;
        IF Obj_State( dial, FORTOS ) = Selected THEN
          for_gem := TOS_O ;
        IF Obj_State( dial, FORACC ) = Selected THEN
          for_gem := ACC_O ;
        Get_DEdit( dial, BACKPATH, backup_path ) ;
      END ;
  END ;



(* Do_Menu - Perform a menu operation which was selected by the user with the
    mouse.  The chosen menu title and item are passed in the parameters
    'title' and 'item', respectively. *)

  FUNCTION Do_Menu( title, item : integer ) : boolean ;
    VAR
      done : boolean ;
    BEGIN
      done := false ;
      Wind_Update( BEG_Mctrl ) ; {After the menu selection, stop other menus}
      CASE item OF               {from popping down and ruining our screen!}
        MIINFO    : formdo(CONTINFO, NOHIDE);
        MIEDIT    : Compile_Edit( 1, TRUE ) ;
        MICOMPIL  : Compile_Edit( 2, TRUE ) ;
        MILINK    : Call_Linker( TRUE ) ;
        MIRUN     : Call_Program( TRUE ) ;
        MICMPOPT  : Compiler_Options ;
        MILNKOPT  : Link_Options ;
        MISAVOPT  : Save_Options ;
        MILOAOPT  : Load_Options ;
        MISOURCE  : Set_Source ;
        MILOCATE  : Locate_programs ;
        MICOPY    : Do_Copy ;
        MIDLF     : Delete_File ;
        MICRD     : Create_Folder ;
        MIDLFOL   : Setup_DFolder ;
        MICHN     : Rename_File ;
        MIPRF     : Print_File ;
        MIDF      : Disk_Space ;
        MIQUIT    : done := true ;
      END ;
      Menu_Normal( menu, title ) ;
      Do_Menu := done ;
      IF item<>MIRUN THEN Wind_Update( End_Mctrl ) ;
    END ;

{The next series of SHORT procedure run the menu selections from Keypresses}

  PROCEDURE link ;
  BEGIN
    Menu_Hilight( menu, MFILE ) ;
    Call_Linker( FALSE ) ;
    Menu_Normal( menu, MFILE ) ;
  END ;

  PROCEDURE run;
  BEGIN
    Menu_Hilight( menu, MFILE ) ;
    Call_Program( FALSE ) ;
    Menu_Normal( menu, MFILE ) ;
  END ;

  PROCEDURE edit ;
  BEGIN
    Menu_Hilight( menu, MFILE ) ;
    Compile_Edit( 1, FALSE ) ;
    Menu_Normal( menu, MFILE ) ;
  END ;

  PROCEDURE compile ;
  BEGIN
    Menu_Hilight( menu, MFILE ) ;
    Compile_Edit( 2, FALSE ) ;
    Menu_Normal( menu, MFILE ) ;
  END ;

  PROCEDURE copyF ;
  BEGIN
    Menu_Hilight( menu, MSPECIAL ) ;
    Do_Copy ;
  END ;

  PROCEDURE rename ;
  BEGIN
    Menu_Hilight( menu, MSPECIAL ) ;
    Rename_File ;
    Menu_NORMAL( menu, MSPECIAL ) ;
  END ;

  PROCEDURE disk ;
  BEGIN
    Menu_Hilight( menu, MSPECIAL ) ;
    Disk_Space ;
    Menu_Normal( menu, MSPECIAL ) ;
  END ;

  PROCEDURE print ;
  BEGIN
    Menu_Hilight( menu, MSPECIAL ) ;
    Print_File ;
    Menu_Normal( menu, MSPECIAL ) ;
  END ;

  PROCEDURE deleteF ;
  BEGIN
    Menu_Hilight( menu, MSPECIAL ) ;
    Delete_File ;
  END ;

  PROCEDURE deleteD ;
  BEGIN
    Menu_Hilight( menu, MSPECIAL ) ;
    Setup_DFolder ;
  END ;

  PROCEDURE createD ;
  BEGIN
    Menu_Hilight( menu, MSPECIAL ) ;
    Create_Folder ;
    Menu_Normal( menu, MSPECIAL ) ;
  END ;

  PROCEDURE Event_Loop ;
    VAR
      what_key,
      which : integer ;
      done : boolean ;
      msg : Message_Buffer ;

    BEGIN
      done := FALSE ;
      REPEAT
        which := Get_Event( E_keyboard|E_Message, 0, 0, 0, 0,
                    false, 0, 0, 0, 0, false, 0, 0, 0, 0,
                    msg, what_key, dummy, dummy, dummy, dummy, dummy ) ;
        IF which & E_Message <> 0 THEN
          BEGIN
           IF msg[0]=MN_Selected THEN done := Do_Menu( msg[3], msg[4] ) ;
          END
        ELSE IF which & E_Keyboard <> 0 THEN
          BEGIN
            Wind_Update( Beg_Mctrl ) ;
            IF what_key = $6100 THEN done := TRUE
            {Allow control OR ALTERNATE key presses!}
            ELSE IF (what_key = $1205) OR (what_key = $1200) THEN edit
            ELSE IF (what_key = $2E03) OR (what_key = $2E00) THEN compile
            ELSE IF (what_key = $260C) OR (what_key = $2600) THEN link
            ELSE IF (what_key = $1312) OR (what_key = $1300) THEN run
            ELSE IF what_key = $3B00 THEN copyF
            ELSE IF what_key = $3C00 THEN createD
            ELSE IF what_key = $3D00 THEN rename
            ELSE IF what_key = $3E00 THEN disk
            ELSE IF what_key = $3F00 THEN print
            ELSE IF what_key = $4000 THEN deleteF
            ELSE IF what_key = $4100 THEN deleteD ;
            IF (what_key<>$1312) AND (what_key<>$1300) THEN
              Wind_Update( End_Mctrl ) ;
          END ;
      UNTIL done ;
    END ;


FUNCTION Low_Resolution : boolean ;
BEGIN
  rez := get_rez ;                (* need to remember screen resolution *)
  Low_Resolution := (rez = 0) ;
END ;


(* main *)
  BEGIN
    IF Init_Gem <> -1 THEN
      BEGIN
        IF NOT Load_Resource( 'pascalm.rsc' ) THEN
          dummy := Do_Alert( '[3][PASCALM.RSC not found!][ Cancel ]', 0 )
        ELSE IF Low_Resolution THEN
          BEGIN
            bad_res := '[3][You must use medium or|high resolution to use|';
            bad_res := ConCat(bad_res, 'Personal Pascal.][ Cancel ]');
            dummy := Do_Alert(bad_res, 0);
          END
        ELSE
          BEGIN
            Set_Defaults ;
            Read_Options( 'PASCALM.INF', FALSE ) ;
            new( envp ) ;
            envp^[0] := chr(0) ;
            Find_Menu( PASMENU, menu ) ;
            Draw_Menu( menu ) ;
            Init_Mouse ;
            formdo( BEGINFO, HIDE ) ;
            Event_Loop ;
            Erase_Menu( menu ) ;
          END ;
        Exit_Gem ;
      END ;
  END .

(* End of PASCALM.PAS }