Category : Modula II Source Code
Archive   : FASTR.ZIP
Filename : FASTR.MOD

 
Output of file : FASTR.MOD contained in archive : FASTR.ZIP
IMPLEMENTATION MODULE FASTR; (* FastStrings by D. Body 7/89 *)

FROM Lib IMPORT FatalError, Move, Compare, ScanR, ScanL,
ScanNeL, ScanNeR;

CONST
NullChar = CHR (0); (* terminates strings *)
HiChar = CHR (255); (* flags case 3 *)


PROCEDURE Min2C (a,b: CARDINAL): CARDINAL;
(* returns the lesser of two cardinals *)

BEGIN
IF a < b THEN
RETURN a
ELSE
RETURN b
END;
END Min2C;

PROCEDURE Min3C (a,b,c: CARDINAL): CARDINAL;
(* returns the lesser of 3 cardinals *)

BEGIN
RETURN Min2C (Min2C (a, b), c);
END Min3C;

PROCEDURE Length (s: ARRAY OF CHAR): CARDINAL;
(* returns the length of a string stored in canonical form *)

VAR
len, disp, last: CARDINAL;
pc : POINTER TO CARDINAL;

BEGIN
last := HIGH (s); (* s[0]..s[last] *)
IF s[last] = HiChar THEN
(* length stored in word before last byte *)
pc := ADR (s[last - 2]);
RETURN pc^;
ELSE
disp := ORD (s[last]); (* locn of NullChar? *)
len := last - disp;
IF (disp <= SIZE (len)) & (s[len] = NullChar) THEN
RETURN len;
ELSE
RETURN SIZE (s); (* string fills the array *)
END;
END;
END Length;

PROCEDURE Terminate (VAR s: ARRAY OF CHAR; len: CARDINAL);
(* convert any array of chars into the canonical form *)

VAR
last, disp: CARDINAL;
pc : POINTER TO CARDINAL;

BEGIN
last := HIGH (s); (* index of last element of s *)
IF len < SIZE (s) THEN
s[len] := NullChar;
disp := last - len;
IF disp <= SIZE (len) THEN
s[last] := CHR (disp); (* OK if disp=0 *)
ELSE
s[last] := HiChar; (* flag this case *)
(* store the length in the word previous to the last byte *)
pc := ADR (s[last - 2]);
pc^ := len;
END;
END;
END Terminate;

PROCEDURE Fix (VAR s: ARRAY OF CHAR);
(* assuming s is already null_terminated, convert it to canonical form *)

VAR
last, pos: CARDINAL;

BEGIN (* find its length and terminate *)
pos := ScanR (ADR (s), SIZE (s), BYTE (NullChar));
IF pos > SIZE (s) THEN
Terminate (s, pos);
(* else, the array is "full", and is canonical *)
END;
END Fix;

PROCEDURE Assign (VAR target: ARRAY OF CHAR; source: ARRAY OF CHAR);
(* assign the source string to the target string. truncate if necessary. *)

VAR
targetLen: CARDINAL;

BEGIN
targetLen := Min2C (SIZE (target), Length (source));
Move (ADR (source), ADR (target), targetLen);
Terminate (target, targetLen);
END Assign;

PROCEDURE Append (VAR target: ARRAY OF CHAR; source: ARRAY OF CHAR);
(* append the source string to the target. truncate if necessary *)

VAR
sourceLen, targetLen, newTargetLen: CARDINAL;

BEGIN
sourceLen := Length (source);
targetLen := Length (target);
newTargetLen := Min2C (targetLen + sourceLen, SIZE (target));
IF newTargetLen > targetLen THEN
Move (ADR (source), ADR (target), newTargetLen - targetLen);
Terminate (target, newTargetLen);
END;
END Append;

PROCEDURE Assert (b: BOOLEAN; msg: ARRAY OF CHAR);

VAR
errmsg: ARRAY [0..79] OF CHAR;

BEGIN
IF NOT b THEN
Assign (errmsg, 'ASSERTION VIOLATION: ');
Append (errmsg, msg);
FatalError (errmsg);
END;
END Assert;

PROCEDURE Insert (VAR target: ARRAY OF CHAR; subStr: ARRAY OF CHAR; pos: CARDINAL);
(* insert subStr into the target, to start at position pos. truncate if necessary. *)

VAR
subLen, targetLen: CARDINAL;

BEGIN
subLen := Length (subStr);
targetLen := Length (target);
IF pos >= targetLen THEN
Append (target, subStr);
ELSIF subLen + targetLen <= SIZE (target) THEN
Move (ADR (target[pos]), ADR (target[pos + subLen]), targetLen - pos);
Move (ADR (subStr), ADR (target[pos]), subLen);
Terminate (target, Min2C (targetLen + subLen, SIZE (target)));
ELSIF pos + subLen < SIZE (target) THEN
Move (ADR (target[pos]), ADR (target[pos + subLen]),
subLen + targetLen - SIZE (target));
Move (ADR (subStr), ADR (target[pos]), subLen);
(* target is full *)
ELSE
Terminate (target, pos);
Append (target, subStr);
END;
END Insert;

PROCEDURE FindPat (pattern, subject: ARRAY OF CHAR; start: CARDINAL): CARDINAL;
(* searches from position start for the first match of pattern in the subject. *)
(* returns the length (subject) to signal failure of the search. *)

VAR
where, subLim, subLen, patLen: CARDINAL;

BEGIN
patLen := Length (pattern);
subLen := Length (subject) - start;
IF subLen < patLen THEN
RETURN start + subLen; (* FAILURE *)
ELSIF patLen = 1 THEN
RETURN start + ScanR (ADR (subject[start]), subLen, BYTE (pattern[0]));
ELSE
subLim := subLen - patLen;
(* locate the first character of the pattern *)
where := start + ScanR (ADR (subject[start]), subLen, BYTE (pattern[0]));
WHILE where <= subLim DO
(* compare subject[where]..subject[where + patLim] with the pattern *)
IF (where <= subLim) &
(patLen = Compare (ADR (subject[where]), ADR (pattern), patLen)) THEN
RETURN where;
END; (* success: where marks the spot *)
INC (where);
where := where + ScanR (ADR (subject[where]), subLen - where, BYTE (pattern[0]));
END;
RETURN start + subLen; (* FAILURE *)
END;
END FindPat;

PROCEDURE FindChar (ch, subject: ARRAY OF CHAR; start: CARDINAL): CARDINAL;
(* assuming ch has length 1, searches from position start for the first match *)
(* of ch in the subject. returns the Length (subject) to signal failure. *)

BEGIN
Assert (Length (ch) = 1, "FindChar pattern length not 1.");
RETURN start + ScanR (ADR (subject[start]), Length (subject) - start,
BYTE (ch));
END FindChar;

PROCEDURE FindOtherChar (ch, subject: ARRAY OF CHAR; start: CARDINAL): CARDINAL;
(* assuming ch has length 1, searches from postion start for the first non-match *)
(* of ch in the subject. returns the Length (subject) to signal failure. *)

BEGIN
Assert (Length (ch) = 1, "FindOtherChar pattern length not 1.");
RETURN start + ScanNeR (ADR (subject[start]), Length (subject) - start,
BYTE (ch));
END FindOtherChar;

PROCEDURE CopySub (VAR target: ARRAY OF CHAR; subject: ARRAY OF CHAR; start, len: CARDINAL);
(* assigns a copy of a substring of the subject to the target. the substring *)
(* begins at position start, and has a length of len. *)

VAR
targetLen, st, rem: CARDINAL;

BEGIN
st := SIZE (target);
rem := Length (subject) - start;
targetLen := len;
IF st < targetLen THEN
targetLen := st;
END;
IF rem < targetLen THEN
targetLen := rem;
END;
Move (ADR (subject[start]), ADR (target), targetLen);
Terminate (target, targetLen);
END CopySub;

PROCEDURE DeleteSub (VAR subject: ARRAY OF CHAR; start, len: CARDINAL);
(* delete a substring of the subject. the substring begins at position *)
(* start, and has length of len. *)

VAR
subLen: CARDINAL;

BEGIN
subLen := Length (subject);
IF start + len < subLen THEN
(* shift left the rest of the subject *)
Move (ADR (subject[start + len]), ADR (subject[start]),
subLen - (start + len));
Terminate (subject, subLen - len);
ELSE
Terminate (subject, start);
END;
END DeleteSub;

PROCEDURE Parse (VAR subject: ARRAY OF CHAR; pattern: ARRAY OF CHAR; VAR before: ARRAY OF CHAR);
(* search subject string, left to right, for first occurance of the substring pattern. *)
(* if not found, set before to subject, and subject to the empty string; else replace *)
(* subject by the remainder of the subject after the pattern. *)

VAR
where: CARDINAL;

BEGIN
where := FindPat (pattern, subject, 0);
CopySub (before, subject, 0, where);
DeleteSub (subject, 0, where + Length (pattern));
END Parse;

PROCEDURE LexCompare (VAR s1, s2: ARRAY OF CHAR): INTEGER;
(* assume s1 and s2 are canonical strings. returns an indication of the *)
(* relative lexical comparision of the two strings. [NOTE: VAR parameters *)
(* are used solely for efficiency. *)

VAR
len1, len2, lenx, pos: CARDINAL;

BEGIN
len1 := Length (s1);
len2 := Length (s2);
lenx := Min2C (len1, len2);
pos := Compare (ADR (s1), ADR (s2), lenx);
IF pos = lenx THEN
RETURN len1 - len2
ELSE
RETURN ORD (s1[pos]) - ORD (s2[pos]);
END;
END LexCompare;

PROCEDURE IsLess (s1, s2: ARRAY OF CHAR): BOOLEAN;

BEGIN
RETURN LexCompare (s1, s2) < 0;
END IsLess;

PROCEDURE IsEqual (s1, s2: ARRAY OF CHAR): BOOLEAN;

BEGIN
RETURN LexCompare (s1, s2) = 0;
END IsEqual;

PROCEDURE IsGreater (s1, s2: ARRAY OF CHAR): BOOLEAN;

BEGIN
RETURN LexCompare (s1, s2) > 0;
END IsGreater;

PROCEDURE TrimL (VAR s: ARRAY OF CHAR; ch: CHAR);
(* trim-left: delete leading characters from the string *)

VAR
ct: CARDINAL;

BEGIN
(* ScanNeR returns a count of the number of chars to be trimed *)
ct := ScanNeR (ADR (s), Length (s), SHORTCARD (ORD (ch)));
IF (ct > 0) THEN
DeleteSub (s, 0, ct);
END;
END TrimL;

PROCEDURE TrimR (VAR s: ARRAY OF CHAR; ch: CHAR);
(* trim-right: delete trailing characters from the string *)

VAR
ct, len: CARDINAL;

BEGIN
(* right-to-left scan, starting at the end *)
len := Length (s);
(* ScanNeL returns a count of the number of chars to be trimmed *)
ct := ScanNeL (ADR (s[len - 1]), len, SHORTCARD (ORD (ch)));
Terminate (s, len - ct);
END TrimR;

END FASTR.


  3 Responses to “Category : Modula II Source Code
Archive   : FASTR.ZIP
Filename : FASTR.MOD

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/