path: root/app/diskettenmonitor/3.5/src/disk 3.5-m.quelle

(************************************************************************) 
(*                                                                      *)
(*  DDDD   IIIII   SSSS  K  K      3333      55555      /  M     M      *)
(*  D   D    I    S      K K           3     5         /   MM   MM      *)
(*  D   D    I     SSS   KK         333      5555     /    M M M M      *)
(*  D   D    I        S  K K           3         5   /     M  M  M      *)
(*  DDDD   IIIII  SSSS   K  K      3333   O  5555   /      M     M      *)
(*                                                                      *)
(************************************************************************)
(*                                                                      *)
(* Diskettenmonitor   Version 3.5 Multi                                 *)
(*                                                                      *)
(* Autor : Ingo Siekmann unter freundlicher Mithilfe von Stefan Haase,  *)
(*                                Nils Ehnert, APu und Frank Lenniger   *)
(*                                                                      *)
(* Stand : Sonntag, den 16. November 1986                               *)
(*                                                                      *)
(* Lauffähig ab EUMEL Version 1.7.3 /M in Systemtasks                   *)
(*                                                                      *)
(*                                                                      *)
(* (c) 1986 by ULES c/o Ingo Siekmann & Nils Ehnert                     *)
(*                                                                      *)
(************************************************************************)
(************************************************************************)
(*                                                                      *)
(* Softwareaenderungen und Softwareneuerungen :                         *)
(*                                                                      *)
(* 03.01.1986 3.3.2.8 : Block- Asciieditor ueberarbeitet, neuer Header- *)
(*                      editor (V1.3), Helpfunktion, gib kommando,      *)
(*                      Fileaccess auch fuer 16-Files                   *)
(* 15.01.1986 3.3.2.9 : Vorbereitung fuer den Suchmodus in 3.3.3.0,     *)
(*                      Notbremse ins globalmenue mit ctrl g, byte ops  *)
(*                      ueberarbeitet, pic dienste in vorbereitung      *)
(*                      Headereditor (V1.4)                             *)
(* 16.01.1986         : halt from terminal --> ctrl g := true           *)
(* 16.01.1886 3.3.3.0 : Suchmodus ins Blockmenue (TEST), Blockeditor    *)
(*                      Byteposops fuer Suchmodus einbauen              *)
(* 21.01.1986         : inchar in get char umgewandelt                  *)
(* 28.01.1986         : lernmodus eingebaut (???)                       *)
(* 31.01.1986 3.3.3.1 : Suchmodus und Lernmodus wieder ausgebaut        *)
(*                      beim Datenraumschreiben nur belegte Bloecke raus*)
(* 14.02.1986 3.3.3.2 : Fehler Überarbeitet                             *)
(* 20.02.1986         : Suchmodus vorbereitet (2. Versuch ?)            *)
(* 06.03.1986 3.3.3.3 : Suchmodus eingebaut (Test)                      *)
(* 10.03.1986         : Softwaretrennung zwischen Single und Multi      *)
(* 12.03.1986         : read next block cmd ins blockmenu eingebaut     *)
(*                      Fehler überarbeitet, Vorbereitung für besseren  *)
(*                      Suchmodus                                       *)
(* 17.03.1986 3.3.3.4 : configurator menü -> einstellen von disk type,  *)
(*                      i/o channel, disk info. TEXT/HEX search .       *)
(* 02.04.1986         : urflop ops mit versatzops                       *)
(* 08.04.1986         : urflop menue mit versatz                        *)
(* 30.04.1986 3.3.3.5 : Fehler ueberarbeitet                            *)
(* 30.04.1986 3.3.3.6 : lab read/write ins space menue                  *)
(* 05.05.1986 3.3.3.7 : hex / dez - get für alles, block editor über-   *)
(*                      arbeitet, fehler überarbeitet. auslieferung für *)
(*                      HRZ !                                           *)
(* 06.06.1986 3.4     : Fehler im search und menue monitor behoben      *)
(* 12.06.1986         : Fehler im Space/Header-Menue behoben            *)
(* 16.11.1986 3.5     : Fehler im Urflopmenue behoben                   *)
(*                                                                      *)
(*       A C H T U N G  : Keine weitere Entwicklung von Version 3 !!    *)
(*                                                                      *)
(*            Bielefeld, den 16.11.1986        ULES                     *)
(*                                                                      *)
(*                      Ingo Siekmann                                   *)
(*                                                                      *)
(*                                                                      *)
(************************************************************************)

PACKET byte operations and disk monitor version 35 multi 
 
       DEFINES  BYTE , 
                HEX , 
                ASCII , 
                DECRL , 
                DECRH , 
                INCRL , 
                INCRH ,
                := ,
                - ,
                + ,
                $ , 
                hint ,
                zu byte ,
                lower byte ,
                higher byte ,
                set lower byte ,
                set higher byte ,
                nil byte ,
                put ,
                get ,

                block in ,
                block out ,

                HEADER , 
                header ,
                nil header ,
                is start header ,
                is end header ,
                is file header ,
                name ,
                date ,
                type ,
                pass ,
                header edit ,

                show first ,
                show second ,
                block edit ,
                ascii edit ,

                set ctrl g ,
                reset ctrl g ,

                set channel ,
                read block ,
                write block ,
                seek space ,
                seek block ,
                read space ,
                write space ,
                check archive error ,

                space nr ,
                header nr ,

                urlader lesen ,
                urlader schreiben ,
                urlader lesen auf seite ,
                urlader schreiben von seite ,

                search ,

                io control ,

                central disk monitor process : 



LET start of volume = 1000 ,
    end of volume   =    1 ,
    file header     =    3 ;

LET global info line  = "** GLOBAL : b / s / a / c / u / k / q     # stop --> ctrl g, help --> ""?"" **" ,
    block info line   = "** BLOCK  : r / w / e / k / s / n / q     # stop --> ctrl g, help --> ""?"" **" ,
    search info line  = "** SEARCH : a -> ascii / h -> hex / q -> quit / ctrl g -> stop            **" ,
    editor info line  = "** EDITOR : f / s / d / e / k / p / q     # stop --> ctrl g, help --> ""?"" **" ,
    space info line   = "** SPACE  : r, R, w, W, e, E, s, l, k, q  # stop --> ctrl g, help --> ""?"" **" ,
    space header info = "** SPACE / HEADER : s -> read space / h -> read header / q -> quit        **" ,
    archiv info line  = "** ARCHIV : a / r / l / f / s / k / q     # stop --> ctrl g, help --> ""?"" **" ,
    urflop info line  = "** URFLOP : r / R / w / W / l / k / q     # stop --> ctrl g, help --> ""?"" **" ,
    conf info line    = "** CONFIGURATOR : c / t / i / k / q       # stop --> ctrl g, help --> ""?"" **" ,
    first mon line    = "----------------------------------------------------------------------------" ,
    command line      = ">__________________________________________________________________________<" ; 
 
LET global chars = "bsacuqk?"7"" ,
    block chars  = "rweqksn?"7"" ,
    search chars = "ahdq"7"" ,
    editor chars = "fsdeqk?"7"p" ,
    space chars  = "rRwWesqEkl?"7"" ,
    archiv chars = "arlfsqk?"7"" ,
    urflop chars = "rRwWlqk?"7"" ,
    conf chars   = "ctikq?"7"" ;

LET info line x pos    =    1 ,
    info line y pos    =   20 ,
    info line x pos 2  =    1 ,
    info line y pos 2  =   24 ,
    command line x pos =    1 ,
    command line y pos =   21 ,
    error line x pos   =    1 ,
    error line y pos   =   22 ,

    file type          = 1003 ,
    file type 16       = 1002 ,

    block 0            =    0 ,

    std archive channel =  31 ,

    type mode          =    1 ,
    size mode          =    5 ,
    std disk type      =    0 ;

LET software stand      = "Sonntag, den 16.11.1986" ,
    software version    = "Version  3.5 /Multi" ,
    software bemerkung  = "*** Ende der Entwicklung der Version 3 ! ***" ,
    software bemerkung1 = "" ;

LET eumel 0 start block        = 10 ,
    eumel 0 end block          = 65 ,
    eumel 0 end block pic      = 62 ,
    eumel 0 end block 1758     = 67 ,
    pic char table start block = 63 ,
    pic char table end block   = 65 ,
    pic shard start block      =  0 ,
    pic shard end block        = 79 ,

    read write impossible error = 101 ,
    read error                  = 102 ,
    write error                 = 103 ,
    block number error          = 104 ,
    undef archive error         = 105 ;

LET ibm 720 format 5            = 1440 ,
    ibm 360 format 5            =  720 ,
    pic 400 format 5            = 1600 ,
    soft sd 8                   = 1232 ,
    soft dd 8                   = 2464 ,
    hard ss sd                  =  616 ,
    hard ds sd                  = 1232 ;

LET home                = ""1"" ,
    left                = ""8"" ,
    right               = ""2"" ,
    up                  = ""3"" ,
    down                = ""10"" ,
    return              = ""13"" ,
    tab                 = ""9"" ,
    esc                 = ""27"" ,
    cl eol              = ""5"" ,
    cl eop              = ""4"" ;

LET hex chars  = "0123456789ABCDEF" ,
    hex marker = "h" ;

LET start pos      = 479 , 
    heap page nr   =   2 ; 
 

TYPE HEADER = STRUCT (TEXT name, date, INT type, TEXT pass) ;
 
TYPE BYTE = STRUCT (INT lower byte , higher byte) ; 


HEADER CONST nil header := HEADER : ("", "", 0, "") ;
BOUND HEADER VAR bound header ;
BOUND TEXT VAR bound text ;

INITFLAG VAR this packet := false ;

ROW 256 BYTE VAR block ;
ROW 32 TEXT VAR text block ;
ROW 256 INT VAR block int ;

DATASPACE VAR ds :: nilspace ; forget (ds) ;
DATASPACE VAR afds :: nilspace ; forget (afds) ;
DATASPACE VAR lds :: nilspace ; forget (lds) ;
DATASPACE VAR uds :: nilspace ; forget (uds) ; 
DATASPACE VAR blkinds :: nilspace ; forget (blkinds) ;

FILE VAR af, f, lf ; 

INT VAR command index, block nummer, space nummer, x, y, i, i1, xx, yy, 
        archive channel := std archive channel, user channel, error answer,
        header nummer, first sp block, integer, archiv size, error, block nr,
        stpos, s, e, fb, fp, cx, cy, disk type := std disk type, ver ;

TEXT VAR c, hex line :: "", tc, char, t, archive name, dummy,
         stb1, stb2, own command line ;

REAL VAR po ;

BOOL VAR first := true, ende, list file ok, block shown, ctrl g, result ;
 

(********************** PACKET bytes ok :       ****************************)


BYTE PROC nil byte : 
  BYTE : (0,0)
END PROC nil byte ; 
 
OP := (BYTE VAR byte , BYTE CONST old byte) : 
  byte.lower byte  := old byte.lower byte ; 
  byte.higher byte := old byte.higher byte. 
END OP := ; 
 
OP := (BYTE VAR byte , INT CONST int byte) : 
  byte.lower byte  := int byte MOD 256 ; 
  byte.higher byte := (int byte AND -256) DIV 256 AND 255 . 
END OP := ; 
 
OP := (ROW 256 BYTE VAR byte, ROW 256 INT CONST int byte) :
  INT VAR i ;
  FOR i FROM 1 UPTO 256 REPEAT
    byte (i) := int byte (i)
  END REPEAT .
END OP := ;

OP := (ROW 256 INT VAR int byte, ROW 256 BYTE CONST byte) :
  INT VAR i ;
  FOR i FROM 1 UPTO 256 REPEAT 
    int byte (i) := byte (i)
  END REPEAT .
END OP := ;

BYTE OP + (BYTE VAR byte , INT CONST int byte) : 
  byte.lower byte := byte.lower byte + lower byte (int byte) ; 
  byte.higher byte := byte.higher byte + higher byte (int byte) ; 
  byte . 
END OP + ; 
 
BYTE OP - (BYTE VAR byte, INT CONST int byte) : 
  byte.lower byte := byte.lower byte - lower byte (int byte) ; 
  byte.higher byte := byte.higher byte - higher byte (int byte) ; 
  byte . 
END OP - ; 
 
OP := (INT VAR int byte, BYTE CONST byte) : 
  IF byte.higher byte > 127 
    THEN int byte := minus * 255 + minus + byte.lower byte
    ELSE int byte := byte.higher byte * 256 + byte.lower byte 
  END IF

.minus : byte.higher byte - 256 .
END OP := ; 
 
OP INCRL (BYTE VAR byte, INT CONST lower) :
  byte.lower byte INCR lower 
END OP INCRL ;

OP INCRH (BYTE VAR byte, INT CONST high) :
  byte.higher byte INCR high 
END OP INCRH ;

OP DECRL (BYTE VAR byte, INT CONST lower) :
  byte.higher byte DECR lower
END OP DECRL ;

OP DECRH (BYTE VAR byte, INT CONST high) :
  byte.higher byte DECR high
END OP DECRH ;

INT PROC lower byte (BYTE CONST byte) :
  byte.lower byte .
END PROC lower byte ;

INT PROC higher byte (BYTE CONST byte) :
  byte.higher byte .
END PROC higher byte ;

INT PROC lower byte (INT CONST int byte) : 
  int byte MOD 256 . 
END PROC lower byte ; 
 
INT PROC higher byte (INT CONST int byte) : 
  (int byte AND -256) DIV 256 AND 255 . 
END PROC higher byte ; 
 
PROC set lower byte (BYTE VAR byte, INT CONST lower byte) :
  byte.lower byte := lower byte 
END PROC set lower byte ;

PROC set higher byte (BYTE VAR byte, INT CONST higher byte) :
  byte.higher byte := higher byte 
END PROC set higher byte ;
 
OP HEX (TEXT VAR insert line , BYTE CONST byte) : 
   insert line CAT (hex chars SUB (byte.lower byte  DIV 16 + 1)) ; 
   insert line CAT (hex chars SUB (byte.lower byte  MOD 16 + 1)) ; 
   insert line CAT " " ; 
   insert line CAT (hex chars SUB (byte.higher byte DIV 16 + 1)) ; 
   insert line CAT (hex chars SUB (byte.higher byte MOD 16 + 1)) ; 
   insert line CAT " " . 
END OP HEX ; 
 
OP ASCII (TEXT VAR insert line , BYTE CONST byte) : 
  insert line CAT ascii (byte.lower byte ) ; 
  insert line CAT ascii (byte.higher byte) . 
END OP ASCII ;
 
TEXT PROC ascii (INT CONST half byte) : 
  IF half byte >  31 AND half byte < 127 COR 
     half byte > 213 AND half byte < 219 COR 
     half byte = 251
    THEN code (half byte) 
    ELSE "." 
  END IF . 
END PROC ascii ; 
 
PROC block in (ROW 256 BYTE VAR block bytes, INT CONST type , block nr) : 
  ROW 256 INT VAR block ; 
  reset block io ;
  block in (block, type, block nr, error answer) ; 
  block bytes := block ; 
  check archive error (error answer, true) .
END PROC block in ; 

PROC block out (ROW 256 BYTE CONST bytes , INT CONST disk type, block nr) :
  ROW 256 INT VAR int bytes := bytes ;
  reset block io ;
  block out (int bytes, disk type, block nr, error answer) ;
  check archive error (error answer, true) .
END PROC block out ;

PROC put (BYTE CONST byte) : 
  put ("LOW : " + text (byte.lower byte) + " HIGH : " + text (byte.higher byte)) .
END PROC put ; 
 
PROC get (BYTE VAR byte) : 
  get (integer) ; 
  byte := integer . 
END PROC get ; 
 
PROC zu byte (ROW 256 BYTE VAR bytes, TEXT CONST byte kette, INT CONST stelle) :
  INT VAR lower, higher ;
  lower := pos (hex chars, (byte kette SUB 1)) * 16 +
           pos (hex chars, (byte kette SUB 2)) - 17 ;
  higher:= pos (hex chars, (byte kette SUB 4)) * 16 +
           pos (hex chars, (byte kette SUB 5)) - 17 ;
  IF higher > 127
    THEN bytes (stelle) := minus * 255 + minus + lower
    ELSE bytes (stelle) := higher * 256 + lower
  END IF .

minus : higher - 256 .
END PROC zu byte ;

BYTE OPERATOR $ (TEXT CONST hex) : 
    TEXT VAR byte kette :: ""; 
    FOR i FROM 1 UPTO 4 REPEAT
       IF (hex SUB i) = "" 
         THEN byte kette CAT "0" 
       ELIF (hex SUB i) = " " 
         THEN (* Nix *) 
         ELSE byte kette CAT (hex SUB i) 
       END IF ; 
    END REPEAT ; 
    BYTE VAR byte ;
    INT VAR lower, higher, i; 
    lower := pos (hex chars, (byte kette SUB 1)) * 16 + 
             pos (hex chars, (byte kette SUB 2)) - 17 ; 
    higher:= pos (hex chars, (byte kette SUB 3)) * 16 + 
             pos (hex chars, (byte kette SUB 4)) - 17 ; 
    IF higher > 127 
      THEN byte := minus * 255 + minus + lower 
      ELSE byte := higher * 256 + lower
    END IF ; 
    byte . 

minus : higher - 256 . 
END OPERATOR $ ; 

INT PROCEDURE hint (TEXT CONST he) :
    INT VAR laenge :: length (he) ,
            stelle ,
            ziffer ,
            ergebnis :: 0 ;

    TEXT VAR h :: he ;

    FOR stelle FROM 65 UPTO 70 REPEAT
      change all (h, code (stelle + 32), code (stelle))
    END REPEAT ;

    FOR stelle FROM laenge DOWNTO 1 REP
      ziffer := pos ("0123456789ABCDEF", h SUB stelle) - 1 ;
      IF ziffer < 0 
        THEN errorstop ("Unerlaubtes Zeichen in Hexadezimalzahl")
      END IF ;
      ergebnis := ergebnis + ziffer * 16 ** (laenge - stelle)
    END REP ;
    ergebnis
END PROCEDURE hint ;


(********************** PACKET header operations ***************************)


OPERATOR := (HEADER VAR dest, HEADER CONST source) :
    CONCR (dest) := CONCR (source) .
END OPERATOR := ;

HEADER PROCEDURE header (TEXT CONST name, date, INT CONST type,
                         TEXT CONST pass) :
    HEADER : (name, date, type, pass) .
END PROCEDURE header ;

BOOL PROCEDURE is start header (HEADER CONST header) :
    CONCR (header).type = start of volume .
END PROCEDURE is start header ;

BOOL PROCEDURE is end header (HEADER CONST header) :
    CONCR (header).type = end of volume .
END PROCEDURE is end header ;

BOOL PROCEDURE is file header (HEADER CONST header) :
    CONCR (header).type = file header .
END PROCEDURE is file header ;

PROCEDURE name (HEADER VAR header, TEXT CONST new name) :
    CONCR (header).name := new name .
END PROCEDURE name ;

TEXT PROCEDURE name (HEADER CONST header) :
    CONCR (header).name .
END PROCEDURE name ;

PROCEDURE date (HEADER VAR header, TEXT CONST new date) :
    CONCR (header).date := new date .
END PROCEDURE date ;

TEXT PROCEDURE date (HEADER CONST header) :
    CONCR (header).date .
END PROCEDURE date ;

PROCEDURE type (HEADER VAR header, INT CONST new type) :
    CONCR (header).type := new type .
END PROCEDURE type ;

INT PROCEDURE type (HEADER CONST header) :
    CONCR (header).type .
END PROCEDURE type ;

PROCEDURE pass (HEADER VAR header, TEXT CONST new pass) :
    CONCR (header).pass := new pass .
END PROCEDURE pass ;

TEXT PROCEDURE pass (HEADER CONST header) :
    CONCR (header).pass .
END PROCEDURE pass ;


(**********************   Header-Editor V1.4    ****************************)


PROCEDURE header edit (HEADER VAR header, TEXT CONST msg) :
    TEXT VAR head :: ""15"HEADER - EDITOR V1.4" + (25 - LENGTH msg) * "." + msg +
                     5 * "." + " "14"" ;
    disable stop ;
    REPEAT
      out (home) ;
      out (16 * (cl eol + down)) ;
      cursor (6, 6) ;
      putline (head) ;
      cursor (6, 7) ;
      put (""15"TEXT name : "14"") ;
      edit get (CONCR (header).name, max text length, 38) ;
      IF is error
        THEN clear error ;
             CONCR (header).name := "" ;
             cursor (6, 7) ;
             put (""15"TEXT name : "14"") ;
             edit get (CONCR (header).name, max text length, 38) 
      END IF ;
      cursor (6, 8) ;
      put (""15"TEXT date : "14"") ;
      edit get (CONCR (header).date, max text length, 38) ;
      IF is error
        THEN clear error ;
             CONCR (header).date := "" ;
             cursor (6, 8) ;
             put (""15"TEXT date : "14"") ;
             edit get (CONCR (header).date, max text length, 38) 
      END IF ;
      cursor (6, 9) ;
      put (""15"INT type  : "14"") ;
      TEXT VAR d :: text (CONCR (header).type) ;
      edit get (d, max text length, 38) ;
      CONCR (header).type := int (d) ;
      cursor (6, 10) ;
      put (""15"TEXT pass : "14"") ;
      edit get (CONCR (header).pass, max text length, 38) ;
      IF is error
        THEN clear error ;
             CONCR (header).pass := "" ;
             cursor (6, 10) ;
             put (""15"TEXT pass : "14"") ;
             edit get (CONCR (header).pass, max text length, 38) 
      END IF ;
      cursor (6, 13) ;
    UNTIL NOT no (""15"header ok. "14"") END REPEAT 
END PROCEDURE header edit ;
 

(********************** PACKET block editor     ****************************)


PROCEDURE show first (ROW 256 BYTE CONST block) :
    out (home) ;
    po := 1.0 ;
    first := true ;
    FOR i FROM 1 UPTO 16 REPEAT
      text block (i) := text ((i - 1) * 16, 4) ;
      text block (i) CAT " : " ;
      get cursor (x, y) ;
      FOR i1 FROM 1 UPTO 8 REPEAT
         text block (i) HEX block ((i-1) * 8 + i1)
      END REPEAT ;
      text block (i) CAT "  *" ;
      FOR i1 FROM 1 UPTO 8 REPEAT
         text block (i) ASCII block ((i - 1) * 8 + i1)
      END REPEAT ;
      text block (i) CAT "*" ;
      cursor (x, y) ;
      putline (text block (i))
    END REPEAT .
END PROCEDURE show first ;

PROCEDURE show second (ROW 256 BYTE CONST block) :
    out (home) ;
    po := 129.0 ;
    first := false ;
    FOR i FROM 17 UPTO 32 REPEAT
      text block (i) := text ((i - 1) * 16, 4) ;
      text block (i) CAT " : " ;
      get cursor (x,y) ;
      FOR i1 FROM 1 UPTO 8 REPEAT
         text block (i) HEX block ((i - 1) * 8 + i1) 
      END REPEAT ;
      text block (i) CAT "  *" ;
      FOR i1 FROM 1 UPTO 8 REPEAT
         text block (i) ASCII block ((i - 1) * 8 + i1)
      END REPEAT ;
      text block (i) CAT "*" ;
      cursor (x, y);
      putline (text block (i))
    END REPEAT .
END PROCEDURE show second ;
 
PROCEDURE block edit (ROW 256 BYTE VAR block, INT CONST st) :
    IF st > 0
      THEN IF st > 255
             THEN push (255 * right)
             ELSE push (st * right)
           END IF 
    END IF ;
    BOOL VAR low :: TRUE ;
    edit info ;
    cursor (8, 1) ;
    get cursor (x, y) ;
    po := 1.0 ;
    REPEAT 
      get cursor (x, y) ;
      cursor (x, y) ;
  (*  inchar (t) ;  *)
      get char (t) ;
      IF (t = right OR t = " ") AND x < 53 
        THEN cursor (x + 3, y) ; po INCR 0.5
      ELIF (t = right OR t = " ") AND  x > 52 AND y < 16
        THEN cursor (8, y + 1) ; po INCR 0.5
      ELIF t = up AND y > 1
        THEN cursor (x, y - 1) ; po DECR 8.0
      ELIF t = left AND x > 8
        THEN cursor (x - 3, y) ; po DECR 0.5
      ELIF t = left AND x = 8 AND y <> 1
        THEN cursor (53, y - 1) ; po DECR 0.5
      ELIF t = down AND y < 16
        THEN cursor (x, y + 1) ; po INCR 8.0
      ELIF t = tab 
        THEN IF first 
               THEN show first (block)
               ELSE show second (block)
             END IF ;
             ascii edit (block, first) ;
             IF first 
               THEN show first (block)
               ELSE show second (block)
             END IF ; 
             IF t <> return
               THEN edit info ;
                    cursor (8, 1) ;
             END IF 
      ELIF t = ""7""
        THEN set ctrl g 
      END IF ;
      get cursor (x, y) ;
      cursor (x, y);
      IF code (t) > 47 AND code (t) < 58 OR
         code (t) > 96 AND code (t) < 103
        THEN IF code (t) > 96 CAND code (t) < 103
               THEN t := code (code (t) - 32)
             END IF ;
             out (left + "-" + 2 * right + "-" + 3 * left + t) ;
             REPEAT
           (*  inchar (tc) ;  *)
               get char (tc) ;
             UNTIL code (tc) > 47 AND code (tc) < 58 OR
                   code (tc) > 96 AND code (tc) < 103   END REPEAT ;
             IF code (tc) > 96 CAND code (tc) < 103
               THEN tc := code (code (tc) - 32)
             END IF ;
             out (tc + " " + 4 * left + " ") ;
             cursor (x, y) ;
             t CAT tc ; 
             INT VAR bp :: int (po) ; 
             IF po MOD real (bp) = 0.0
               THEN low := TRUE
               ELSE low := FALSE
             END IF ;
             IF NOT first               (* ONE : 17.06.85 *)
               THEN bp INCR 128
             END IF ;
             IF low
               THEN set lower byte (block (bp), hint (t)) 
               ELSE set higher byte (block (bp), hint (t)) 
             END IF ;
      END IF ;
      info ;
    UNTIL t = return COR ctrl g END REPEAT ;
    IF first 
      THEN show first (block)
      ELSE show second (block)
    END IF ;
    cursor (1, 17) .

info :
  get cursor (x, y) ;
  cursor (xx, yy) ;
  IF po MOD real (int(po)) = 0.0
    THEN put ("LOW") 
    ELSE put ("HIGH")
  END IF ; 
  cursor (x,y) .

edit info :
  cursor (1, 23) ;
  put (cl eol + "Block-Editor : Hexmodus,") ;
  IF first
    THEN put ("First Block")
    ELSE put ("Second Block")
  END IF ;
  put (",") ;
  get cursor (xx, yy) .
END PROCEDURE block edit ;
 
PROCEDURE block edit (ROW 256 BYTE VAR block, BOOL CONST first,
                      INT CONST st) :
 
    IF st > 0
      THEN IF st > 255
             THEN push (255 * right)
             ELSE push (st * right)
           END IF 
    END IF ;
    BOOL VAR low :: TRUE ;
    edit info ;
    cursor (8, 1) ;
    get cursor (x, y) ;
    po := 1.0 ;
    REPEAT 
      get cursor (x, y) ;
      cursor (x, y) ;
  (*  inchar (t) ;  *)
      get char (t) ;
      IF (t = right OR t = " ") AND x < 53 
        THEN cursor (x + 3, y) ; po INCR 0.5
      ELIF (t = right OR t = " ") AND  x > 52 AND y < 16
        THEN cursor (8, y + 1) ; po INCR 0.5
      ELIF t = up AND y > 1
        THEN cursor (x, y - 1) ; po DECR 8.0
      ELIF t = left AND x > 8
        THEN cursor (x - 3, y) ; po DECR 0.5
      ELIF t = left AND x = 8 AND y <> 1
        THEN cursor (53, y - 1) ; po DECR 0.5
      ELIF t = down AND y < 16
        THEN cursor (x, y + 1) ; po INCR 8.0
      ELIF t = tab 
        THEN IF first 
               THEN show first (block)
               ELSE show second (block)
             END IF ;
             ascii edit (block, first) ;
             IF first 
               THEN show first (block)
               ELSE show second (block)
             END IF ; 
             IF t <> return
               THEN edit info ;
                    cursor (8, 1) ;
             END IF 
      ELIF t = ""7""
        THEN set ctrl g
      END IF ;
      get cursor (x, y) ;
      cursor (x, y);
      IF code (t) > 47 AND code (t) < 58 OR
         code (t) > 96 AND code (t) < 103
        THEN IF code (t) > 96 CAND code (t) < 103
               THEN t := code (code (t) - 32)
             END IF ;
             out (left + "-" + 2 * right + "-" + 3 * left + t) ;
             REPEAT
           (*  inchar (tc) ;  *)
               get char (tc) ;
             UNTIL code (tc) > 47 AND code (tc) < 58 OR
                   code (tc) > 96 AND code (tc) < 103   END REPEAT ;
             IF code (tc) > 96 CAND code (tc) < 103
               THEN tc := code (code (tc) - 32)
             END IF ;
             out (tc + " " + 4 * left + " ") ;
             cursor (x, y) ;
             t CAT tc ; 
             INT VAR bp :: int (po) ; 
             IF po MOD real (bp) = 0.0
               THEN low := TRUE
               ELSE low := FALSE
             END IF ;
             IF NOT first               (* ONE : 17.06.85 *)
               THEN bp INCR 128
             END IF ;
             IF low
               THEN set lower byte (block (bp), hint (t)) 
               ELSE set higher byte (block (bp), hint (t)) 
             END IF ;
      END IF ;
      info ;
    UNTIL t = return COR ctrl g END REPEAT ;
    IF first 
      THEN show first (block)
      ELSE show second (block)
    END IF ;
    cursor (1, 17) .

info :
  get cursor (x, y) ;
  cursor (xx, yy) ;
  IF po MOD real (int(po)) = 0.0
    THEN put ("LOW") 
    ELSE put ("HIGH")
  END IF ; 
  cursor (x,y) .

edit info :
  cursor (1, 23) ;
  put (cl eol + "Block-Editor : Hexmodus,") ;
  IF first
    THEN put ("First Block")
    ELSE put ("Second Block")
  END IF ;
  put (",") ;
  get cursor (xx, yy) .
END PROCEDURE block edit ;
 
PROCEDURE ascii edit (ROW 256 BYTE VAR block, BOOL CONST first) :
    BOOL VAR low ;
    edit info ;
    cursor (59, 1) ;
    x := 1 ;
    y := 1 ;
    po := 1.0 ;
    REPEAT
      get char (t) ;
      IF po < 1.0 AND first
        THEN po := 1.0
      END IF ;
      IF po < 129.0 AND NOT first
        THEN po := 129.0 
      END IF ;
      IF po > 128.5 AND first
        THEN po := 128.5 
      END IF ;
      IF po > 256.5 AND NOT first
        THEN po := 256.5 
      END IF ;
      SELECT pos (""9""8""2""3""10""13""7"", t) OF
        CASE 1, 6 : quit ascii edit
        CASE 2    : IF x > 1 COR (x = 1 AND y > 1)
                      THEN x DECR 1; po DECR 0.5
                    END IF 
        CASE 3    : IF x < 16 COR (x = 16 AND y <> 16)
                      THEN x INCR 1; po INCR 0.5 
                    END IF 
        CASE 4    : IF y > 1
                      THEN y DECR 1 ;
                           po DECR 8.0 
                    END IF 
        CASE 5    : IF y < 16
                      THEN y INCR 1 ;
                           po INCR 8.0 
                    END IF 
        CASE 7    : set ctrl g
       OTHERWISE IF code (t) >= 32 AND code (t) <= 126
                   THEN set char ; push (""2"")
                 END IF
      END SELECT ;
      IF x < 1 AND y = 1
        THEN x := 1
      ELIF x < 1 AND y > 1
        THEN x := 16 ;
             y DECR 1
      ELIF x > 16 AND y = 16
        THEN x := 16 ;
      ELIF x > 16 AND y < 16
        THEN x := 1 ;
             y INCR 1
      ELIF y < 1
        THEN y := 1
      ELIF y > 16
        THEN y := 16
      END IF ;
      info ;
    UNTIL ctrl g END REPEAT .

quit ascii edit :
  x := 8 ;
  y := 1 ;
  cursor (x, y) ;
  po := 1.0 ;
  LEAVE ascii edit .

set char :
  out (t) ;
  INT VAR bp :: int (po) ;
  IF x MOD 2 = 0 
    THEN set higher byte (block (bp), code (t))
    ELSE set lower  byte (block (bp), code (t))
  END IF.

info :
  cursor (xx, yy) ;
  IF po MOD real (int (po)) = 0.0
    THEN put ("LOW") 
    ELSE put ("HIGH")
  END IF ; 
  cursor (58 + x, y) .

edit info :
  cursor (1, 23) ;
  put (""5"Block-Editor : Asciimodus,") ;
  IF first
    THEN put ("First Block")
    ELSE put ("Second Block")
  END IF ;
  put (",") ;
  get cursor (xx, yy) .
END PROCEDURE ascii edit ;


(********************** PACKET block i/o :      ****************************)


PROCEDURE set channel (INT CONST channel) :
    archive channel := channel .
END PROCEDURE set channel ;

PROCEDURE read block (ROW 256 BYTE VAR block byte, INT CONST block nummer) :
    user channel := channel ;
    enable stop ;
    continue (archive channel) ;
    disable stop ;
    block in (block int, disk type, block nummer, error answer) ;
    IF is error
      THEN clear error
    END IF ;
    break (quiet) ;
    continue (user channel) ;
    enable stop ;
    check archive error (error answer, true) ;
    block byte := block int .
END PROCEDURE read block ;

PROCEDURE write block (ROW 256 BYTE VAR block byte, INT CONST block nummer) :
    user channel := channel ;
    enable stop ;
    block int := block byte ;
    continue (archive channel) ;
    disable stop ;
    block out (block int, disk type, block nummer, error answer) ;
    IF is error
      THEN clear error
    END IF ;
    break (quiet) ;
    continue (user channel) ;
    enable stop ;
    check archive error (error answer, false) .
END PROCEDURE write block;

PROCEDURE read block (ROW 256 INT VAR block int, INT CONST block nummer) :
    user channel := channel ;
    enable stop ;
    continue (archive channel) ;
    disable stop ;
    block in (block int, disk type, block nummer, error answer) ;
    IF is error
      THEN clear error
    END IF ;
    break (quiet) ;
    continue (user channel) ;
    enable stop ;
    check archive error (error answer, true) .
END PROCEDURE read block ;

PROC write block (ROW 256 INT VAR block int, INT CONST block nummer) :
    user channel := channel ;
    enable stop ;
    continue (archive channel) ;
    disable stop ;
    block out (block int, disk type, block nummer, error answer) ;
    IF is error
      THEN clear error
    END IF ;
    break (quiet) ;
    continue (user channel) ;
    enable stop ;
    check archive error (error answer, false) .
END PROCEDURE write block ;


(********************** PACKET space i/o :      ****************************)


PROCEDURE seek space (INT CONST space) :
    user channel := channel ;
    enable stop ;
    rewind ;
    INT VAR i ;
    continue (archive channel) ;
    disable stop ;
    FOR i FROM 1 UPTO space REPEAT
      skip dataspace
    UNTIL is error END REPEAT ;
    break (quiet) ;
    continue (user channel) .
END PROCEDURE seek space ;

PROCEDURE seek block (INT CONST block nr) :
    seek (block nr) .
END PROCEDURE seek block ;

PROCEDURE read space (DATASPACE VAR ds) :
    user channel := channel ;
    enable stop ;
    continue (archive channel) ;
    disable stop ;
    read (ds) ;
    break (quiet) ;
    continue (user channel) .
END PROCEDURE read space ;

PROCEDURE read space (DATASPACE VAR ds, INT VAR max pages,
                      BOOL CONST errors) :
    user channel := channel ;
    enable stop ;
    continue (archive channel) ;
    disable stop ;
    read (ds, max pages, errors) ;
    break (quiet) ;
    continue (user channel) .
END PROCEDURE read space ;

PROCEDURE write space (DATASPACE CONST ds) :
    user channel := channel ;
    enable stop ;
    continue (archive channel) ;
    disable stop ;
    write (ds) ;
    break (quiet) ;
    continue (user channel) .
END PROCEDURE write space ;

PROCEDURE check archive error (INT CONST code, BOOL CONST read) :
    enable stop ;
    IF read 
      THEN SELECT code OF
             CASE 0 :
             CASE 1 : error stop (read write impossible error,
                                  "Lesen unmoeglich (1)")
             CASE 2 : error stop (read error,
                                  "Lesefehler (2)")
             CASE 3 : error stop (block number error,
                                  "Blocknummer zu hoch (3)")
            OTHERWISE error stop (undef archive error,
                                  "Archivfehler unbekannt ("+ text (code) +")") 
           END SELECT
      ELSE SELECT code OF
             CASE 0 :
             CASE 1 : error stop (read write impossible error,
                                  "Schreiben unmoeglich (1)")
             CASE 2 : error stop (write error,
                                  "Schreibfehler (2)")
             CASE 3 : error stop (block number error,
                                  "Blocknummer zu hoch (3)")
            OTHERWISE error stop (undef archive error,
                                  "Archivfehler unbekannt ("+ text (code) +")")
           END SELECT
    END IF .
END PROCEDURE check archive error ;


(********************** PACKET menue monitor :  ****************************)


PROCEDURE fehler behandeln :
    IF is error CAND error message <> "" 
      THEN IF is halt from terminal
             THEN set ctrl g 
             ELSE cursor (error line x pos, error line y pos) ; 
                  clear error ;
                  put (cl eol +"Fehler : "+ error message) 
           END IF 
    END IF .
END PROCEDURE fehler behandeln ;

PROCEDURE set ctrl g :
    ctrl g := true .
END PROCEDURE set ctrl g ;

PROCEDURE reset ctrl g :
    ctrl g := false .
END PROCEDURE reset ctrl g ;

PROCEDURE fehler loeschen :
    INT VAR x, y ;
    get cursor (x, y) ;
    cursor (1, 22) ;
    out (cl eol) ;
    cursor (1, 18) ;
    out (cl eol) ;
    cursor (1, 23) ;
    out (cl eol) ;
    cursor (x, y) .
END PROCEDURE fehler loeschen ;


(**********************     Global-Menue        ****************************)


PROCEDURE global menue :
    ende := false ;
    user channel := channel ;
    disable stop ;
    REPEAT
      menue monitor (global info line, global chars, command index) ;
      fehler loeschen ;
      SELECT command index OF
        CASE 1 : block menue
        CASE 2 : space menue
        CASE 3 : archive menue
        CASE 4 : configurator menue
        CASE 5 : urflop menue
        CASE 6 : out ("uit");ende := true ;
        CASE 7 : get and do one command ; block shown := false 
        CASE 8 : global menue help ; block shown := false 
        CASE 9 : set ctrl g 
      END SELECT ;
      fehler behandeln ;
    UNTIL ende COR ctrl g END REPEAT ;
    reset ctrl g ;
    ende := false .
END PROCEDURE global menue ;


(**********************     Block-Menue         ****************************)


PROCEDURE block menue :
    disable stop ;
    REPEAT
      menue monitor (block info line, block chars, command index) ;
      fehler loeschen ;
      SELECT command index OF
       CASE 1 : read one block
       CASE 2 : write one block
       CASE 3 : edit block menue
       CASE 4 : LEAVE block menue
       CASE 5 : get and do one command 
       CASE 6 : search menue
       CASE 7 : push ("r"+ text (block nummer + 1) +" ")
       CASE 8 : block menue help ; block shown := false 
       CASE 9 : set ctrl g
     END SELECT ;
     show first three ints ;
     display info line ;
     fehler behandeln 
   UNTIL ctrl g END REPEAT .
 
read one block :
  out ("ead Block : ") ;
  x get (block nummer) ;
  IF NOT is error
    THEN reset block io ;
         read block (block, block nummer)
  END IF ;
  IF NOT is error
    THEN show first (block) ; block shown := true
  END IF .

write one block :
  out ("rite") ;
  IF yes ("write auf Block "+ text (block nummer))
    THEN reset block io ;
         write block (block, block nummer)
  ELIF yes ("write auf einen anderen Block")
    THEN out (" auf Block : ") ;
         x get (block nummer) ;
         IF NOT is error
           THEN reset block io ;
                write block (block, block nummer) 
         END IF 
  END IF .

show first three ints :
  cursor (1, 18) ;
  put (""5"1.INT : ") ;
  TEXT VAR h :: "" ; h HEX block (1) ;
  INT VAR ih := block (1) ;
  h CAT ("/ " + text (ih)) ;
  put (h) ;
  put (", 2.INT : ") ;
  h := "" ; h HEX block (2) ;
  ih := block (2) ;
  h CAT ("/ " + text (ih)) ;
  put (h) ;
  put (", 3.INT : ") ;
  h := "" ; h HEX block (3) ;
  ih := block (3) ;
  h CAT ("/ " + text (ih)) ;
  put (h) .
END PROCEDURE block menue ;


(**********************     Search-Menue        ****************************)


PROCEDURE search menue :
    disable stop ;
    menue monitor (search info line, search chars, command index) ;
    fehler loeschen ;
    SELECT command index OF
       CASE 1 : ascii search
       CASE 2 : hex search
       CASE 3 : dez search
       CASE 4 : LEAVE search menue
       CASE 5 : set ctrl g
     END SELECT ;
     display info line ;
     fehler behandeln .

ascii search :
  cursor (command line x pos + 1, command line y pos) ;
  put ("Suchtext :") ; getline (t) ; 
  cursor (command line x pos + 1, command line y pos) ;
  put ("suchen nach """+ t +""" von Block :") ;
  x get (s) ; 
  cursor (command line x pos + 1, command line y pos) ;
  put ("suchen nach """+ t +""" von Block") ;
  put (s) ; put ("bis Block :") ; x get (e) ;
  search (t, s, e, fb, fp) ; 
  out (""13"") ;
  IF fp > 0 
    THEN put (cl eol +"Gefunden auf Block") ; put (fb) ;
         put (", Position") ; put (fp) ; 
         read block (block, fb) ; 
         IF fp < 256 
           THEN show first (block) 
           ELSE show second (block) 
         END IF ; 
         block shown := true ;
         st pos := (fp MOD 256) - 1 ;
         block nummer := fb ;
    ELSE put ("Nicht gefunden !!"); 
  FI .

hex search :
  cursor (command line x pos + 1, command line y pos) ;
  put ("Suchhex :") ; getline (t) ; 
  cursor (command line x pos + 1, command line y pos) ;
  put ("suchen nach """+ t +""" von Block :") ;
  x get (s) ; 
  cursor (command line x pos + 1, command line y pos) ;
  put ("suchen nach """+ t +""" von Block") ;
  put (s) ; put ("bis Block :") ; x get (e) ;
  change all (t, " ", "") ;
  TEXT VAR such hex := "" ;
  i := 1 ;
  REPEAT
    such hex CAT code (hint (subtext (t, i, i + 1))) ;
    i INCR 2
  UNTIL i >= length (t) END REPEAT ;
  search (such hex, s, e, fb, fp) ; 
  out (""13"") ;
  IF fp > 0 
    THEN put (cl eol +"Gefunden auf Block") ; put (fb) ;
         put (", Position") ; put (fp) ; 
         read block (block, fb) ; 
         IF fp < 256 
           THEN show first (block) 
           ELSE show second (block) 
         END IF ; 
         block shown := true ;
         st pos := (fp MOD 256) - 1 ;
         block nummer := fb ;
    ELSE put ("Nicht gefunden !!"); 
  FI .

dez search :
  error stop ("gibt es noch nicht !") .
END PROCEDURE search menue ; 


(**********************  Block-Editor-Menue     ****************************)


PROCEDURE edit block menue :
    INT VAR command index ;
    disable stop ;
    REPEAT
      fehler loeschen ; 
      show first three ints ;
      menue monitor (editor info line, editor chars, command index) ;
      SELECT command index OF
        CASE 1 : out ("irst") ;
                 show first (block) ;
                 block shown := true 
        CASE 2 : out ("econd") ;
                 show second (block) ;
                 block shown := true 
        CASE 3 : out ("ump") ;
                 show first (block) ; block edit (block, stpos) ;
                 show second (block) ; block edit (block, stpos) ;
                 block shown := true ;
        CASE 4 : IF NOT block shown 
                   THEN IF first
                          THEN show first (block)
                          ELSE show second (block)
                        END IF ;
                        block shown := true 
                 END IF ;
              (* IF first AND stpos >= 256
                   THEN show second (block) ;
                        block shown := true
                 ELIF NOT first AND stpos <= 256
                   THEN show first (block) ;
                        block shown := true
                 END IF ;                            *) (* ??? *)
                 block edit (block, stpos) 
        CASE 5 : LEAVE edit block menue
        CASE 6 : get and do one command ; block shown := false 
        CASE 7 : block editor menue help ;  block shown := false 
        CASE 8 : set ctrl g
        CASE 9 : INT VAR old st pos := st pos ;
                 out ("os auf Byte : ") ; 
                 x get (st pos) ;
                 IF st pos < 0 OR st pos > 513
                   THEN st pos := old st pos ;
                        error stop ("Zahl nicht ok")
                 END IF 
      END SELECT ;
      fehler behandeln
    UNTIL ctrl g END REPEAT .

show first three ints :
  cursor (1, 18) ;
  put (""5"1.INT : ") ;
  TEXT VAR h :: "" ; h HEX block (1) ;
  INT VAR ih := block (1) ;
  h CAT ("/ " + text (ih)) ;
  put (h) ;
  put (", 2.INT : ") ;
  h := "" ; h HEX block (2) ;
  ih := block (2) ;
  h CAT ("/ " + text (ih)) ;
  put (h) ;
  put (", 3.INT : ") ;
  h := "" ; h HEX block (3) ;
  ih := block (3) ;
  h CAT ("/ " + text (ih)) ;
  put (h) .
END PROCEDURE edit block menue ;


(**********************     Space-Menue         ****************************)


PROCEDURE space menue :
    disable stop ;
    REPEAT
      menue monitor (space info line, space chars, command index) ;
      fehler loeschen ;
      rewind ;
      SELECT command index OF
        CASE  1 : read one space 
        CASE  2 : bit map read
        CASE  3 : write one space
        CASE  4 : bit map write
        CASE  5 : edit one space
        CASE  6 : copy one space 
        CASE  7 : LEAVE space menue
        CASE  8 : new edit
        CASE  9 : get and do one command 
        CASE 10 : load one space 
        CASE 11 : space menue help 
        CASE 12 : set ctrl g
      END SELECT ;
      fehler behandeln ;
      display info line ;
    UNTIL ctrl g END REPEAT .

load one space :
  out ("aden aus Datei : ") ;
  getline (dummy) ;
  forget (ds) ;
  ds := nilspace ;
  ds := old (dummy) .

read one space :
  cursor (info line x pos, info line y pos) ;
  out (space header info) ;
  cursor (command line x pos + 2, command line y pos) ;
  out ("ead ") ;
  REPEAT
    get char (dummy)
  UNTIL pos ("shq"7"", dummy) > 0 END REPEAT ;
  IF dummy = "s"
    THEN out ("Space : ") ; read one s
  ELIF dummy = "h"
    THEN out ("Header : ") ; read one h
  ELIF dummy = ""7""
    THEN set ctrl g
  END IF .

read one s :
  x get (space nummer) ;
  IF NOT is error
    THEN seek space (space nummer) ;
         first sp block := block number + 1 ;
         forget (ds) ;
         ds := nilspace ;
         read space (ds)
  END IF .

read one h :
  x get (header nummer) ;
  space nummer := space nr (header nummer) ; 
  IF NOT is error
    THEN seek space (space nummer) ;
         first sp block := block number + 1 ;
         forget (ds) ;
         ds := nilspace ;
         read space (ds)
  END IF .

bit map read :
  out ("ead Space ab Block : ") ;
  x get (s) ;
  cursor (command line x pos + 1, command line y pos) ;
  out ("Read Space ab Block "+ text (s) +" Max. Bloecke : ") ;
  x get (e) ;
  seek block (s) ;
  IF e = 0 
    THEN e := 32000
  END IF ;
  forget (ds) ;
  ds := nilspace ;
  IF yes ("bei Lesefehlern abbrechen")
    THEN read space (ds, e, true)
    ELSE read space (ds, e, false)
  END IF .

write one space :
  out ("rite") ;
  IF yes ("write auf Space "+ text (space nummer))
    THEN seek space (space nummer) ;
         write space (ds) 
  ELIF yes ("write auf einen anderen Space")
    THEN out (" auf Space : ") ;
         x get (space nummer) ;
         IF NOT is error
           THEN seek space (space nummer) ;
                write space (ds)
         END IF 
  END IF .

bit map write :
  out ("rite Space ab Block : ") ;
  x get (s) ;
  seek block (s) ;
  write space (ds) .

edit one space :
  IF type (ds) = file type 16
    THEN change to 17 ;
         f := sequential file (modify, ds) ;
         edit (f, 1, 1, x size - 2, 16) ;
         block shown := false 
  ELIF type (ds) = file type
    THEN f := sequential file (modify, ds) ;
         edit (f, 1, 1, x size - 2, 16) ;
         block shown := false 
  ELIF ds pages (ds) = 1 CAND type (ds) = 0
    THEN edit header ;
         block shown := false 
  END IF .

change to 17 :
  TEXT VAR t := "" ;
  REPEAT
    t CAT "­"
  UNTIL NOT exists (t) END REPEAT ;
  copy (ds, t) ;
  reorganize (t) ;
  forget (ds) ;
  ds := nilspace ;
  ds := old (t) ;
  forget (t, quiet) .

copy one space :
  put ("ave in Datei : ") ;
  getline (t) ;
  copy (ds, t) .

edit header :
  bound header := ds ;
  cursor (1, 23) ;
  out (cl eol +"Header-Editor : ") ;
  IF is start header (bound header)
    THEN out ("Header ist ein Archiv-Startheader.")
  ELIF is file header (bound header)
    THEN out ("Header ist ein File-Header.")
  ELIF is end header (bound header)
    THEN out ("Header ist ein Archiv-Endheader.")
    ELSE out ("Header ist unbekannt (Headertype = "+ text (type (bound header)) +").")
  END IF ;
  header edit (bound header, "Headernummer : "+ text (header nr) + " ") .

new edit :
  out (left +"new edit ") ;
  block shown := false ;
  IF yes ("Neuen Headerspace erstellen")
    THEN create new header 
    ELSE create new file
  END IF .

create new header :
  forget (ds) ;
  ds := nilspace ;
  bound header := ds ;
  bound header := nil header ;
  cursor (1, 23) ;
  out (cl eol +"Header-Editor : ") ;
  put ("Neuen Header erstellen") ;
  header edit (bound header, "Neuen Header erstellen") .
 
create new file :
  forget (ds) ;
  ds := nilspace ;
  f := sequential file (modify, ds) ;
  edit (f, 1, 1, x size - 2, 16) .
END PROCEDURE space menue ;


(**********************   Configurator-Menu     ****************************)


PROCEDURE configurator menue :
    disable stop ;
    REPEAT
      display conf info ;
      menue monitor (conf info line, conf chars, command index) ;
      fehler loeschen ;
      SELECT command index OF
        CASE  1 : put ("hannel :") ; x get (archive channel) ;
        CASE  2 : put (left +"disktype :") ; x get (disk type) ;
        CASE  3 : disk info
        CASE  4 : get and do one command 
        CASE  5 : LEAVE configurator menue
        CASE  6 : conf menue help 
        CASE  7 : set ctrl g
      END SELECT ;
      fehler behandeln ;
      display info line ;
    UNTIL ctrl g END REPEAT .

display conf info :
  cursor (1, 19) ;
  put (cl eol +"I/O Channel :") ; put (archive channel) ; put (",") ;
  put ("Disktype :") ; put (disk type) ; put (",") ;
  put ("Operatorchannel :") ; put (channel) ;
  cursor (1, 18) ;
  put ("Zeit :") ; put (time of day) ; put (", Datum :") ; put (date) ;
  INT VAR x size, x used ;
  storage (x size, x used) ;
  put (",") ; put (x used) ; put ("K von") ; 
  put (int (real (x size + 24) * 64.0 / 63.0)) ;
  put ("K sind belegt !") .

disk info :
  INT VAR size, io, error ;
  io control (archive channel, io, size, error) ;
  out (home + 16 * (cl eol + down)) ;
  out (home + down) ;
  putline ("Diskinfo :") ;
  putline (first mon line) ;
  put ("Disksize :") ; put (size) ; put ("Blocks,") ;
  put (size DIV 2) ; put ("kB.") ;
  line ;
  put ("Disktype :") ;
  IF size = ibm 720 format 5
    THEN putline ("5 1/4 Zoll, IBM-720 kB Format, 80 Tracks,") ;
         putline ("           double sided/double density, softsectored") 
  ELIF size = ibm 360 format 5
    THEN putline ("5 1/4 Zoll, IBM-360 kB Format, 40 Tracks,") ;
         putline ("           single sided/double density, softsectored") 
  ELIF size = pic 400 format 5
    THEN putline ("5 1/4 Zoll, PIC400 Format, 80 Tracks,") ;
         putline ("           double sided/double density, softsectored") 
  ELIF size = soft sd 8
    THEN putline ("8 Zoll, EUMEL-Format, 77 Tracks,") ;
         putline ("           single sided/double density, softsectored") 
  ELIF size = soft dd 8
    THEN putline ("8 Zoll, EUMEL-Format, 77 Tracks,") ;
         putline ("           double sided/double density, softsectored") 
  ELIF size = hard ss sd 
    THEN putline ("8 Zoll, EUMEL-Format, 32 Tracks,") ;
         putline ("           single sided/single density, hardsectored")
  ELIF size = hard ds sd
    THEN putline ("8 Zoll, EUMEL-Format, 32 Tracks,") ;
         putline ("           double sided/single density, hardsectored")
    ELSE putline ("Unbekannter Disktype") ; line
  END IF ;
  putline (first mon line) .
END PROCEDURE configurator menue ;



(**********************   Header/Space Ops.     ****************************)


INT PROCEDURE header nr :
  IF space nummer = 0
    THEN 0
    ELSE (space nummer + 1) DIV 2
  END IF .
END PROCEDURE header nr ;

INT PROCEDURE space nr (INT CONST header nummer) :
  IF header nummer = 0 COR header nummer = 1
    THEN header nummer
    ELSE header nummer * 2 - 1
  END IF 
END PROCEDURE space nr ;


(**********************     Archiv-Menue        ****************************)


PROCEDURE archive menue :
    archive (archive name) ;
    disable stop ;
    REPEAT
      menue monitor (archiv info line, archiv chars, command index) ;
      fehler loeschen ;
      SELECT command index OF
        CASE 1 : archive anmelden
        CASE 2 : out ("elease (archive)") ;
                 release (archive) ; archivename := "" 
        CASE 3 : out ("ist (archive)") ;
                 list archive ;
                 block shown := false 
        CASE 4 : out ("etch (SOME archive, archive)") ;
                 fetch (SOME archive, archive) ;
                 block shown := false 
        CASE 5 : out ("ave (SOME all, archive)") ;
                 save (SOME all, archive) ;
                 block shown := false 
        CASE 6 : release (archive) ;
                 LEAVE archive menue
        CASE 7 : get and do one command ;
                 block shown := false 
        CASE 8 : archiv menue help ;
                 block shown := false
        CASE 9 : set ctrl g
      END SELECT ;
      fehler behandeln
    UNTIL ctrl g END REPEAT .

archive anmelden :
  put ("rchivename : ") ;
  getline (archivename) ;
  archive (archivename) .

list archive :
  IF NOT (list file ok) COR no (""13"Alte Archiveliste zeigen")
    THEN forget (af ds) ;
         af ds := nilspace ;
         af := sequential file (output, af ds) ;
         list (af, archive) ;
         list file ok := true 
  END IF ;
  edit (af, 1, 1, xsize - 2, 16) .
END PROCEDURE archive menue ;


(**********************     Urflop-Menue        ****************************)


PROCEDURE urflop menue :
    INT VAR s, e ;
    disable stop ;
    REPEAT
      menue monitor (urflop info line, urflop chars, command index) ;
      fehler loeschen ;
      SELECT command index OF
        CASE 1 : read
        CASE 2 : x read
        CASE 3 : write
        CASE 4 : x write
        CASE 5 : list task ;
                 block shown := false 
        CASE 6 : LEAVE urflop menue
        CASE 7 : get and do one command ;
                 block shown := false 
        CASE 8 : urflop menue help ;
                 block shown := false 
        CASE 9 : set ctrl g
      END SELECT ;
      fehler behandeln
    UNTIL ctrl g END REPEAT .

list task :
  forget (l ds) ;
  l ds := nilspace ;
  lf := sequential file (output, l ds) ;
  list (lf) ;
  edit (lf, 1, 1, xsize - 2, 16) .

write :
  out ("rite Datenraumname : ") ;
  getline (t) ;
  IF yes ("Urlader schreiben wie gelesen")
    THEN urlader schreiben (t, eumel 0 start block,
                               -1)
  ELIF yes ("Urlader für PIC 400 (Shard 6.xx) schreiben")
    THEN urlader schreiben (t, eumel 0 start block, 
                               eumel 0 end block pic)
  ELIF yes ("Urlader für PIC 400 (Shard 7.xx, u. Bicos Masch.) schreiben")
    THEN urlader schreiben (t, eumel 0 start block,
                               eumel 0 end block)
  ELIF yes ("Urlader für PIC 400 (ab Shard 7.13 für EUMEL Ver. 1758) schreiben")
    THEN urlader schreiben (t, eumel 0 start block,
                               eumel 0 end block 1758)
  END IF .

x write :
  out ("rite Datenraumname : ") ;
  getline (t) ;
  cursor (command line x pos, command line y pos) ; 
  out (">Write Datenraum """+ t +""" von Block : ") ;
  x get (s) ;
  cursor (command line x pos, command line y pos) ; 
  out (">Write Datenraum """+ t +""" von Block "+ text (s) + " bis : ") ;
  x get (e) ;
  cursor (command line x pos, command line y pos) ; 
  out (">Write Datenraum """+ t +""" von Block "+ text (s) + " bis"+
       " Block "+ text (e)) ;
  IF yes ("mit Versatz")
    THEN cursor (command line x pos, command line y pos) ; 
         out (">Write Datenraum """+ t +""" von Block "+ text (s) + " bis"+
              " Block "+ text (e) +" Versatz : ") ;
         x get (ver) ;
         cursor (command line x pos, command line y pos) ; 
         out (">Write Datenraum """+ t +""" von Block "+ text (s) + " bis"+
              " Block "+ text (e) +" Ver. "+ text (ver) + " --> ") ;
         urlader schreiben (t, s, e, ver)
    ELSE cursor (command line x pos, command line y pos) ; 
         out (">Write Datenraum """+ t +""" von Block "+ text (s) + " bis"+
              " Block "+ text (e) +" --> ") ;
         urlader schreiben (t, s, e)
  END IF .

read :
  out ("ead Datenraumname : ") ;
  getline (t) ;
  IF yes ("Urlader für PIC 400 (Shard 6.xx) lesen")
    THEN urlader lesen (t, eumel 0 start block, 
                           eumel 0 end block pic)
  ELIF yes ("Urlader für PIC 400 (Shard 7.xx, u. Bicos Masch.) lesen")
    THEN urlader lesen (t, eumel 0 start block,
                           eumel 0 end block)
  ELIF yes ("Urlader für PIC 400 (Shard 7.xx für EUMEL Ver. 1758) lesen")
    THEN urlader lesen (t, eumel 0 start block,
                           eumel 0 end block 1758)
  END IF .

x read :
  out ("ead Datenraumname : ") ;
  getline (t) ;
  cursor (command line x pos, command line y pos) ; 
  out (">Read Datenraum """+ t +""" von Block : ") ;
  x get (s) ;
  cursor (command line x pos, command line y pos) ; 
  out (">Read Datenraum """+ t +""" von Block "+ text (s) + " bis : ") ;
  x get (e) ;
  IF yes ("mit Versatz")
    THEN cursor (command line x pos, command line y pos) ; 
         out (">Read Datenraum """+ t +""" von Block "+ text (s) + " bis"+
              " Block "+ text (e) +" Versatz : ") ;
         x get (ver) ;
         cursor (command line x pos, command line y pos) ; 
         out (">Read Datenraum """+ t +""" von Block "+ text (s) + " bis"+
              " Block "+ text (e) +" Ver. "+ text (ver) + " --> ") ;
         urlader lesen (t, s, e, ver)
    ELSE cursor (command line x pos, command line y pos) ; 
         out (">Read Datenraum """+ t +""" von Block "+ text (s) + " bis"+
              " Block "+ text (e) +" --> ") ;
         urlader lesen (t, s, e)
  END IF .
END PROCEDURE urflop menue ;


(**********************  Disk - Monitor Call    ****************************)


PROCEDURE central disk monitor process :
    archive ("disk") ;
    release (archive) ;
    space nummer := -1 ;
    block nummer := -1 ;
    header nummer := -1 ;
    first sp block := -1 ;
    st pos := 0 ;
    archive name := "" ;
    list file ok := false ;
    block shown := false ;
    reset ctrl g ;
    page ;
    line (3) ;
    putline ("D I S K  -  M O N I T O R") ;
    putline ("=========================") ;
    line ;
    putline ("Autor : Ingo Siekmann") ;
    putline ("Stand : "+ software stand) ;
    putline (software version) ;
    putline ("Bem.  : "+ software bemerkung) ;
    putline ("        "+ software bemerkung1) ;
    line ;
    putline ("(c) 1986 by ULES c/o Ingo Siekmann & Nils Ehnert") ;
    line ;
    initialize if necessary ;
    global menue ;
    line ;
    unblock (archive) ;
    IF archive name <> "" CAND NOT ctrl g
      THEN archive (archive name)
    END IF . 
END PROCEDURE central disk monitor process ;


(**********************     Unterprogramme      ****************************)


THESAURUS OPERATOR SOME (THESAURUS CONST thesaurus) :
    DATASPACE VAR edit space :: nilspace ;
    THESAURUS VAR result := empty thesaurus ;
    FILE VAR file := sequential file (output, edit space) ;
    file FILLBY thesaurus ;
    modify (file) ;
    edit (file, 1, 1, xsize - 2, 16) ;
    input (file) ;
    result FILLBY file ;
    forget (edit space) ;
    result .
END OPERATOR SOME ;

THESAURUS OPERATOR SOME (TASK CONST dest task) :
    SOME ALL dest task .
END OPERATOR SOME ;

PROCEDURE display info line :
    INT VAR x, y ;
    get cursor (x, y) ;
    cursor (1, 24) ;
    put (cl eol +"Block : ") ; put (block nummer) ;
    put (", Space : ") ; put (space nummer) ;
    put (", First Sp Block : ") ; put (first sp block) ;
    put (", Header : ") ; put (header nummer) ;
    cursor (x, y) .
END PROCEDURE display info line ;

PROCEDURE x get (INT VAR i) :
    enable stop ;
    get (dummy) ;
    IF (dummy SUB length (dummy)) = hex marker
      THEN i := hint (text (dummy, length (dummy) - 1))
      ELSE i := int (dummy)
    END IF ;
    IF NOT last conversion ok
      THEN error stop ("Zahl ist nicht korrekt")
    END IF .
END PROCEDURE x get ;
 

(**********************     Urflop - Ops.       ****************************)


PROCEDURE urlader lesen (TEXT CONST urname, INT CONST start, end) :
    urlader lesen (urname, start, end, 0) .
END PROCEDURE urlader lesen ;

PROCEDURE urlader schreiben (TEXT CONST urname, INT CONST start, end) :
    urlader schreiben (urname, start, end, 0) .
END PROCEDURE urlader schreiben ;

PROCEDURE urlader lesen auf seite (TEXT CONST urname, INT CONST start, end,
                                   auf) :
    urlader lesen (urname, start, end, auf - start) .
END PROCEDURE urlader lesen auf seite ;

PROCEDURE urlader schreiben von seite (TEXT CONST urname, INT CONST start,
                                       end, von) :
    urlader schreiben (urname, start, end, von - start) .
END PROCEDURE urlader schreiben von seite ;

PROCEDURE urlader lesen (TEXT CONST urname, INT CONST start, end, ver) : 
    IF exists (urname) 
      THEN error stop (""""+ urname +""" gibt es schon") 
    END IF ; 
    forget (uds) ; 
    uds := nilspace ; 
    reset block io ;
    reset ctrl g ;
    FOR block nr FROM start UPTO end REPEAT 
      continue (archive channel) ; 
      disable stop ; 
      block in (uds, block nr + ver, disk type, block nr, error) ; 
      continue (user channel) ; 
      enable stop ; 
      check archive error (error, true) ; 
      cout (block nr) ;
      dummy := incharety ;
      IF dummy = ""7""
        THEN set ctrl g
      END IF 
    UNTIL dummy = esc COR ctrl g END REPEAT ; 
    IF NOT ctrl g
      THEN copy (uds, urname) ; 
    END IF ;
    forget (uds) . 
END PROCEDURE urlader lesen ; 
 
PROCEDURE urlader schreiben (TEXT CONST urname, INT CONST start, end, ver) :
    forget (uds) ; 
    uds := old (urname) ; 
    reset ctrl g ;
    reset block io ;
    block nr := start;
    IF block nr = -1
      THEN block nr := next ds page (uds, block nr) 
    END IF ;
    WHILE block nr <> -1 REPEAT 
      continue (archive channel) ; 
      disable stop ; 
      block out (uds, block nr + ver, disk type, block nr, error) ; 
      break (quiet);
      continue (user channel) ; 
      enable stop ; 
      check archive error (error, false) ; 
      cout (block nr) ;
      dummy := incharety ;
      IF dummy = ""7""
        THEN set ctrl g
      END IF ;
      IF end = -1 COR start = -1
        THEN block nr := next ds page (uds, block nr)
      ELIF block nr = end
        THEN block nr := -1
        ELSE block nr INCR 1
      END IF 
    UNTIL dummy = esc COR ctrl g END REPEAT ; 
    forget (uds) . 
END PROCEDURE urlader schreiben ; 
 

(**********************     Unterprogramme      ****************************)


PROCEDURE reset block io : 
    user channel := channel ;
    INT VAR i, s, e ;
    io control (archive channel, i, s, e) ;
    check archive error (e, true) .
END PROCEDURE reset block io ;

PROCEDURE get and do one command :
    initialize if necessary ;
    cursor (1, 21) ;
    out (cl eop) ;
    get command ("gib ein EUMEL-Kommando : ", own command line) ;
    do (own command line) .
END PROCEDURE get and do one command  ;

PROCEDURE io control (INT VAR io, size, error) :
    ROW 256 INT VAR block ;
    control (type mode, 0, 0, io) ;
    control (size mode, 0, 0, size) ;
    block in (block, std disk type, block 0, error) .
END PROCEDURE io control ;

PROCEDURE io control (INT CONST io channel, INT VAR io, size, error) :
    INT VAR op channel :: channel ;
    continue (io channel) ;
    io control (io, size, error) ;
    break (quiet) ;
    continue (op channel) .
END PROCEDURE io control ;


(**********************    Menue - Help Ops     ****************************)


PROCEDURE global menue help :
    out (home + cl eop) ;
    line ;
    putline ("Help für das Global-Menue : ") ;
    line ;
    putline ("b --> Aufruf des Block-Menüs (direkter Block i/o)") ;
    putline ("s --> Aufruf des Space-Menüs (direkter Space- und Header i/o)") ;
    putline ("a --> Aufruf des Archiv-Menüs (normale Archivoperationen)") ;
    putline ("u --> Aufruf des Urflop-Menüs (Urlader/Datenraum <-> Floppy)") ;
    putline ("c --> Aufruf des Konfigurator-Menüs") ;
    line ;
    putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)") ;
    line ;
    putline ("q --> Verlassen des Diskettenmonitors (quit wie im Editor)") ;
END PROCEDURE global menue help ;

PROCEDURE block menue help :
    out (home + cl eop) ;
    line ;
    putline ("Help für das Block-Menü : ") ;
    line ;
    putline ("r --> Lesen eines Blockes (block in)") ;
    putline ("n --> Lesen des nächsten Blockes") ;
    putline ("w --> Schreiben eines Blockes (block out)") ;
    line ;
    putline ("s --> Suchen nach einem Text") ;
    line ;
    putline ("e --> Aufruf des Blockeditor-Menüs") ;
    line ;
    putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)") ;
    line ;
    putline ("q --> Verlassen des Block-Menüs (Rückkehr ins Global-Menü)") ;
END PROCEDURE block menue help ;

PROCEDURE block editor menue help :
    out (home + cl eop) ;
    line ;
    putline ("Help für das Blockeditor-Menü : ") ;
    line ;
    putline ("f --> Zeigen der ersten 256 Bytes des aktuellen Blockes") ;
    putline ("s --> Zeigen der zweiten 256 Bytes des aktuellen Blockes") ;
    line ;
    putline ("e --> Editieren des aktullen Teilblockes") ;
    putline ("d --> Editieren des ersten und zweiten Teilblockes") ;
    line ;
    putline ("p --> Position setzen, auf der der Editor beginnen soll.") ;
    line ;
    putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)") ;
    line ;
    putline ("q --> Verlassen des Blockeditor-Menüs (Rückkehr ins Block-Menü)") ;
END PROCEDURE block editor menue help ;

PROCEDURE space menue help :
    out (home + cl eop) ;
    line ;
    putline ("Help für das Space-Menü : ") ;
    line ;
    putline ("r --> Lesen eines Datenraums bzw. eines Headers") ;
    putline ("R --> Lesen eines Datenraums ab Block x") ;
    putline ("w --> Schreiben eines Datenraums bzw. eines Headers") ;
    putline ("W --> Schreiben eines Datenraums ab Block x") ;
    line ;
    putline ("e --> Editieren des aktullen Datenraums (Datei o. Header)") ;
    putline ("E --> Editieren einer neuen Datei oder eines Header") ;
    line ;
    putline ("s --> Kopieren des aktuellen Datenraums in eine benannten Datenraum") ;
    putline ("l --> Kopieren eines benannten Datenraums in den aktuellen Datenraum") ; 
    line ;
    putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)") ;
    putline ("q --> Verlassen des Space-Menüs (Rückkehr ins Global-Menü)") ; 
END PROCEDURE space menue help ;

PROCEDURE archiv menue help :
    out (home + cl eop) ;
    line ;
    putline ("Help für das Archiv-Menü : ") ;
    line ;
    putline ("a --> Archiv anmelden") ;
    putline ("r --> Archiv abmelden") ;
    line ;
    putline ("f --> Einige Dateien vom Archiv in die Task laden") ;
    putline ("s --> Einige Dateien der Task auf das Archiv schreiben") ;
    putline ("l --> Dateiliste des Archives zeigen") ;
    line ;
    putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)") ;
    line ;
    putline ("q --> Verlassen des Archiv-Menüs (Rückkehr ins Global-Menü)") ; 
END PROCEDURE archiv menue help ;

PROCEDURE urflop menue help :
    out (home + cl eop) ;
    line ;
    putline ("Help für das Urflop-Menü : ") ; 
    line ;
    putline ("r --> Lesen der Blöcke 10 bis 62 in einen benannten Datenraum") ;
    putline ("R --> Lesen der Blöcke x bis y in einen benannten Datenraum") ;
    line ;
    putline ("w --> Schreiben der Blöcke 10 bis 62 aus einem benannten Datenraum") ;
    putline ("W --> Schreiben der Blöcke x bis y aus einem benannten Datenraum") ;
    line ;
    putline ("l --> Dateiliste der Task zeigen (list)") ;
    line ;
    putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)") ;
    line ;
    putline ("q --> Verlassen des Urflop-Menüs (Rückkehr ins Global-Menü)") ; 
END PROCEDURE urflop menue help ;

PROCEDURE conf menue help :
    out (home + cl eop) ;
    line ;
    putline ("Help für das Configurator-Menü :") ;
    line ;
    putline ("c --> Einstellen des Kanals, auf dem der Block i/o abläuft") ;
    putline ("t --> Einstellen des Diskettentypes (EUMEL, CPM etc)") ;
    line ;
    putline ("i --> Disketteninfo") ;
    line ;
    putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)") ;
    line ;
    putline ("q --> Verlassen des Archiv-Menüs (Rückkehr ins Global-Menü)") ; 
END PROCEDURE conf menue help ;

BOOL PROCEDURE is halt from terminal :
    is error CAND error code = 1
END PROCEDURE is halt from terminal ;
 
PROCEDURE block in (TEXT VAR block, INT CONST block nr, disk type, 
                    INT VAR error) : 
    initialize if necessary ;
    block in (blkinds, heap page nr, disk type, block nr, error) ; 
    block := subtext (bound text, start pos, LENGTH bound text) ; 
END PROCEDURE block in ; 

PROCEDURE initialize if necessary :
    IF NOT initialized (this packet)
      THEN forget (blkinds) ;
           blkinds := nilspace ; 
           bound text := blkinds ; 
           bound text := (start pos + 511) * " " ;
           own command line := "" ;
           archive channel := std archive channel ;
           disk type := std disk type 
    END IF .
END PROCEDURE initialize if necessary ;

BOOL PROCEDURE yes (TEXT CONST msg) :
    get cursor (cx, cy) ;
    cursor (command line x pos + 1, command line y pos + 1) ;
    result := NOT no (msg) ;
    cursor (cx, cy) ;
    result .
END PROCEDURE yes ;
(* 
INT OPERATOR $ (TEXT CONST hex) :
    INT VAR laenge := length (hex), stelle, ziffer, ergebnis := 0 ;
    FOR stelle FROM laenge DOWNTO 1 REPEAT
      ziffer := pos ("0123456789ABCDEF", hex SUB stelle) - 1 ;
      IF ziffer < 0
        THEN error stop ("Ist keine Hexzahl")
      END IF ;
      ergebnis INCR ziffer * 16 ** (laenge - stelle)
    END REPEAT ;
    ergebnis .
END OPERATOR $ ;
*)
PROCEDURE search (TEXT CONST st, INT CONST start block, end block, 
                  INT VAR fbnr, fpos) : 
    enable stop ;
    INT CONST l := LENGTH st - 1 ;
    reset ctrl g ;
    reset block io ;
    FOR fbnr FROM start block UPTO end block REPEAT
      cout (fbnr) ;
      continue (archive channel) ;
      block in (stb1, fbnr, disk type, error) ;
      IF error = 0
        THEN block in (stb2, fbnr + 1, disk type, error) 
      END IF ;
      break (quiet) ; 
      continue (user channel) ; 
      check archive error (error, true) ; 
      stb1 CAT text (stb2, l) ; 
    UNTIL pos (stb1, st) > 0 COR incharety = ""27"" END REPEAT ; 
    fpos := pos (stb1, st) 
END PROCEDURE search ; 

END PACKET byte operations and disk monitor version 35 multi ;