From 98cab31fc3659e33aef260efca55bf9f1753164c Mon Sep 17 00:00:00 2001
From: Lars-Dominik Braun <lars@6xq.net>
Date: Mon, 11 Feb 2019 11:49:19 +0100
Subject: Add source files from Michael

---
 system/dos/1986/src/eu disk descriptor.fd | 102 ++++++++++++++++++++++++++++++
 1 file changed, 102 insertions(+)
 create mode 100644 system/dos/1986/src/eu disk descriptor.fd

(limited to 'system/dos/1986/src/eu disk descriptor.fd')

diff --git a/system/dos/1986/src/eu disk descriptor.fd b/system/dos/1986/src/eu disk descriptor.fd
new file mode 100644
index 0000000..c09c820
--- /dev/null
+++ b/system/dos/1986/src/eu disk descriptor.fd	
@@ -0,0 +1,102 @@
+PACKET eu disk DEFINES                          (* Copyright (C) 1985 *)
+                                                (* Frank Klapper      *)
+                                                (* 25.03.86           *)
+  load shard interface table,
+  open eu disk,
+  eu size,
+  eu heads,
+  eu tracks,
+  eu first sector,
+  eu last sector:
+
+LET table length = 15,
+ 
+    size field         = 1,
+    head field         = 2,
+    track field        = 3,
+    first sector field = 4,
+    last  sector field = 5;
+
+ROW table length ROW 5 INT VAR format table;
+
+INT VAR table top,
+        table pointer;
+
+PROC open eu disk:
+  enable stop;
+  init check rerun;
+(*COND FLOPPY*)
+  INT VAR blocks := archive blocks;
+  search format table entry;
+(*ENDCOND*)
+.
+
+(*COND FLOPPY*)
+search format table entry:
+  table pointer := 1;
+  WHILE format table [table pointer][size field] <> blocks REP
+    table pointer INCR 1;
+    IF table pointer > table top
+      THEN error stop ("Diskettenformat nicht implementiert")
+    FI
+  PER.
+(*ENDCOND*)
+
+END PROC open eu disk;
+
+PROC load shard interface table:
+  FILE VAR f := sequential file (input, "shard interface");
+  TEXT VAR line;
+  table top := 0;
+  WHILE NOT eof (f) REP
+    get line (f, line);
+    IF (line SUB 1) <> ";"
+      THEN load line
+    FI
+  PER.
+
+load line:
+  table top INCR 1;
+  IF table top > table length
+    THEN error stop ("Shard Interface Tabelle zu groá")
+  FI;
+  INT VAR blank pos := 1;
+  format table [table top][size field]         := next int;
+  format table [table top][head field]         := next int;
+  format table [table top][track field]        := next int; 
+  format table [table top][first sector field] := next int;
+  format table [table top][last  sector field] := next int.
+
+next int:
+  line := compress (subtext (line, blank pos)) + " ";
+  blank pos := pos (line, " ");
+  int (subtext (line, 1, blank pos - 1)).
+
+END PROC load shard interface table;
+ 
+INT PROC eu size:
+  format table [table pointer][size field]
+
+END PROC eu size;
+
+INT PROC eu heads:
+  format table [table pointer][head field]
+
+END PROC eu heads;
+
+INT PROC eu tracks:
+  format table [table pointer][track field]
+
+END PROC eu tracks;
+
+INT PROC eu first sector:
+  format table [table pointer][first sector field]
+
+END PROC eu first sector;
+
+INT PROC eu last sector:
+  format table [table pointer][last sector field]
+
+END PROC eu last sector;
+
+END PACKET eu disk;
-- 
cgit v1.2.3