1 files changed, 693 insertions, 0 deletions
diff --git a/system/dos/1.8.7/src/dir.dos b/system/dos/1.8.7/src/dir.dos
new file mode 100644
index 0000000..08456b5
--- /dev/null
+++ b/system/dos/1.8.7/src/dir.dos
@@ -0,0 +1,693 @@
+PACKET dir DEFINES                            (* Copyright (c) 1986, 87 *)
+                                              (* Frank Klapper          *)
+  open dir,                                   (* 02.03.88               *)
+  insert dir entry,
+  delete dir entry,
+  init dir ds,
+  file info,
+  format dir,
+
+  dir list,
+  file   exists,
+  subdir exists,
+  all files,
+  all subdirs:
+ 
+LET max dir entrys = 1000;
+
+(*-------------------------------------------------------------------------*)
+
+INITFLAG VAR dir block ds used := FALSE;
+DATASPACE VAR dir block ds;
+BOUND STRUCT (ALIGN dummy, ROW 64 REAL daten) VAR dir block;
+REAL VAR last read dir block no;
+
+PROC init dir block io:
+  last read dir block no := -1.0;
+  IF NOT initialized (dir block ds used)
+    THEN dir block ds := nilspace;
+         dir block := dir block ds
+  FI.
+
+END PROC init dir block io;
+
+PROC read dir block (REAL CONST block nr):
+  IF last read dir block no <> block nr
+    THEN last read dir block no := -1.0;
+         read disk block and close work if error (dir block ds, 2, block nr);
+         last read dir block no := block nr
+  FI.
+
+END PROC read dir block;
+
+PROC write dir block (REAL CONST block nr):
+  write disk block and close work if error (dir block ds, 2, block nr);
+  last read dir block no := block nr.
+
+END PROC write dir block;
+
+PROC write dir block:
+  IF last read dir block no < 0.0
+    THEN error stop ("Lesefehler")
+  FI;
+  write dir block (last read dir block no)
+
+END PROC write dir block;
+
+PROC get dir entry (TEXT VAR entry buffer, INT CONST block entry no):
+  (* 0 <= block entry no <= 15 *)
+  entry buffer := 32 * ".";
+  INT CONST replace offset := 4 * block entry no;
+  replace (entry buffer, 1, dir block.daten [replace offset + 1]);
+  replace (entry buffer, 2, dir block.daten [replace offset + 2]);
+  replace (entry buffer, 3, dir block.daten [replace offset + 3]);
+  replace (entry buffer, 4, dir block.daten [replace offset + 4]).
+
+END PROC get dir entry;
+
+PROC put dir entry (TEXT CONST entry buffer, INT CONST block entry no):
+  (* 0 <= block entry no <= 15 *)
+  INT CONST offset := 4 * block entry no;
+  dir block.daten [offset + 1] := entry buffer RSUB 1;
+  dir block.daten [offset + 2] := entry buffer RSUB 2;
+  dir block.daten [offset + 3] := entry buffer RSUB 3;
+  dir block.daten [offset + 4] := entry buffer RSUB 4.
+
+END PROC put dir entry;
+
+(*-------------------------------------------------------------------------*)
+
+LET DIRPOS = REAL;                  (* 16.0 * msdos block nr + entry no *)
+                                    (* 0 <= entry no <= 15              *)
+
+DIRPOS PROC dirpos (REAL CONST block nr, INT CONST entry nr):
+  block nr * 16.0 + real (entry nr).
+
+END PROC dir pos;
+
+REAL PROC block no (DIRPOS CONST p):
+  floor (p / 16.0)
+
+END PROC block no;
+
+INT PROC entry no (DIRPOS CONST p):
+  int (p MOD 16.0)
+
+END PROC entry no;
+
+PROC incr (DIRPOS VAR p):
+  p INCR 1.0.
+
+END PROC incr;
+
+(*-------------------------------------------------------------------------*)
+
+LET FREELIST = STRUCT (ROW max dir entrys DIRPOS stack,
+                       INT stacktop,
+                       DIRPOS begin of free area,
+                              end of dir,
+                       REAL dir root);                  (* erste Clusterno, 0 für Main Dir *)
+ 
+PROC init free list (FREELIST VAR flist, REAL CONST root):
+  flist.stacktop           := 0;
+  flist.begin of free area := dir pos (9.0e99, 0);
+  flist.end of dir         := dir pos (-1.0, 0);
+  flist.dir root           := root.
+
+END PROC init free list;
+ 
+PROC store (FREELIST VAR flist, DIRPOS CONST free pos):
+  flist.stacktop INCR 1;
+  flist.stack [flist.stack top] := free pos.
+
+END PROC store;
+
+PROC store begin of free area (FREELIST VAR flist, DIRPOS CONST begin):
+  flist.begin of free area := begin
+
+END PROC store begin of free area;
+
+PROC store end of dir (FREELIST VAR flist, DIRPOS CONST end):
+  flist.end of dir := end
+
+END PROC store end of dir;
+
+DIRPOS PROC free dirpos (FREELIST VAR flist):
+  enable stop;
+  DIRPOS VAR result;
+  IF flist.stacktop > 0
+    THEN pop
+    ELIF NOT free area empty
+    THEN first of free area
+    ELIF expansion alloweded
+    THEN allocate new dir cluster;
+         result := free dirpos (flist)
+    ELSE error stop ("Directory voll")
+  FI;
+  result.
+
+pop:
+  result := flist.stack [flist.stacktop];
+  flist.stacktop DECR 1.
+
+free area empty:
+  flist.begin of free area > flist.end of dir.
+
+first of free area:
+  result := flist.begin of free area;
+  incr (flist.begin of free area).
+
+expansion alloweded:
+  flist.dir root >= 2.0.
+
+allocate new dir cluster:
+  REAL CONST new dir cluster :: available fat entry;
+  REAL VAR last entry no;
+  search last entry no of fat chain;
+  fat entry (new dir cluster, last fat chain entry);
+  fat entry (last entry no, new dir cluster);
+  write fat;
+  store begin of free area (flist, dir pos (first new block, 0));
+  store end   of dir       (flist, dir pos (last  new block, 15));
+  init new dir cluster.
+
+search last entry no of fat chain:
+  last entry no := flist.dir root;
+  WHILE NOT is last fat chain entry (fat entry (last entry no)) REP
+    last entry no := fat entry (last entry no)
+  PER.
+
+first new block:
+  begin of cluster (new dir cluster).
+
+last new block:
+  begin of cluster (new dir cluster) + real (sectors per cluster - 1).
+
+init new dir cluster:
+  TEXT CONST empty dir entry :: 32 * ""0"";
+  INT VAR i;
+  FOR i FROM 0 UPTO 15 REP
+    put dir entry (empty dir entry, i)
+  PER;
+  disable stop;
+  REAL VAR block no := first new block;
+  WHILE block no <= last new block REP
+    write dir block (block no)
+  PER.
+
+END PROC free dirpos; 
+
+(*-------------------------------------------------------------------------*)
+
+LET FILEENTRY = STRUCT (TEXT date and time,
+                        REAL size,
+                             first cluster, 
+                        DIRPOS dirpos),
+
+    FILELIST = STRUCT (THESAURUS thes,
+                       ROW max dir entrys FILEENTRY entry);
+
+PROC init file list (FILELIST VAR flist):
+  flist.thes := empty thesaurus.
+
+END PROC init file list;
+
+PROC store file entry (FILELIST VAR flist, TEXT CONST entry text, DIRPOS CONST position):
+  INT VAR entry index;
+  insert (flist.thes, file name, entry index);
+  store file entry (flist.entry [entry index], entry text, position).
+ 
+file name:
+  TEXT CONST name pre  :: compress (subtext (entry text, 1, 8)),
+             name post :: compress (subtext (entry text, 9, 11));
+  IF name post <> ""
+    THEN name pre + "." + name post
+    ELSE name pre
+  FI.
+
+END PROC store file entry;
+
+PROC store file entry (FILEENTRY VAR fentry, TEXT CONST entry text, DIRPOS CONST position):
+  fentry.first cluster := real (entry text ISUB 14);
+  fentry.date and time := dos date + "  " + dos time;
+  fentry.size          := dint (entry text ISUB 15, entry text ISUB 16);
+  fentry.dirpos        := position.
+
+dos date:
+  day + "." + month + "." + year. 
+ 
+day: 
+  text2 (code (entry text SUB 25) MOD 32).
+ 
+month:
+  text2 (code (entry text SUB 25) DIV 32 + 8 * (code (entry text SUB 26) MOD 2)).
+ 
+year:
+  text (80 + code (entry text SUB 26) DIV 2, 2).
+
+dos time:
+  hour + ":" + minute. 
+ 
+hour: 
+  text2 (code (entry text SUB 24) DIV 8).
+ 
+minute: 
+  text2 (code (entry text SUB 23) DIV 32 + 8 * (code (entry text SUB 24) MOD 8)).
+ 
+END PROC store file entry;
+
+TEXT PROC text2 (INT CONST intvalue):
+  IF intvalue < 10
+    THEN "0" + text (intvalue)
+    ELSE text (int value)
+  FI.
+
+END PROC text2;
+
+DIRPOS PROC file entry pos (FILELIST CONST flist, TEXT CONST file name):
+  INT CONST link index :: link (flist.thes, file name);
+  IF link index = 0
+    THEN error stop ("Die Datei """ + file name + """ gibt es nicht")
+  FI;
+  flist.entry [link index].dir pos.
+
+END PROC file entry pos;
+
+PROC delete (FILELIST VAR flist, TEXT CONST file name):
+  INT VAR dummy;
+  delete (flist.thes, file name, dummy).
+
+END PROC delete;
+
+PROC file info (FILELIST CONST flist, TEXT CONST file name, REAL VAR first cluster no, storage):
+  INT CONST link index :: link (flist.thes, file name);
+  IF link index = 0
+    THEN error stop ("Die Datei """ + file name + """ gibt es nicht")
+  FI;
+  first cluster no := flist.entry [link index].first cluster;
+  storage          := flist.entry [link index].size
+
+END PROC file info;
+
+BOOL PROC contains (FILELIST VAR flist, TEXT CONST file name):
+  flist.thes CONTAINS file name
+
+END PROC contains;
+
+PROC list (FILE VAR f, FILELIST CONST flist):
+  INT VAR index := 0;
+  TEXT VAR name;
+  get (flist.thes, name, index);
+  WHILE index > 0 REP
+    list file;
+    get (flist.thes, name, index)
+  PER.
+
+list file:
+  write (f, centered name);
+  write (f, "  ");
+  write (f, text (flist.entry [index].size, 11, 0));
+  write (f, " Bytes belegt      ");
+  write (f, flist.entry [index].date and time); 
+(*COND TEST*)
+  write (f, "  +++  "); 
+  write (f, text (flist.entry [index].first cluster)); 
+(*ENDCOND*)
+  line (f).
+
+centered name:
+  INT VAR point pos := pos (name, ".");
+  IF point pos > 0
+    THEN name pre + "." + name post
+    ELSE text (name, 12)
+  FI.
+
+name pre:
+  text (subtext (name, 1, point pos - 1), 8).
+
+name post:
+  text (subtext (name, point pos + 1, point pos + 4), 3).
+ 
+END PROC list;
+
+(*-------------------------------------------------------------------------*)
+ 
+LET DIRENTRY = REAL,
+
+    DIRLIST = STRUCT (THESAURUS thes,
+                      ROW max dir entrys DIRENTRY entry);
+
+PROC init dir list (DIRLIST VAR dlist):
+  dlist.thes := empty thesaurus.
+
+END PROC init dir list;
+
+PROC store subdir entry (DIRLIST VAR dlist, TEXT CONST entry text):
+  INT VAR entry index;
+  insert (dlist.thes, subdir name, entry index);
+  dlist.entry [entry index] := real (entry text ISUB 14).
+
+subdir name:
+  TEXT CONST name pre  :: compress (subtext (entry text, 1, 8)),
+             name post :: compress (subtext (entry text, 9, 11));
+  IF name post <> ""
+    THEN name pre + "." + name post
+    ELSE name pre
+  FI.
+
+END PROC store subdir entry;
+
+REAL PROC first cluster of subdir (DIRLIST CONST dlist, TEXT CONST name):
+  INT CONST link index := link (dlist.thes, name);
+  IF link index = 0
+    THEN error stop ("Das Unterverzeichnis """ + name + """ gibt es nicht")
+  FI;
+  dlist.entry [link index].
+
+END PROC first cluster of subdir;
+
+BOOL PROC contains (DIRLIST CONST dlist, TEXT CONST subdir name):
+  dlist.thes CONTAINS subdir name
+
+END PROC contains;
+
+PROC list (FILE VAR f, DIRLIST CONST dlist):
+  INT VAR index := 0;
+  TEXT VAR name;
+  get (dlist.thes, name, index);
+  WHILE index > 0 REP
+    list dir;
+    get (dlist.thes, name, index)
+  PER.
+
+list dir:
+  write (f, centered name);
+  write (f, "   <DIR>");
+(*COND TEST*)
+  write (f, "  +++  ");                                 
+  write (f, text (dlist.entry [index]));  
+(*ENDCOND*)
+  line (f).
+
+centered name:
+  INT VAR point pos := pos (name, ".");
+  IF point pos > 0
+    THEN name pre + "." + name post
+    ELSE text (name, 12)
+  FI.
+
+name pre:
+  text (subtext (name, 1, point pos - 1), 8).
+
+name post:
+  text (subtext (name, point pos + 1, point pos + 4), 3).
+ 
+END PROC list;
+
+(*-------------------------------------------------------------------------*)
+
+LET DIR = BOUND STRUCT (FILELIST filelist,
+                        DIRLIST dirlist, 
+                        FREELIST freelist,
+                        TEXT path);
+ 
+DIR VAR dir;
+DATASPACE VAR dir ds;
+INITFLAG VAR dir ds used := FALSE;
+
+PROC open dir (TEXT CONST path string):
+  init dir block io;
+  init dir ds;
+  dir.path := path string;
+  load main dir;
+  TEXT VAR rest path := path string;
+  WHILE rest path <> "" REP
+    TEXT CONST sub dir name := next sub dir name (rest path);
+    load sub dir
+  PER.
+
+load main dir:
+  init file list (dir.filelist);
+  init dir  list (dir.dirlist);
+  init free list (dir.free list, 0.0);
+  store end of dir (dir.freelist, dirpos (last main dir sector, 15));
+  BOOL VAR was last dir sector := FALSE;
+  REAL VAR block no := first main dir sector;
+  INT VAR i;
+  FOR i FROM 1 UPTO dir sectors REP
+      load dir block (block no, was last dir sector);
+      block no INCR 1.0
+      UNTIL was last dir sector
+  PER. 
+
+first main dir sector:
+  real (begin of dir).
+
+last main dir sector:
+  real (begin of dir + dir sectors - 1).
+
+load sub dir:
+  REAL VAR cluster no := first cluster of sub dir (dir.dirlist, sub dir name);
+  was last dir sector := FALSE;
+  init file list (dir.filelist);
+  init dir  list (dir.dirlist);
+  init free list (dir.free list, cluster no);
+  WHILE NOT is last fat chain entry (cluster no) REP
+    load sub dir entrys of cluster;
+    cluster no := fat entry (cluster no)
+    UNTIL was last dir sector
+  PER.
+
+load sub dir entrys of cluster:
+  store end of dir (dir.freelist, dirpos (last block no of cluster, 15));
+  block no := begin of cluster (cluster no);
+  FOR i FROM 1 UPTO sectors per cluster REP
+    load dir block (block no, was last dir sector);
+    block no INCR 1.0
+    UNTIL was last dir sector
+  PER.
+
+last block no of cluster:
+  begin of cluster (cluster no) + real (sectors per cluster - 1).
+
+END PROC open dir;
+
+PROC load dir block (REAL CONST block no, BOOL VAR was last block): 
+  was last block := FALSE;
+  read dir block (block no);
+  INT VAR entry no;
+  TEXT VAR entry;
+  FOR entry no FROM 0 UPTO 15 REP 
+    get dir entry (entry, entry no);
+    process entry
+    UNTIL was last block
+  PER.
+
+process entry:
+  SELECT pos (""0"."229"", entry SUB 1) OF
+    CASE 1: end of dir search
+    CASE 2: (* root des aktuellen directorys oder des übergeordneten, also nichts tun *)
+    CASE 3: free entry
+    OTHERWISE volume label or file entry or subdir entry
+  END SELECT.
+
+end of dir search:
+  was last block := TRUE;
+  store begin of free area (dir.freelist, dir pos (block no, entry no)).
+
+free entry:
+  store (dir.freelist, dir pos (block no, entry no)).
+
+volume label or file entry or subdir entry:
+  INT CONST byte 11 :: code (entry SUB 12);
+  IF (byte 11 AND 8) > 0
+    THEN (* volume label *)
+  ELIF (byte 11 AND 16) > 0
+    THEN sub dir entry
+    ELSE file entry
+  FI.
+
+sub dir entry:
+  store subdir entry (dir.dir list, entry).
+
+file entry:
+  store file entry (dir.file list, entry, dir pos (block no, entry no)).
+
+END PROC load dir block; 
+ 
+TEXT PROC next subdir name (TEXT VAR path string):
+  TEXT VAR subdir name;
+  IF (path string SUB 1) <> "\"
+    THEN error stop ("ungültige Pfadbezeichnung")
+  FI;
+  INT CONST backslash pos :: pos (path string, "\", 2);
+  IF backslash pos = 0
+    THEN subdir name := subtext (path string, 2);
+         path string := ""
+    ELSE subdir name := subtext (path string, 2, backslash pos - 1);
+         path string := subtext (path string, backslash pos)
+  FI;
+  dos name (subdir name, read modus).
+
+END PROC next subdir name;
+
+PROC init dir ds:
+  IF initialized (dir ds used)
+    THEN forget (dir ds)
+  FI;
+  dir ds := nilspace;
+  dir := dir ds.
+
+END PROC init dir ds;
+
+PROC insert dir entry (TEXT CONST name, REAL CONST start cluster, storage):
+  DIRPOS CONST ins pos :: free dirpos (dir.free list);
+  TEXT CONST entry string :: entry name + ""32"" + (10 * ""0"") + dos time +
+                             dos date + entry start cluster + entry storage;
+  write entry on disk;
+  write entry in dir ds.
+
+entry name:
+  INT CONST point pos := pos (name, ".");
+  IF point pos > 0
+    THEN subtext (name, 1, point pos - 1) + (9 - point pos) * " " +
+         subtext (name, point pos + 1) + (3 - LENGTH name + point pos) * " "
+    ELSE name + (11 - LENGTH name) * " "
+  FI.
+ 
+dos time:
+  TEXT CONST akt time :: time of day (clock (1));
+  code ((minute MOD 8) * 32) + code (8 * hour + minute DIV 8).
+
+hour:
+  int (subtext (akt time, 1, 2)).
+
+minute:
+  int (subtext (akt time, 4, 5)).
+
+dos date:
+  TEXT CONST akt date :: date (clock (1));
+  code (32 * (month MOD 8) + day) + code ((year - 80) * 2 + month DIV 8).
+
+day: 
+  int (subtext (akt date, 1, 2)).
+
+month:
+  int (subtext (akt date, 4, 5)).
+
+year:
+  int (subtext (akt date, 7, 8)).
+
+entry start cluster:
+  TEXT VAR buffer2 := "12";
+  replace (buffer2, 1, low word (start cluster));
+  buffer2.
+
+entry storage:
+  TEXT VAR buffer4 := "1234";
+  replace (buffer4, 1, low  word (storage));
+  replace (buffer4, 2, high word (storage));
+  buffer4.
+
+write entry on disk:
+  read dir block (block no (ins pos));
+  put dir entry (entry string, entry no (ins pos));
+  write dir block.
+
+write entry in dir ds:
+  store file entry (dir.file list, entry string, ins pos).
+
+END PROC insert dir entry;
+
+PROC delete dir entry (TEXT CONST name):
+  TEXT VAR entry;
+  DIRPOS CONST del pos :: file entry pos (dir.filelist, name);
+  read dir block (block no (del pos));
+  get dir entry (entry, entry no (del pos));
+  put dir entry (""229"" + subtext (entry, 2, 32), entry no (del pos));
+  write dir block;
+  delete (dir.filelist, name);
+  store (dir.freelist, del pos).
+
+END PROC delete dir entry;
+
+PROC format dir:
+  init dir block io;
+  init dir ds;
+  build empty dir block;
+  REAL VAR block no := real (begin of dir);
+  disable stop;
+  FOR i FROM 1 UPTO dir sectors REP
+    write dir block (block no);
+    block no INCR 1.0
+  PER;
+  enable stop;
+  dir.path := "";
+  init file list (dir.file list);
+  init dir  list (dir.dir  list);
+  init free list (dir.free list, 0.0);
+  store begin of free area (dir.free list, dir pos (real (begin of dir), 0));
+  store end of dir (dir.free list, dir pos (last main dir sector, 15)).
+
+build empty dir block:
+  INT VAR i;
+  FOR i FROM 0 UPTO 15 REP
+    put dir entry (32 * ""0"",  i)
+  PER.
+
+last main dir sector:
+  real (begin of dir + dir sectors - 1).
+
+END PROC format dir;
+ 
+PROC file info (TEXT CONST file name, REAL VAR start cluster, size):
+  file info (dir.file list, file name, start cluster, size)
+
+END PROC file info;
+
+THESAURUS PROC all files:
+  THESAURUS VAR t := dir.filelist.thes;
+  t
+
+END PROC all files;
+
+THESAURUS PROC all subdirs:
+  dir.dirlist.thes
+
+END PROC all subdirs;
+
+BOOL PROC file exists (TEXT CONST file name):
+  contains (dir.filelist, file name)
+
+END PROC file exists;
+
+BOOL PROC subdir exists (TEXT CONST subdir name):
+  contains (dir.dirlist, subdir name)
+
+END PROC subdir exists;
+
+PROC dir list (DATASPACE VAR ds):
+  open list file;
+  head line (list file, list file head);
+  list (list file, dir.file list);
+  list (list file, dir.dir list).
+
+open list file:
+  forget (ds);
+  ds := nilspace;
+  FILE VAR list file := sequential file (output, ds);
+  putline (list file, "").
+ 
+list file head:
+  "DOS" + path string.
+
+path string:
+  IF dir.path <> ""
+    THEN "     PATH: " + dir.path
+    ELSE ""
+  FI.
+
+END PROC dir list;
+
+END PACKET dir;
+