TP3/shell/Shell.mod

MODULE Shell ;

(* TP3 main-menu shell.  Draws the Turbo Pascal 3.0 screen with ANSI
   escapes and dispatches on the same command letters as the original
   (TPSRC4 kmenu / kcmdtab).  Editor, compiler and interpreter are
   placeholders for now; the shell logic (files, directory, options,
   save/load with .BAK) mirrors the original closely. *)

FROM Term IMPORT
   Open, Close, ClrScr, GotoXY, PutCh, PutStr, PutCard, PutLongCard,
   ScrnWide, Marked, Normal, GetCh, Beep ;

FROM Posix IMPORT
   read, write, open, close, unlink, rename,
   getcwd, chdir, opendir, readdir, closedir, statvfs,
   Dir, dirent, statvfsbuf ;

FROM Compiler IMPORT Compile, CodeBytes, DataBytes, ImageBytes ;
FROM Linker IMPORT LinkSize, WriteCom ;
FROM Editor IMPORT Run, GotoOffset ;

FROM TextBuf IMPORT
   TextLimit, Clear, Length, CharAt, InsertCh ;

FROM SYSTEM IMPORT ADR, ADDRESS, BYTE ;

CONST
   O_RDONLY  = 0 ;      (* linux *)

VAR
   drive     : CHAR ;
   workName  : ARRAY [0..255] OF CHAR ;
   mainName  : ARRAY [0..255] OF CHAR ;
   changed   : BOOLEAN ;

   codeDest  : CARDINAL ;        (* 0=Memory, 1=COM, 2=CHN *)
   errNo, errPos : CARDINAL ;
   minCode, minData, minStack, maxStack : CARDINAL ;
   paramLine : ARRAY [0..255] OF CHAR ;

(* ------------------------------------------------------------------ *)
(*  string helpers                                                    *)
(* ------------------------------------------------------------------ *)

PROCEDURE StrLen (VAR s : ARRAY OF CHAR) : CARDINAL ;
VAR i : CARDINAL ;
BEGIN
   i := 0 ;
   WHILE (i <= HIGH (s)) AND (s [i] # 0C) DO
      INC (i)
   END ;
   RETURN i
END StrLen ;

PROCEDURE StrClear (VAR s : ARRAY OF CHAR) ;
BEGIN
   s [0] := 0C
END StrClear ;

PROCEDURE StrCopy (VAR dst : ARRAY OF CHAR ; src : ARRAY OF CHAR) ;
VAR i : CARDINAL ;
BEGIN
   i := 0 ;
   LOOP
      IF i > HIGH (dst) THEN
         dst [HIGH (dst)] := 0C ;
         EXIT
      END ;
      IF i > HIGH (src) THEN
         dst [i] := 0C ;
         EXIT
      END ;
      IF src [i] = 0C THEN
         dst [i] := 0C ;
         EXIT
      END ;
      dst [i] := src [i] ;
      INC (i)
   END
END StrCopy ;

PROCEDURE StrAppend (VAR dst : ARRAY OF CHAR ; suffix : ARRAY OF CHAR) ;
VAR i, j : CARDINAL ;
BEGIN
   i := StrLen (dst) ;
   j := 0 ;
   LOOP
      IF i > HIGH (dst) THEN
         EXIT
      END ;
      IF j > HIGH (suffix) THEN
         dst [i] := 0C ;
         EXIT
      END ;
      IF suffix [j] = 0C THEN
         dst [i] := 0C ;
         EXIT
      END ;
      dst [i] := suffix [j] ;
      INC (i) ;
      INC (j)
   END
END StrAppend ;

PROCEDURE StrEq (VAR a, b : ARRAY OF CHAR) : BOOLEAN ;
VAR i : CARDINAL ;
BEGIN
   i := 0 ;
   LOOP
      IF (i > HIGH (a)) OR (i > HIGH (b)) THEN
         RETURN FALSE
      END ;
      IF (a [i] = 0C) AND (b [i] = 0C) THEN
         RETURN TRUE
      END ;
      IF a [i] # b [i] THEN
         RETURN FALSE
      END ;
      INC (i)
   END ;
   RETURN FALSE
END StrEq ;

PROCEDURE Upper (ch : CHAR) : CHAR ;
BEGIN
   IF (ch >= "a") AND (ch <= "z") THEN
      RETURN CHR (ORD (ch) - (ORD ("a") - ORD ("A")))
   END ;
   RETURN ch
END Upper ;

PROCEDURE CrLf ;
BEGIN
   PutCh (CHR (13)) ;
   PutCh (CHR (10))
END CrLf ;

PROCEDURE GetCwd (VAR buf : ARRAY OF CHAR) ;
VAR i : CARDINAL ;
BEGIN
   IF getcwd (ADR (buf), 4096) = NIL THEN
      buf [0] := 0C
   END
END GetCwd ;

(* ------------------------------------------------------------------ *)
(*  marks one command letter then prints the rest of the label        *)
(* ------------------------------------------------------------------ *)

PROCEDURE Key (letter, rest : ARRAY OF CHAR) ;
BEGIN
   Marked ;
   PutCh (letter [0]) ;
   Normal ;
   PutStr (rest)
END Key ;

(* ------------------------------------------------------------------ *)
(*  input line editing (no echo from termios): CR or LF ends the line, *)
(*  backspace deletes the last char, the result is stored 0C-terminated*)
(* ------------------------------------------------------------------ *)

PROCEDURE ReadLine (VAR s : ARRAY OF CHAR) : CARDINAL ;
VAR len : CARDINAL ;
    ch   : CHAR ;
BEGIN
   StrClear (s) ;
   len := 0 ;
   LOOP
      GetCh (ch) ;
      IF (ch = CHR (13)) OR (ch = CHR (10)) THEN
         PutCh (CHR (13)) ;
         PutCh (CHR (10)) ;
         EXIT
      ELSIF (ch = CHR (8)) OR (ch = CHR (127)) THEN
         IF len > 0 THEN
            DEC (len) ;
            PutStr (" ")     (* backspace over the char *)
         END
      ELSIF ch = CHR (27) THEN
         (* ESC: cancel the current edit *)
         EXIT
      ELSIF (ch >= " ") AND (ch <= "~") AND (len < HIGH (s)) THEN
         s [len] := ch ;
         INC (len) ;
         PutCh (ch)
      END
   END ;
   s [len] := 0C ;
   RETURN len
END ReadLine ;

PROCEDURE Pause ;
VAR ch : CHAR ;
BEGIN
   Beep ;
   GetCh (ch)
END Pause ;

PROCEDURE WaitEsc ;
VAR ch : CHAR ;
BEGIN
   LOOP
      GetCh (ch) ;
      IF (ch = CHR (27)) OR (ch = "q") OR (ch = "Q") THEN
         EXIT
      END
   END
END WaitEsc ;

(* return true if the user confirms with Y / y *)
PROCEDURE Confirm (prompt : ARRAY OF CHAR) : BOOLEAN ;
VAR ch : CHAR ;
BEGIN
   PutStr (prompt) ;
   GetCh (ch) ;
   IF (ch = "y") OR (ch = "Y") THEN
      CrLf ;
      RETURN TRUE
   END ;
   CrLf ;
   RETURN FALSE
END Confirm ;

(* ------------------------------------------------------------------ *)
(*  file name handling                                                *)
(* ------------------------------------------------------------------ *)

(* Does the name contain a '.' ? *)
PROCEDURE HasExt (VAR s : ARRAY OF CHAR) : BOOLEAN ;
VAR i : CARDINAL ;
BEGIN
   i := 0 ;
   WHILE (i <= HIGH (s)) AND (s [i] # 0C) DO
      IF s [i] = "." THEN
         RETURN TRUE
      END ;
      INC (i)
   END ;
   RETURN FALSE
END HasExt ;

(* replaces the current work file, appending .PAS when needed *)
PROCEDURE SetWorkName (VAR s : ARRAY OF CHAR) ;
BEGIN
   StrCopy (workName, s) ;
   IF NOT HasExt (workName) THEN
      StrAppend (workName, ".PAS")
   END
END SetWorkName ;

(* The .COM name for the current work file: the same path with .COM.
   TP3 derives the output name the same way (it hands the destination to the
   overlay loader with the extension swapped), so FOO.PAS links to FOO.COM
   in whatever directory the source lives, not to the current directory.

   The dot is found by scanning for the LAST one, not the first: a Pascal
   path may well contain a directory component with a dot in it, and taking
   the first would truncate the directory and write the .COM somewhere else. *)
PROCEDURE ComName (VAR dst : ARRAY OF CHAR) ;
VAR i, dot : CARDINAL ;
BEGIN
   IF StrLen (workName) = 0 THEN
      StrClear (dst) ;
      RETURN
   END ;
   StrCopy (dst, workName) ;
   dot := 0 ;
   i := 0 ;
   WHILE (i <= HIGH (workName)) AND (workName [i] # 0C) DO
      IF workName [i] = "." THEN
         dot := i
      END ;
      INC (i)
   END ;
   IF dot = 0 THEN
      (* no extension at all - just append *)
      StrCopy (dst, workName) ;
      StrAppend (dst, ".COM")
   ELSE
      (* cut at the dot, then append *)
      i := dot ;
      WHILE (i <= HIGH (dst)) DO
         dst [i] := 0C ;
         INC (i)
      END ;
      StrAppend (dst, ".COM")
   END
END ComName ;

(* ------------------------------------------------------------------ *)
(*  buffered save of the work file: .BAK = old version, then ^Z       *)
(* ------------------------------------------------------------------ *)

PROCEDURE SaveWorkFile ;
VAR fd      : INTEGER ;
    path    : ARRAY [0..511] OF CHAR ;
    w       : LONGINT ;
    i       : CARDINAL ;
    msg     : ARRAY [0..255] OF CHAR ;
    b       : BYTE ;
BEGIN
   IF StrLen (workName) = 0 THEN
      PutStr ("        ...work file not set") ;
      CrLf ;
      Pause ;
      RETURN
   END ;

   StrClear (msg) ;
   StrAppend (msg, "Saving A:") ;
   StrAppend (msg, workName) ;
   PutStr (msg) ;

   StrClear (path) ;
   StrAppend (path, workName) ;
   StrAppend (path, ".BAK") ;
   w := unlink (ADR (path)) ;            (* drop old backup *)

   StrClear (path) ;
   StrAppend (path, workName) ;
   StrAppend (path, ".BAK") ;
   StrClear (msg) ;
   StrAppend (msg, workName) ;
   w := rename (ADR (msg), ADR (path)) ; (* old version -> .BAK *)

   StrClear (path) ;
   StrAppend (path, workName) ;
   fd := open (ADR (path), 1 + 512 + 64, 420) ;   (* O_WRONLY|O_TRUNC|O_CREAT, 0644 *)
   IF fd < 0 THEN
      CrLf ;
      PutStr ("        ...cannot create file") ;
      Pause ;
      RETURN
   END ;
   i := 0 ;
   WHILE i < Length () DO
      IF CharAt (i) = CHR (13) THEN
         b := CHR (13) ;
         w := write (fd, ADR (b), 1) ;
         b := CHR (10) ;
         w := write (fd, ADR (b), 1)
      ELSE
         b := VAL (BYTE, ORD (CharAt (i))) ;
         w := write (fd, ADR (b), 1)
      END ;
      INC (i)
   END ;
   b := CHR (26) ;                        (* EOF marker ^Z, TP3 style *)
   w := write (fd, ADR (b), 1) ;
   w := close (fd) ;
   changed := FALSE ;
   CrLf
END SaveWorkFile ;

(* ------------------------------------------------------------------ *)
(*  load a file into the text buffer; stop at ^Z or TextLimit         *)
(* ------------------------------------------------------------------ *)

PROCEDURE LoadWorkFile ;
VAR fd       : INTEGER ;
    path     : ARRAY [0..511] OF CHAR ;
    k        : LONGINT ;
    b        : BYTE ;
    prevCR, tooBig : BOOLEAN ;
BEGIN
   StrClear (path) ;
   StrAppend (path, workName) ;
   fd := open (ADR (path), O_RDONLY, 0) ;
   IF fd < 0 THEN
      PutStr ("New File") ;
      CrLf ;
      Clear ;
      changed := FALSE ;
      Pause ;
      RETURN
   END ;

   tooBig := FALSE ;
   prevCR := FALSE ;
   Clear ;
   LOOP
      IF Length () >= TextLimit THEN
         tooBig := TRUE ;
         EXIT
      END ;
      k := read (fd, ADR (b), 1) ;
      IF k # 1 THEN
         EXIT
      END ;
      IF b = CHR (26) THEN
         EXIT
      ELSIF b = CHR (10) THEN
         IF NOT prevCR THEN
            InsertCh (Length (), CHR (13))   (* lone LF -> CR *)
         END ;
         prevCR := FALSE
      ELSIF b = CHR (13) THEN
         InsertCh (Length (), CHR (13)) ;
         prevCR := TRUE
      ELSE
         InsertCh (Length (), CHR (ORD (b))) ;
         prevCR := FALSE
      END
   END ;
   k := close (fd) ;
   IF tooBig THEN
      PutStr ("File too big") ;
      CrLf
   END ;
   changed := FALSE ;
   Pause
END LoadWorkFile ;

(* ------------------------------------------------------------------ *)
(*  directory listing (kdir)                                          *)
(* ------------------------------------------------------------------ *)

PROCEDURE MatchMask (VAR m, n : ARRAY OF CHAR) : BOOLEAN ;
VAR mi, ni, saveMi, saveNi : CARDINAL ;
    isAll : BOOLEAN ;
BEGIN
   (* DOS-style: "*.*" and "*" mean "everything" *)
   isAll := TRUE ;
   mi := 0 ;
   WHILE (mi <= HIGH (m)) AND (m [mi] # 0C) DO
      IF NOT ((m [mi] = "*") OR (m [mi] = ".")) THEN
         isAll := FALSE
      END ;
      INC (mi)
   END ;
   IF isAll THEN
      RETURN TRUE
   END ;

   mi := 0 ;
   ni := 0 ;
   saveMi := 0 ;
   saveNi := 0 ;
   LOOP
      (* mask exhausted *)
      IF (mi <= HIGH (m)) AND (m [mi] = "*") THEN
         saveMi := mi ;
         WHILE (mi <= HIGH (m)) AND (m [mi] = "*") DO
            INC (mi)
         END ;
         IF mi > HIGH (m) THEN
            RETURN TRUE
         END ;
         saveNi := ni
      ELSIF (mi > HIGH (m)) OR (m [mi] = 0C) THEN
         RETURN (ni <= HIGH (n)) AND (n [ni] = 0C)
      ELSIF (ni <= HIGH (n)) AND (n [ni] # 0C) AND
            (Upper (m [mi]) = Upper (n [ni])) THEN
         INC (mi) ;
         INC (ni)
      ELSIF saveMi > 0 THEN
         INC (saveNi) ;
         IF saveNi > HIGH (n) THEN
            RETURN FALSE
         END ;
         ni := saveNi ;
         mi := saveMi + 1
      ELSIF (ni > HIGH (n)) OR (n [ni] = 0C) THEN
         RETURN FALSE
      ELSE
         RETURN FALSE
      END
   END ;
   RETURN FALSE
END MatchMask ;

PROCEDURE DirCmd ;
VAR mask     : ARRAY [0..255] OF CHAR ;
    d        : Dir ;
    p        : POINTER TO dirent ;
    count    : CARDINAL ;
    freeK    : LONGCARD ;
    sv       : statvfsbuf ;
    i        : CARDINAL ;
    w        : INTEGER ;
BEGIN
   PutStr ("Dir mask: ") ;
   IF ReadLine (mask) = 0 THEN
      StrCopy (mask, "*.*")
   END ;
   CrLf ;

   d := opendir (ADR (".")) ;
   IF d = NIL THEN
      PutStr ("No files") ;
      CrLf ;
      Pause ;
      RETURN
   END ;
   count := 0 ;
   LOOP
      p := readdir (d) ;
      IF p = NIL THEN
         EXIT
      END ;
      IF (p^.d_name [0] # ".") AND
         (MatchMask (mask, p^.d_name)) THEN
         INC (count) ;
         PutStr (p^.d_name) ;
         i := 1 + (12 - StrLen (p^.d_name) MOD 12) ;
         IF i > 12 THEN
            i := 12
         END ;
         ScrnWide (i)
      END
   END ;
   w := closedir (d) ;
   CrLf ;
   IF count = 0 THEN
      PutStr ("No files") ;
      CrLf
   END ;
   IF statvfs (ADR ("."), ADR (sv)) = 0 THEN
      freeK := (sv.f_bavail * sv.f_frsize) DIV 1024 ;
      PutLongCard (freeK) ;
      PutStr ("k bytes free") ;
      CrLf
   END ;
   Pause
END DirCmd ;

(* ------------------------------------------------------------------ *)
(*  main menu                                                         *)
(* ------------------------------------------------------------------ *)

PROCEDURE DrawMenu ;
VAR cwd   : ARRAY [0..4095] OF CHAR ;
    freeB : CARDINAL ;
    i     : CARDINAL ;
BEGIN
   ClrScr ;

   GotoXY (1, 1) ;
   Key ("L", "ogged drive: ") ;
   PutCh (drive) ;

   GetCwd (cwd) ;
   GotoXY (2, 1) ;
   Key ("A", "ctive directory: ") ;
   PutStr (cwd) ;

   GotoXY (4, 1) ;
   Key ("W", "ork file: A:") ;
   PutStr (workName) ;

   GotoXY (5, 1) ;
   Key ("M", "ain file: A:") ;
   PutStr (mainName) ;

   GotoXY (7, 1) ;
   Key ("E", "dit     ") ;
   Key ("C", "ompile  ") ;
   Key ("R", "un   ") ;
   Key ("S", "ave") ;

   GotoXY (9, 1) ;
   Key ("D", "ir      ") ;
   Key ("Q", "uit  compiler ") ;
   Key ("O", "ptions") ;

   GotoXY (11, 1) ;
   PutStr ("Text: ") ;
   PutCard (Length ()) ;
   PutStr (" bytes") ;

   freeB := TextLimit - Length ();
   GotoXY (12, 1) ;
   PutStr ("Free: ") ;
   PutCard (freeB) ;
   PutStr (" bytes") ;

   GotoXY (14, 1) ;
   Marked ;
   PutCh (">") ;
   Normal
END DrawMenu ;

(* ------------------------------------------------------------------ *)
(*  command handlers                                                  *)
(* ------------------------------------------------------------------ *)

PROCEDURE CmdLogDrive ;
VAR nm : ARRAY [0..255] OF CHAR ;
    ln : CARDINAL ;
BEGIN
   ClrScr ;
   GotoXY (1, 1) ;
   PutStr ("New drive: ") ;
   ln := ReadLine (nm) ;
   IF ln = 1 THEN
      drive := Upper (nm [0]) ;
      IF (drive < "A") OR (drive > "P") THEN
         drive := "A"
      END
   ELSIF ln > 1 THEN
      (* treat as a directory instead (linux has no real drives) *)
      IF chdir (ADR (nm)) # 0 THEN
         PutStr ("File not found") ;
         CrLf ;
         Pause
      END
   END
END CmdLogDrive ;

PROCEDURE CmdActDir ;
VAR nm : ARRAY [0..255] OF CHAR ;
BEGIN
   ClrScr ;
   GotoXY (1, 1) ;
   PutStr ("New directory: ") ;
   IF ReadLine (nm) > 0 THEN
      IF chdir (ADR (nm)) # 0 THEN
         PutStr ("File not found") ;
         CrLf ;
         Pause
      END
   END
END CmdActDir ;

PROCEDURE CmdWorkFile ;
VAR nm       : ARRAY [0..255] OF CHAR ;
    txtTitle : ARRAY [0..511] OF CHAR ;
BEGIN
   ClrScr ;
   GotoXY (1, 1) ;
   PutStr ("Work file name: ") ;
   IF ReadLine (nm) > 0 THEN
      IF changed THEN
         CrLf ;
         PutStr ("            ") ;
         IF Confirm ("Save current work file now (Y/N) ?") THEN
            SaveWorkFile
         END
      END ;
      ClrScr ;
      GotoXY (1, 1) ;
      SetWorkName (nm) ;
      StrClear (txtTitle) ;
      StrAppend (txtTitle, "Loading A:") ;
      StrAppend (txtTitle, workName) ;
      PutStr (txtTitle) ;
      CrLf ;
      LoadWorkFile
   END
END CmdWorkFile ;

PROCEDURE CmdMainFile ;
VAR nm : ARRAY [0..255] OF CHAR ;
BEGIN
   ClrScr ;
   GotoXY (1, 1) ;
   PutStr ("Main file name: ") ;
   IF ReadLine (nm) > 0 THEN
      StrCopy (mainName, nm) ;
      IF NOT HasExt (mainName) THEN
         StrAppend (mainName, ".PAS")
      END
   END
END CmdMainFile ;

PROCEDURE CmdCompile ;
VAR comPath : ARRAY [0..255] OF CHAR ;
BEGIN
   ClrScr ;
   GotoXY (1, 1) ;
   IF Compile (errNo, errPos) THEN
      PutStr ("Compiled OK - code ") ;
      PutCard (CodeBytes ()) ;
      PutStr (" bytes, data ") ;
      PutCard (DataBytes ()) ;
      CrLf ;
      (* Destination, as TP3's Options submenu sets it: 0 = Memory (the
         debugger runs the code in place), 1 = .COM, 2 = .CHN.
         Until now the choice was displayed and then ignored, which was a
         fidelity gap: selecting COM did nothing at all. *)
      CASE codeDest OF
      | 0 :
            PutStr ("Destination: Memory (code left in the buffer)") ;
            CrLf
      | 2 :
            (* .CHN is Turbo Pascal's TBIOS overlay format; the original
               wrote it with its own overlay loader.  Refuse rather than
               pretend - the user's next R would not find anything. *)
            PutStr ("Destination: .CHN is not implemented") ;
            CrLf
      ELSE
            PutStr ("Destination: .COM") ;
            CrLf ;
            ComName (comPath) ;
            IF WriteCom (comPath) THEN
               PutStr ("  wrote ") ;
               PutStr (comPath) ;
               PutStr ("  ") ;
               PutCard (LinkSize ()) ;
               PutStr (" bytes (image ") ;
               PutCard (ImageBytes ()) ;
               PutStr (")")
            ELSE
               (* WriteCom unlinked any partial file, so there is no half
                  file to clean up here. *)
               PutStr ("  could not write ") ;
               PutStr (comPath) ;
               PutStr (" - disk error?")
            END ;
            CrLf
      END ;
      PutStr ("press ESC to return to the editor") ;
      CrLf ;
      WaitEsc
   ELSE
      PutStr ("TP3-style error ") ;
      PutCard (errNo) ;
      PutStr (" at relative pos ") ;
      PutCard (errPos) ;
      CrLf ;
      PutStr ("press ESC, then the editor opens on the error") ;
      CrLf ;
      WaitEsc ;
      (* TP3 kcwait: waitesc ; BX:=txerrpos ; DEC BX ; JMP editor2.
         Net cursor position = txbeg + txerrpos, i.e. errPos here. *)
      GotoOffset (errPos) ;
      CmdEditor
   END
END CmdCompile ;

PROCEDURE CmdRun ;
BEGIN
   ClrScr ;
   GotoXY (1, 1) ;
   PutStr ("Interpreter pending - compiled code is in memory") ;
   CrLf ;
   PutStr ("(TP3 option R / debugger not yet wired)") ;
   CrLf ;
   WaitEsc
END CmdRun ;

PROCEDURE CmdEditor ;
VAR edChanged : BOOLEAN ;
BEGIN
   IF StrLen (workName) = 0 THEN
      (* kgetfn: no work file yet -> prompt just like W does *)
      CmdWorkFile ;
      IF StrLen (workName) = 0 THEN
         RETURN
      END
   END ;
   edChanged := FALSE ;
   Run (drive, workName, edChanged) ;
   IF edChanged THEN
      changed := TRUE
   END
END CmdEditor ;

(* ------------------------------------------------------------------ *)
(*  TP3  "Options" submenu (optmenu)                                  *)
(* ------------------------------------------------------------------ *)

PROCEDURE PutHex (n : CARDINAL) ;
VAR dig : ARRAY [0..7] OF CHAR ;
    i, d : CARDINAL ;
BEGIN
   i := 0 ;
   LOOP
      d := n MOD 16 ;
      IF d < 10 THEN
         dig [i] := CHR (ORD ("0") + d)
      ELSE
         dig [i] := CHR (ORD ("A") + d - 10)
      END ;
      n := n DIV 16 ;
      INC (i) ;
      IF (n = 0) OR (i = 8) THEN
         EXIT
      END
   END ;
   WHILE i > 0 DO
      DEC (i) ;
      PutCh (dig [i])
   END
END PutHex ;

PROCEDURE OptionsMenu ;
VAR ch : CHAR ;
    s  : ARRAY [0..255] OF CHAR ;
    done : BOOLEAN ;
BEGIN
   done := FALSE ;
   REPEAT
      ClrScr ;
      GotoXY (1, 1) ;
      Marked ; PutCh ("M") ; Normal ;
      PutStr ("emory   ") ;
      Marked ; PutCh ("C") ; Normal ;
      PutStr ("OM   ") ;
      Marked ; PutCh ("H") ; Normal ;
      PutStr ("CHN") ;
      CrLf ;
      PutStr ("           ") ;
      IF codeDest = 1 THEN
         PutStr ("Compile   ->   COM")
      ELSIF codeDest = 2 THEN
         PutStr ("Compile   ->   CHN")
      ELSE
         PutStr ("Compile   ->   Memory")
      END ;
      CrLf ;
PutStr ("Text: ") ;
   PutCard (Length ()) ;
      PutStr ("  Code: ") ;
      PutHex (minCode) ;
      PutStr ("  Data: ") ;
      PutHex (minData) ;
      PutStr ("  Stack: ") ;
      PutHex (minStack) ;
      CrLf ;
      PutStr ("Command line Params: ") ;
      PutStr (paramLine) ;
      CrLf ;
      Marked ; PutCh ("F") ; Normal ;
      PutStr ("ind run-time error     ") ;
      Marked ; PutCh ("Q") ; Normal ;
      PutStr ("uit") ;
      CrLf ;
      CrLf ;
      Marked ; PutCh (">") ; Normal ;

      GetCh (ch) ;
      ch := Upper (ch) ;
      CASE ch OF
      | "M" : codeDest := 0
      | "C" : codeDest := 1
      | "H" : codeDest := 2
      | "O" :
           ClrScr ; GotoXY (1,1) ;
           PutStr ("Min Code Segment (hex): ") ;
           IF ReadLine (s) > 0 THEN minCode := 0 END
      | "D" :
           ClrScr ; GotoXY (1,1) ;
           PutStr ("Min Data Segment (hex): ") ;
           IF ReadLine (s) > 0 THEN minData := 0 END
      | "I" :
           ClrScr ; GotoXY (1,1) ;
           PutStr ("Min Free Dyn Mem / Stack (hex): ") ;
           IF ReadLine (s) > 0 THEN minStack := 0 END
      | "A" :
           ClrScr ; GotoXY (1,1) ;
           PutStr ("Max Free Dyn Mem / Stack (hex): ") ;
           IF ReadLine (s) > 0 THEN maxStack := 0 END
      | "P" :
           ClrScr ; GotoXY (1,1) ;
           PutStr ("Command line Params: ") ;
           IF ReadLine (paramLine) > 0 THEN
              (* keep the parameter string *) 
           END
      | "F" :
           ClrScr ; GotoXY (1,1) ;
           PutStr ("Find run-time error address (hex) : ") ;
           IF ReadLine (s) > 0 THEN
              PutStr ("Searching ... (not implemented)") ;
              CrLf ;
              Pause
           END
      | "Q" :
           done := TRUE
      ELSE
         (* ignore *)
      END
   UNTIL done
END OptionsMenu ;

(* ------------------------------------------------------------------ *)

PROCEDURE terminal ;
VAR ch : CHAR ;
BEGIN
   Open ;
   drive := "A" ;
   codeDest := 0 ;
   minCode := 0 ; minData := 0 ; minStack := 0 ; maxStack := 0 ;
   StrClear (workName) ;
   StrClear (mainName) ;
   StrClear (paramLine) ;
   Clear ;
   changed := FALSE ;

   LOOP
      DrawMenu ;
      GetCh (ch) ;
      ch := Upper (ch) ;
      CASE ch OF
      | "L" : CmdLogDrive
      | "A" : CmdActDir
      | "W" : CmdWorkFile
      | "M" : CmdMainFile
      | "E" : CmdEditor
      | "C" : CmdCompile
      | "R" : CmdRun
      | "S" :
           IF StrLen (workName) > 0 THEN
              SaveWorkFile ;
              Pause
           END
      | "D" : DirCmd
      | "O" : OptionsMenu
      | "Q" :
           IF changed THEN
              CrLf ;
              IF Confirm ("Work file not saved. Save (Y/N) ?") THEN
                 SaveWorkFile
              END
           END ;
           Close ;
           (* gm2 -fiso: a bare HALT aborts (SIGABRT, shell status 134);
              an explicit HALT (0) exits cleanly with status 0. *)
           HALT (0)
      ELSE
         (* any other key: redraw the menu, like TP3 *)
      END
   END
END terminal ;

BEGIN
   terminal
END Shell.