From 724cc003460ec67eda269911da85c9f9e40aa6cf Mon Sep 17 00:00:00 2001
From: Lars-Dominik Braun <lars@6xq.net>
Date: Fri, 30 Sep 2016 16:57:23 +0200
Subject: Add extracted sources from floppy disk images

Some files have no textual representation (yet) and were added as raw
dataspaces.
---
 dos/name conversion.dos | 77 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 77 insertions(+)
 create mode 100644 dos/name conversion.dos

(limited to 'dos/name conversion.dos')

diff --git a/dos/name conversion.dos b/dos/name conversion.dos
new file mode 100644
index 0000000..e72d838
--- /dev/null
+++ b/dos/name conversion.dos	
@@ -0,0 +1,77 @@
+PACKET name conversion DEFINES                  (* Copyright (C) 1985 *)
+                                                (* Frank Klapper      *)
+  dos name,                                     (* 31.12.86           *)
+
+  read  modus,
+  write modus:
+
+BOOL CONST read  modus :: TRUE,
+           write modus :: NOT read modus;
+
+LET upper case chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789$#&§!()-{}`_",
+    lower case chars = "abcdefghijklmnopqrstuvwxyz";
+
+TEXT PROC dos name (TEXT CONST eu name, BOOL CONST read write modus):
+  enable stop;
+  INT CONST point pos :: pos (eu name, ".");
+  IF name extension exists
+    THEN changed name with extension
+    ELSE changed name without extension
+  FI.
+
+name extension exists:
+  point pos > 0.
+
+changed name with extension:
+  TEXT CONST name pre  :: compress (subtext (eu name, 1, point pos - 1)),
+             name post :: compress (subtext (eu name, point pos + 1));
+  IF LENGTH name pre = 0 OR LENGTH name pre > 8 OR LENGTH name post > 3
+    THEN error
+  FI;
+  IF LENGTH name post = 0
+    THEN new name (name pre, read write modus)
+    ELSE new name (name pre, read write modus) + "."
+       + new name (name post, read write modus)
+  FI.
+
+changed name without extension:
+  IF LENGTH eu name > 8 OR LENGTH euname < 1
+    THEN error
+  FI;
+  new name (eu name, read write modus).
+
+error:
+  error stop ("Unzulässiger Name").
+
+END PROC dos name;
+
+TEXT PROC new name (TEXT CONST old name, BOOL CONST read write modus):
+  TEXT VAR new := "";
+  INT VAR count;
+  FOR count FROM 1 UPTO LENGTH old name REP
+    convert char
+  PER;
+  new.
+
+convert char:
+  TEXT CONST char :: old name SUB count;
+  IF is lower case char
+    THEN new CAT (upper case chars SUB string pos)
+  ELIF is upper case char OR read write modus
+    THEN new CAT char
+  ELSE error stop ("Unzulässiger Name")
+  FI.
+
+is lower case char:
+  pos (lower case chars, char) > 0.
+
+is upper case char:
+  pos (upper case chars, char) > 0. 
+
+string pos:
+  pos (lower case chars, char).
+
+END PROC new name; 
+ 
+END PACKET name conversion;
+
-- 
cgit v1.2.3