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 SYSTEM IMPORT ADR, ADDRESS, BYTE ;

CONST
   TextLimit = 62903 ;
   O_RDONLY  = 0 ;      (* linux *)

VAR
   drive     : CHAR ;
   workName  : ARRAY [0..255] OF CHAR ;
   mainName  : ARRAY [0..255] OF CHAR ;
   txt       : ARRAY [0..TextLimit] OF BYTE ;
   txtLen    : CARDINAL ;
   changed   : BOOLEAN ;

   codeDest  : CARDINAL ;        (* 0=Memory, 1=COM, 2=CHN *)
   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 ;

(* ------------------------------------------------------------------ *)
(*  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 < txtLen DO
      w := write (fd, ADR (txt [i]), 1) ;
      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 ;
    n, i     : CARDINAL ;
    k        : LONGINT ;
    b        : BYTE ;
    tooBig   : BOOLEAN ;
BEGIN
   StrClear (path) ;
   StrAppend (path, workName) ;
   fd := open (ADR (path), O_RDONLY, 0) ;
   IF fd < 0 THEN
      PutStr ("New File") ;
      CrLf ;
      txtLen := 0 ;
      changed := FALSE ;
      Pause ;
      RETURN
   END ;

   tooBig := FALSE ;
   txtLen := 0 ;
   LOOP
      IF txtLen >= TextLimit THEN
         tooBig := TRUE ;
         EXIT
      END ;
      k := read (fd, ADR (b), 1) ;
      IF k # 1 THEN
         EXIT
      END ;
      IF b = CHR (26) THEN
         EXIT
      END ;
      txt [txtLen] := b ;
      INC (txtLen)
   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 (txtLen) ;
   PutStr (" bytes") ;

   freeB := TextLimit - txtLen ;
   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 ;
BEGIN
   ClrScr ;
   GotoXY (1, 1) ;
   PutStr ("Compiler under construction - press ESC") ;
   CrLf ;
   WaitEsc
END CmdCompile ;

PROCEDURE CmdRun ;
BEGIN
   ClrScr ;
   GotoXY (1, 1) ;
   PutStr ("Compiler / interpreter under construction - press ESC") ;
   CrLf ;
   WaitEsc
END CmdRun ;

PROCEDURE CmdEditor ;
BEGIN
   ClrScr ;
   GotoXY (1, 1) ;
   PutStr ("Editor under construction - press ESC") ;
   CrLf ;
   WaitEsc
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 (txtLen) ;
      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) ;
   txtLen := 0 ;
   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 ;
           HALT
      ELSE
         (* any other key: redraw the menu, like TP3 *)
      END
   END
END terminal ;

BEGIN
   terminal
END Shell.