Some older sources of modules

While looking for fils to throw away on my hard disk, I came across a zip file with, apparently, the source code for Modula-2 library modules:

VGAlib, Statistics and Mouse have been cobered already in specific topics on this site. This section is about the remaining modules.

Barith : Binary Arithmetic

DEFINITION MODULE barith;

(*  This is FREE software, as described in the GNU General Public Licences.
    Therefore it comes WITH THE FULL SOURCES. Please feel free to improve this
    code when necessary. You OWN this code. I am not Bill Gates.

    I would appreciate that people let in this message when extending this
    library, as a small tribute to me (for laying the foundation). 

    In case people need extra information, contact me via:

        snail mail: Jan Verhoeven, 5012 GH 272, The Netherlands
   electronic mail: jverhoeven@bigfoot.com

    I remain full copyrights to these sources. If you want to send me a small 
    "thanks", please send me a postcard of your hometown to the above shown
    snailmail address. Yes it is in code; the internal code of our national 
    mail deliverer.

    Use this software at your own risk. Please find yourself a GNU GPL if you
    are in any doubt. I use these functions for all my own software, but there
    is NO GUARANTEE OF ANY KIND covering it.            *)

(*  Add support for bitwise logical operators to Modula-2.
    Binary ARITHmatic.
    *)

PROCEDURE and (x, y : CARDINAL) : CARDINAL;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := x AND y.
    *)

PROCEDURE nand (x, y : CARDINAL) : CARDINAL;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := x AND not Y.
    *)

PROCEDURE or (x, y : CARDINAL) : CARDINAL;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := x OR Y.
    *)

PROCEDURE nor (x, y : CARDINAL) : CARDINAL;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := x OR NOT y.
    *)

PROCEDURE xor (x, y : CARDINAL) : CARDINAL;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := x XOR y.
    *)

PROCEDURE test (x, y : CARDINAL) : BOOLEAN;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := TEST (x, y).
    *)

PROCEDURE shl (x, y : CARDINAL) : CARDINAL;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := SHL x, y
    *)

PROCEDURE shr (x, y : CARDINAL) : CARDINAL;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := SHR x for y bits.
    *)

PROCEDURE MulDiv (Mul1, Mul2, Div : CARDINAL) : CARDINAL;
(*
    Calculate Mul1 * Mul2 / Div with 32 bit intermediate result.  *)

END barith.
   
And the implementation:
IMPLEMENTATION MODULE barith;

(*  This is FREE software, as described in the GNU General Public Licences.
    Therefore it comes WITH THE FULL SOURCES. Please feel free to improve this
    code when necessary. You OWN this code. I am not Bill Gates.

    I would appreciate that people let in this message when extending this
    library, as a small tribute to me (for laying the foundation).

    In case people need extra information, contact me via:

        snail mail: Jan Verhoeven, 5012 GH 272, The Netherlands
   electronic mail: jverhoeven@bigfoot.com

    I remain full copyrights to these sources. If you want to send me a small
    "thanks", please send me a postcard of your hometown to the above shown
    snailmail address. Yes it is in code; the internal code of our national
    mail deliverer.

    Use this software at your own risk. Please find yourself a GNU GPL if you
    are in any doubt. I use these functions for all my own software, but there
    is NO GUARANTEE OF ANY KIND covering it.            *)

FROM    SYSTEM      IMPORT  ASSEMBLER;


PROCEDURE and (x, y : CARDINAL) : CARDINAL;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := x AND y.
    *)

VAR Result  : CARDINAL;

BEGIN
    ASM
        MOV  AX, x
        MOV  BX, y
        AND  AX, BX
        MOV  Result, AX
    END;
    RETURN Result;
END and;


PROCEDURE nand (x, y : CARDINAL) : CARDINAL;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := x AND not Y.
    *)

VAR Result  : CARDINAL;

BEGIN
    ASM
        MOV  AX, x
        MOV  BX, y
        NOT  BX
        AND  AX, BX
        MOV  Result, AX
    END;
    RETURN Result;
END nand;


PROCEDURE or (x, y : CARDINAL) : CARDINAL;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := x OR Y.
    *)

VAR Result  : CARDINAL;

BEGIN
    ASM
        MOV  AX, x
        MOV  BX, y
        OR   AX, BX
        MOV  Result, AX
    END;
    RETURN Result;
END or;


PROCEDURE nor (x, y : CARDINAL) : CARDINAL;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := x OR NOT y.
    *)

VAR Result  : CARDINAL;

BEGIN
    ASM
        MOV  AX, x
        MOV  BX, y
        NOT  BX
        OR   AX, BX
        MOV  Result, AX
    END;
    RETURN Result;
END nor;


PROCEDURE xor (x, y : CARDINAL) : CARDINAL;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := x XOR y.
    *)

VAR Result  : CARDINAL;

BEGIN
    ASM
        MOV  AX, x
        MOV  BX, y
        XOR  AX, BX
        MOV  Result, AX
    END;
    RETURN Result;
END xor;


PROCEDURE test (x, y : CARDINAL) : BOOLEAN;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := TEST (x, y)
    *)

VAR Result  : BOOLEAN;

BEGIN
    ASM
        MOV  DX, 0
        MOV  AX, x
        MOV  BX, y
        TEST AX, BX
        JZ   L0
        INC  DX
    L0: MOV  Result, DX
    END;
    RETURN Result;
END test;


PROCEDURE shl (x, y : CARDINAL) : CARDINAL;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := SHL x, y
    *)

VAR result  : CARDINAL;

BEGIN
    ASM
        MOV  AX, x
        MOV  CX, y
        AND  CX, 15
        JCXZ ok
        SHL  AX, CL
    ok: MOV  result, AX
    END;
    RETURN result;
END shl;


PROCEDURE shr (x, y : CARDINAL) : CARDINAL;
(*
    Perform binary arithmatic to operands x and y and return it.
    Operation:  Result := SHR x for y bits.
    *)

VAR result      : CARDINAL;

BEGIN
    ASM
        MOV  AX, x
        MOV  CX, y
        AND  CX, 15
        JCXZ ok
        SHR  AX, CL
    ok: MOV  result, AX
    END;
    RETURN result;
END shr;


PROCEDURE MulDiv (Mul1, Mul2, Div : CARDINAL) : CARDINAL;
(*
    Calculate Mul1 * Mul2 / Div with 32 bit intermediate result.  *)

VAR Result      : CARDINAL;

BEGIN
    ASM
        MOV  AX, Mul1
        MOV  BX, Mul2
        MUL  BX             (* DX:AX = result   *)
        MOV  BX, Div
        DIV  BX
        MOV  Result, AX
    END;
    RETURN Result;
END MulDiv;


END barith.
   
Later it turned out to be that Modula-2 already has these functions inside, in the SET related functions...


Effects : various text windows thingies

The definition module :

DEFINITION MODULE Effects;

PROCEDURE Frame		(TopY, TopX, BotY, BotX : CARDINAL; border : ARRAY OF CHAR);

PROCEDURE SpreidRegel	(regel	: ARRAY OF CHAR; 	breedte : CARDINAL);

PROCEDURE Wacht		(tijd	: CARDINAL);

PROCEDURE Roll		(reeks	: ARRAY OF CHAR; 	tijd : CARDINAL);

PROCEDURE ZekerWeten	(Actie	: ARRAY OF CHAR) : BOOLEAN;

PROCEDURE Bevestig	(opties	: ARRAY OF CHAR) : CHAR;

END Effects.
   
And the implementation module :
IMPLEMENTATION MODULE Effects;

FROM ASCII      IMPORT  ESC;
FROM Display    IMPORT  GetCursorPosition, Goto, SetCursorPosition,
                        Write, WriteChar;
FROM InOut      IMPORT  WriteString;
FROM Keyboard   IMPORT  GetKey;
FROM Strings    IMPORT  Length;
FROM SYSTEM     IMPORT  ASSEMBLER;
FROM Windows    IMPORT  CloseWindow, OpenWindow, Window;


PROCEDURE Frame (TopY, TopX, BotY, BotX : CARDINAL;
                 border                 : ARRAY OF CHAR );

VAR pos     : CARDINAL;

BEGIN
  SetCursorPosition (TopY, TopX);
  Write (border [0]);
  FOR pos := TopX + 1 TO BotX - 1 DO
    Write (border [1]);
    END;
  Write (border [2]);
  FOR pos := TopY + 1 TO BotY - 1 DO
    SetCursorPosition (pos, TopX);
    Write (border [3]);
    SetCursorPosition (pos, BotX);
    Write (border [5]);
    END;
  SetCursorPosition (BotY, BotX);
  WriteChar (border [8]);
  SetCursorPosition (BotY, TopX);
  Write (border [6]);
  FOR pos := TopX + 1 TO BotX - 1 DO
    Write (border [7]);
  END;
END Frame;


PROCEDURE SpreidRegel (regel : ARRAY OF CHAR; breedte : CARDINAL);

VAR     positie,
        woorden,
        Spaties,
        TussenSpaties,
        EindSpaties    : CARDINAL;

BEGIN
  woorden := 0;
  FOR positie := 0 TO Length (regel) -1 DO
    IF regel [positie] = " " THEN
      INC (woorden);
    END;
  END;
    Spaties := breedte - Length (regel);
    TussenSpaties   := Spaties DIV woorden;
    EindSpaties     := Spaties MOD woorden;
    FOR positie := 0 TO Length (regel) -1 DO
        IF regel [positie] = " " THEN
            FOR Spaties := 0 TO TussenSpaties DO
                Write (" ");
            END;
        ELSIF regel [positie] = "_" THEN
            Write (" ");
        ELSE
            Write (regel [positie]);
        END;
    END;
    FOR positie := 1 TO EindSpaties DO
        Write (" ");
    END;
END SpreidRegel;


PROCEDURE Wacht (tijd : CARDINAL);
(*  Wait <tijd> klokticks   *)

BEGIN
    ASM
        PUSH    DS
        MOV     BX, tijd
        XOR     AX, AX
        MOV     DS, AX
        MOV     SI, 46CH        (* Address of 18 Hz timer   *)
        MOV     AX, [SI]        (* Fetch current count      *)
        ADD     BX, AX          (* compose END-time         *)
    W8: MOV     AX, [SI]        (* Fetch new time           *)
        CMP     AX, BX          (* And compare with target  *)
        JNE     W8              (* Wait if not yet reached  *)
        POP     DS
    END;                        (* END of ASM *)
END Wacht;


PROCEDURE Roll (reeks : ARRAY OF CHAR; tijd : CARDINAL);
(*  Unroll text to the screen, centered and timed.  *)

VAR
    ReeksLengte, index          : CARDINAL;
    ScreenX, ScreenY, EndPos    : CARDINAL;
    DoChar, CharsToDo           : CARDINAL;

BEGIN
    ReeksLengte := Length (reeks);
    GetCursorPosition (ScreenY, ScreenX);
    EndPos := 40 + ReeksLengte DIV 2;       (* determine "exit" point   *)
    FOR CharsToDo := 0 TO ReeksLengte DO
        ScreenX := EndPos - CharsToDo;
        SetCursorPosition (ScreenY, ScreenX);
        FOR index := 0 TO CharsToDo DO
            Write (reeks [index]);
        END;                (* END of 2nd FOR   *)
        Wacht (tijd);
    END;                    (* END of main FOR  *)
END Roll;


PROCEDURE ZekerWeten (Actie : ARRAY OF CHAR) : BOOLEAN;

VAR w           : Window;
    letter      : CHAR;
    ok, geldig  : BOOLEAN;

BEGIN
    OpenWindow (w, 3, 50, 5, 75, TRUE, Actie);
    Goto (0, 2);    WriteString ("Ja of Nee");
    REPEAT
        geldig := TRUE;
        GetKey (letter);
        IF letter = 0C THEN     (* IF function key, THEN    *)
            GetKey (letter);    (* dispose off key          *)
            geldig := FALSE;
        END;
        letter := CAP (letter);
        IF    geldig AND (letter = "J") THEN
             ok := TRUE;
        ELSIF geldig AND (letter = "N") THEN
             ok := FALSE;
        ELSE geldig := FALSE;
        END;
        IF letter = ESC THEN
            ok      := FALSE;
            geldig  := TRUE;
        END;
    UNTIL geldig = TRUE;
    CloseWindow (w);
    RETURN ok;
END ZekerWeten;

PROCEDURE Bevestig (opties : ARRAY OF CHAR) : CHAR;

VAR Toets           : CHAR;
    Index, MaxLen   : CARDINAL;

BEGIN
    MaxLen := Length (opties);
    DEC (MaxLen);
    LOOP
        GetKey (Toets);
        Toets := CAP (Toets);
        FOR Index := 0 TO MaxLen DO
            IF opties [Index] = Toets THEN
                EXIT;
            END;
        END;
    END;
    RETURN Toets;
END Bevestig;

END Effects.
   


FileIO

The definition module :

DEFINITION MODULE FileIo;

FROM FileSystem     IMPORT File;

PROCEDURE ReadString   (device      : File;
                        VAR String  : ARRAY OF CHAR;
                        delimiter   : CHAR  );

(*  Read a String from file 'device' until a 'delimiter' char is found  *)

PROCEDURE WriteString  (device      : File;
                        String      : ARRAY OF CHAR;
                        delimiter   : CHAR  );

(*  Write a String to file 'device' and add the specified 'delimiter'.  *)

PROCEDURE ReadCard     (device      : File;
                        VAR card    : CARDINAL  ) : BOOLEAN;

(*  Read a CARDINAL as text from file 'device' and store in 'card';      *)

PROCEDURE WriteCard    (device      : File;
                        card        : CARDINAL;
                        precision   : CARDINAL;
                        delimiter   : CHAR      );

(*  Write a CARDINAL to file 'device'       *)

END FileIo.
   
And the implementation module :
IMPLEMENTATION MODULE FileIo;

FROM ASCII              IMPORT  EOL;
FROM FileSystem         IMPORT  File, ReadChar, WriteChar;
FROM NumberConversion   IMPORT  StringToCard, CardToString;

PROCEDURE ReadString (device        : File;
                      VAR String    : ARRAY OF CHAR;
                      delimiter     : CHAR  );
VAR char    : CHAR;
    index   : CARDINAL;

BEGIN
    index := 0;
    REPEAT
        ReadChar (device, char);
        String [index] := char;
        INC (index);
    UNTIL char = delimiter;
    DEC (index);
    String [index] := 0C;
END ReadString;

PROCEDURE WriteString  (device      : File;
                        String      : ARRAY OF CHAR;
                        delimiter   : CHAR  );
VAR index   : CARDINAL;
    Max     : CARDINAL;
    Char    : CHAR;

BEGIN
    index := 0;
    Max := HIGH (String);
    Char := String [index];
    WHILE (Char # 0C) AND (index <= Max) DO
        WriteChar (device, Char);
        INC (index);
        IF index <= Max THEN
            Char := String [index];
        END;
    END;
    WriteChar (device, delimiter);
END WriteString;

PROCEDURE ReadCard (device : File; VAR card : CARDINAL) : BOOLEAN;

VAR char    : CHAR;
    index   : CARDINAL;
    storage : ARRAY [0..7] OF CHAR;
    ok      : BOOLEAN;

BEGIN
    index := 0;
    LOOP
        ReadChar (device, char);
        CASE char OF
            "0".."9"      : storage [index] := char;
               |
            ",", EOL, " " : ok := TRUE; EXIT;
        ELSE
            ok := FALSE; EXIT;
        END;
        INC (index);
    END;
    storage [index] := 0C;
    IF ok THEN
        StringToCard (storage, card, ok);
    END;
    RETURN ok;
END ReadCard;

PROCEDURE WriteCard    (device      : File;
                        card        : CARDINAL;
                        precision   : CARDINAL;
                        delimiter   : CHAR      );

VAR storage     : ARRAY [0..9] OF CHAR;

BEGIN
    CardToString (card, storage, precision);
    WriteString (device, storage, delimiter);
END WriteCard;

END FileIo.
   


LowLevel : Access to IO ports

The definition module :

DEFINITION MODULE LowLevel;

(*  This is FREE software, as described in the GNU General Public Licences. 
    Therefore it comes WITH THE FULL SOURCES. Please feel free to improve this 
    code when necessary. You OWN this code. I am not Bill Gates.

    I would appreciate that people let in this message when extending this 
    library, as a small tribute to me (for laying the foundation). 

    In case people need extra information, contact me via:

        snail mail: Jan Verhoeven, 5012 GH 272, The Netherlands
   electronic mail: jverhoeven@bigfoot.com

    I remain full copyrights to these sources. If you want to send me a small 
    "thanks", please send me a postcard of your hometown to the above shown
    snailmail address. Yes it is in code; the internal code of our national 
    mail deliverer.

    Use this software at your own risk. Please find yourself a GNU GPL if you 
    are in any doubt. I use these functions for all my own software, but there
    is NO GUARANTEE OF ANY KIND covering it.            *)

TYPE    IOsize      = (Byte, Word);

PROCEDURE InPort	(Port : CARDINAL;	Size : IOsize) : CARDINAL;

(*	Return value by reading I/O port 'Port'.	*)

PROCEDURE OutPort 	(Port, Value : CARDINAL; Size : IOsize);

(*	Send byte 'Value' to I/O port 'Port'.	*)

END LowLevel.
   
And the implementation module :
IMPLEMENTATION MODULE LowLevel;

(*  This is FREE software, as described in the GNU General Public Licences.
    Therefore it comes WITH THE FULL SOURCES. Please feel free to improve this
    code when necessary. You OWN this code. I am not Bill Gates.

    I would appreciate that people let in this message when extending this
    library, as a small tribute to me (for laying the foundation).

    In case people need extra information, contact me via:

        snail mail: Jan Verhoeven, 5012 GH 272, The Netherlands
   electronic mail: jverhoeven@bigfoot.com

    I remain full copyrights to these sources. If you want to send me a small
    "thanks", please send me a postcard of your hometown to the above shown
    snailmail address. Yes it is in code; the internal code of our national
    mail deliverer.

    Use this software at your own risk. Please find yourself a GNU GPL if you
    are in any doubt. I use these functions for all my own software, but there
    is NO GUARANTEE OF ANY KIND covering it.            *)


FROM    SYSTEM      IMPORT  ASSEMBLER;

PROCEDURE InPort (Port : CARDINAL; Size : IOsize) : CARDINAL;

(*	Return value by reading I/O port 'Port'.	*)

VAR Result  : CARDINAL;

BEGIN
  IF Size = Word THEN
    ASM
      MOV  DX, Port
      IN   AX, DX
      MOV  Result, AX
    END;
  ELSE
    ASM
      MOV  DX, Port
      IN   AL, DX
      MOV  AH, 0
      MOV  Result, AX
    END;
  END;
  RETURN Result;
END InPort;


PROCEDURE OutPort (Port, Value : CARDINAL; Size : IOsize);

(*	Send byte 'Value' to I/O port 'Port'.	*)

BEGIN
  IF Size = Word THEN
    ASM
      MOV  DX, Port
      MOV  AX, Value
      OUT  DX, AX
    END;
  ELSE
    ASM
      MOV  DX, Port
      MOV  AL, Value
      OUT  DX, AL
    END;
  END;
END OutPort;

END LowLevel.
   


Tijd

The definition module :

DEFINITION MODULE Tijd;

PROCEDURE Seconde	(VAR sec   : CARDINAL);

PROCEDURE Minuut	(VAR min   : CARDINAL);

PROCEDURE Uur		(VAR uur   : CARDINAL);

PROCEDURE DagVdMaand	(VAR dag   : CARDINAL);

PROCEDURE Maand		(VAR maand : CARDINAL);

PROCEDURE Jaar		(VAR jaar  : CARDINAL);

PROCEDURE DagenVanaf95	(dag, maand, jaar : CARDINAL) : CARDINAL;

PROCEDURE MaakDatum	( VAR dag, maand, jaar    : CARDINAL;
                          delta                   : CARDINAL) ;

PROCEDURE Random (VAR   waarde  : CARDINAL;
                        grens   : CARDINAL  );

(*	bepaal het volgende RANDOM getal en sla dit op in "waarde".
	"waarde" is altijd kleiner dan "grens".
 	*)

(*  PROCEDURE WeekDag (dag, maand, jaar) : CARDINAL;   *)

END Tijd.
   
And the implementation module :
IMPLEMENTATION MODULE Tijd;

FROM SYSTEM         IMPORT  ASSEMBLER;

PROCEDURE Seconde (VAR sec : CARDINAL);
BEGIN
    ASM
    opnieuw:
        MOV     AL, 0
        OUT     70H, AL
        IN      AL, 71H
        MOV     BH, AL
        MOV     BL, 10
        AND     AL, 0F0H
        AND     BH, 00FH
        MOV     CL, 4
        SHR     AL, CL
        MUL     BL
        ADD     AL, BH
        CMP     AL, 60
        JAE     opnieuw
        LES     DI, sec
        STOSW
    END;
END Seconde;

PROCEDURE Minuut (VAR min : CARDINAL);
BEGIN
    ASM
    opnieuw:
        MOV     AL, 2
        OUT     70H, AL
        IN      AL, 71H
        MOV     BH, AL
        MOV     BL, 10
        AND     AL, 0F0H
        AND     BH, 00FH
        MOV     CL, 4
        SHR     AL, CL
        MUL     BL
        ADD     AL, BH
        CMP     AL, 60
        JAE     opnieuw
        LES     DI, min
        STOSW
    END;
END Minuut;

PROCEDURE Uur (VAR uur : CARDINAL);
BEGIN
    ASM
    opnieuw:
        MOV     AL, 4
        OUT     70H, AL
        IN      AL, 71H
        MOV     BH, AL
        MOV     BL, 10
        AND     AL, 0F0H
        AND     BH, 00FH
        MOV     CL, 4
        SHR     AL, CL
        MUL     BL
        ADD     AL, BH
        CMP     AL, 24
        JAE     opnieuw
        LES     DI, uur
        STOSW
    END;
END Uur;

PROCEDURE DagVdMaand (VAR dag : CARDINAL);
BEGIN
    ASM
    opnieuw:
        MOV     AL, 7
        OUT     70H, AL
        IN      AL, 71H
        MOV     BH, AL
        MOV     BL, 10
        AND     AL, 0F0H
        AND     BH, 00FH
        MOV     CL, 4
        SHR     AL, CL
        MUL     BL
        ADD     AL, BH
        CMP     AL, 31
        JAE     opnieuw
        LES     DI, dag
        STOSW
    END;
END DagVdMaand;

PROCEDURE Maand (VAR maand : CARDINAL);
BEGIN
    ASM
    opnieuw:
        MOV     AL, 8
        OUT     70H, AL
        IN      AL, 71H
        MOV     BH, AL
        MOV     BL, 10
        AND     AL, 0F0H
        AND     BH, 00FH
        MOV     CL, 4
        SHR     AL, CL
        MUL     BL
        ADD     AL, BH
        CMP     AL, 12
        JAE     opnieuw
        LES     DI, maand
        STOSW
    END;
END Maand;

PROCEDURE Jaar (VAR jaar : CARDINAL);
BEGIN
    ASM
    opnieuw:
        MOV     AL, 9
        OUT     70H, AL
        IN      AL, 71H
        MOV     BH, AL
        MOV     BL, 10
        AND     AL, 0F0H
        AND     BH, 00FH
        MOV     CL, 4
        SHR     AL, CL
        MUL     BL
        ADD     AL, BH
        ADC     AX, 1900
        CMP     AX, 165
        JE      opnieuw
        LES     DI, jaar
        STOSW
    END;
END Jaar;


PROCEDURE DagenVanaf95 (dag, maand, jaar : CARDINAL) : CARDINAL;

VAR totaal  : CARDINAL;

BEGIN
    totaal := dag;
    WHILE jaar > 1995 DO
        DEC (jaar);
        INC (totaal, 365);
        IF jaar MOD 4 = 0 THEN
            INC (totaal);
        END;
    END;
    WHILE maand > 1 DO
        DEC (maand);
        CASE maand OF
            1, 3, 5, 7,
            8, 10, 12 : INC (totaal, 31);
            |
            4, 6,
            9, 11     : INC (totaal, 30);
            |
            2         : INC (totaal, 28);
                        IF (jaar MOD 4 = 0) THEN
                            INC (totaal);
                        END;
        END;
    END;
    DEC (totaal);
    RETURN totaal;
END DagenVanaf95;

PROCEDURE MaakDatum (VAR dag, maand, jaar   : CARDINAL; delta : CARDINAL);

VAR MaxDag      : CARDINAL;

BEGIN
    INC (dag, delta);
    LOOP
        CASE maand OF
            1, 3, 5, 7,
            8, 10, 12   : MaxDag := 31;
            |
            4, 6, 9, 11 : MaxDag := 30;
        ELSE
            IF jaar MOD 4 = 0 THEN
                MaxDag := 28;
            ELSE
                MaxDag := 29;
            END;
        END;
        IF dag > MaxDag THEN
            DEC (dag, MaxDag);
            INC (maand);
            IF maand > 12 THEN
                maand := 1;
                INC (jaar);
            END;
        ELSE
            EXIT;
        END;
    END;
END MaakDatum;

PROCEDURE Random (VAR waarde    : CARDINAL;
                      grens     : CARDINAL  );
BEGIN
    ASM
        XOR     DX, DX
        MOV     ES, DX
        MOV     BX, 46CH
        MOV     AX, ES:[BX]
        MOV     BX, grens
    next:
        SUB     AX, BX
        CMP     AX, BX
        JA      next
        LES     DI, waarde
        STOSW
    END;
END Random;

(*  PROCEDURE WeekDag (dag, maand, jaar) : CARDINAL;   *)

END Tijd.
   


Timer

The definition module :

DEFINITION MODULE Timer;

PROCEDURE OpenTimer;                    (*  open timer chip in mode 2   *)

PROCEDURE CloseTimer;                   (*  close timer chip in mode 2  *)

PROCEDURE ReadTimer () : CARDINAL;      (*  read timer chip in mode 2   *)

PROCEDURE Wait (ms : CARDINAL);         (*  wait for 'ms' milliseconds  *)

PROCEDURE LongWait (time : CARDINAL);   (*  wait for time ms; time > 55 *)


END Timer.
   
And the implementation module :
IMPLEMENTATION MODULE Timer;

FROM    SYSTEM          IMPORT  ASSEMBLER;


PROCEDURE OpenTimer;

BEGIN
  ASM
    MOV  AL, 34H            (*  open timer chip in mode 2   *)
    OUT  43H, AL
    XOR  AL, AL
    OUT  40H, AL
    OUT  40H, AL
  END;
END OpenTimer;


PROCEDURE CloseTimer;           (*  close timer chip in mode 2   *)

BEGIN
  ASM
    MOV  AL, 36H
    OUT  43H, AL
    XOR  AL, AL
    OUT  40H, AL
    OUT  40H, AL
  END;
END CloseTimer;


PROCEDURE ReadTimer () : CARDINAL;     (*  read timer chip in mode 2    *)

VAR     Time        : CARDINAL;

BEGIN
  ASM
    MOV  AL, 6
    OUT  43H, AL
    IN   AL, 40H
    MOV  AH, AL
    IN   AL, 40H
    XCHG AH, AL
    MOV  [Time], AX
  END;
  RETURN Time;
END ReadTimer;


PROCEDURE Wait (ms : CARDINAL);         (*  wait for 'ms' milliseconds  (ms < 55)   *)

VAR     MaxCount    : CARDINAL;

BEGIN
    MaxCount := 0FFFFH - ms * 1193;
    OpenTimer;
    WHILE ReadTimer () > MaxCount DO
        (*  absolutely nothing  *)
    END;
    CloseTimer;
END Wait;


PROCEDURE LongWait (time : CARDINAL);   (*  wait for more than 55 ms    *)

VAR     i       : CARDINAL;

BEGIN
    FOR i := 1 TO time DO
        Wait (1)
    END
END LongWait;

END Timer.
   


Xchar

The definition module :

DEFINITION MODULE Xchar;

(*  This is FREE software, as described in the GNU General Public Licences.
    Therefore it comes WITH THE FULL SOURCES. Please feel free to improve this
    code when necessary. You OWN this code. I am not Bill Gates.

    I would appreciate that people let in this message when extending this
    library, as a small tribute to me (for laying the foundation).

    In case people need extra information, contact me via:

        snail mail: Jan Verhoeven, 5012 GH 272, The Netherlands
   electronic mail: jverhoeven@bigfoot.com

    I remain full copyrights to these sources. If you want to send me a small
    "thanks", please send me a postcard of your hometown to the above shown
    snailmail address. Yes it is in code; the internal code of our national
    mail deliverer.

    Use this software at your own risk. Please find yourself a GNU GPL if you
    are in any doubt. I use these functions for all my own software, but there
    is NO GUARANTEE OF ANY KIND covering it.            *)


PROCEDURE Lower (Char : CHAR) : CHAR;
(*
    Convert any case character to lower case.
    *)

PROCEDURE IsDigit (Char : CHAR) : BOOLEAN;
(*
    Check whether Char is a digit or not.
    Return TRUE if so, FALSE otherwise
    *)

PROCEDURE IsHexDigit (Char : CHAR) : BOOLEAN;
(*
    Check whether Char is a valid hexdigit or not.
    Return TRUE if so, FALSE otherwise
    *)

PROCEDURE IsLetter (Char : CHAR) : BOOLEAN;
(*
    Check if Char is a Letter.
    Return TRUE if so, FALSE otherwise.
    *)

PROCEDURE LowerString (VAR String : ARRAY OF CHAR);
(*
    Convert complete String to lower case.
    *)

PROCEDURE UpperString (VAR String : ARRAY OF CHAR);
(*
    Convert complete String to upper case.
    *)

PROCEDURE KeyW8 (Token  : CHAR);

(*  Wait for key 'Token' was pressed	*)

PROCEDURE SkipUntil (letter  : CHAR);

(*  Skip all characters until "letter"    *)

PROCEDURE Print (s  : ARRAY OF CHAR);

(*  Colourful version of WriteString.
    This routine uses "displayAttr" which must be IMPORTed from Display.
    *)

PROCEDURE ReadName (VAR buffer : ARRAY OF CHAR);

(*  Read a quoted name from the (redirected) terminal.
    The function waits until a quote is entered, takes up letters and
    stops after the second quote (") is received.
    *)

PROCEDURE CompressName (in  : ARRAY OF CHAR; VAR out  : ARRAY OF CHAR);

(*  Remove spaces from the string "in" and store the result in  string "out".    *)

END Xchar.
   
And the implementation module :
IMPLEMENTATION MODULE Xchar;

(*  This is FREE software, as described in the GNU General Public Licences.
    Therefore it comes WITH THE FULL SOURCES. Please feel free to improve this
    code when necessary. You OWN this code. I am not Bill Gates.

    I would appreciate that people let in this message when extending this
    library, as a small tribute to me (for laying the foundation). 

    In case people need extra information, contact me via:

        snail mail: Jan Verhoeven, 5012 GH 272, The Netherlands
   electronic mail: jverhoeven@bigfoot.com

    I remain full copyrights to these sources. If you want to send me a small 
    "thanks", please send me a postcard of your hometown to the above shown
    snailmail address. Yes it is in code; the internal code of our national 
    mail deliverer.

    Use this software at your own risk. Please find yourself a GNU GPL if you
    are in any doubt. I use these functions for all my own software, but there
    is NO GUARANTEE OF ANY KIND covering it.            *)

IMPORT  Display;

FROM    InOut           IMPORT  Read;
FROM    Keyboard        IMPORT  GetKey;


PROCEDURE Lower (Char : CHAR) : CHAR;

BEGIN
    CASE Char OF
        "A".."Z" : Char := CHR ( ORD (Char) + 32)
    END;
    RETURN Char
END Lower;


PROCEDURE IsDigit (Char : CHAR) : BOOLEAN;

BEGIN
    CASE Char OF
        "0".."9" : RETURN TRUE
    ELSE
        RETURN FALSE
    END
END IsDigit;


PROCEDURE IsHexDigit (Char : CHAR) : BOOLEAN;

BEGIN
    CASE Char OF
        "0".."9",
        "A".."F",
        "a".."f"  : RETURN TRUE
    ELSE
        RETURN FALSE
    END
END IsHexDigit;


PROCEDURE IsLetter (Char : CHAR) : BOOLEAN;

BEGIN
    CASE Char OF
        "A".."Z",
        "a".."z" : RETURN TRUE
    ELSE
        RETURN FALSE
    END
END IsLetter;


PROCEDURE LowerString (VAR String : ARRAY OF CHAR);

VAR index   : CARDINAL;
    Max     : CARDINAL;
    Char    : CHAR;

BEGIN
    index := 0;
    Char := String [index];
    Max := HIGH (String);
    WHILE (Char # 0C) AND (index <= Max) DO
        String [index] := Lower (Char);
        INC (index);
        Char := String [index]
    END
END LowerString;


PROCEDURE UpperString (VAR String : ARRAY OF CHAR);

VAR index   : CARDINAL;
    Max     : CARDINAL;
    Char    : CHAR;

BEGIN
    index := 0;
    Char := String [0];
    Max := HIGH (String);
    WHILE (Char # 0C) AND (index <= Max) DO
        Char := String [index];
        String [index] := CAP (Char);
        INC (index)
    END
END UpperString;


PROCEDURE KeyW8 (soll  : CHAR);             (*  Wait for a keypress     *)

VAR     ist     : CHAR;

BEGIN
    LOOP
        GetKey (ist);
        IF ist = soll THEN EXIT END
    END
END KeyW8;


PROCEDURE SkipUntil (soll  : CHAR);         (*  Skip all tokens until "soll"    *)

VAR     ist     : CHAR;

BEGIN
    REPEAT
        Read (ist)
    UNTIL ist = soll
END SkipUntil;


PROCEDURE Print (s  : ARRAY OF CHAR);       (*  Colourful version of WriteString    *)

VAR     n       : CARDINAL;

BEGIN
    n := 0;
    LOOP
        IF (n > HIGH (s)) OR (s [n] = 0C) THEN EXIT END;
        Display.Write (s [n]);
        INC (n)
    END
END Print;


PROCEDURE ReadName (VAR buffer : ARRAY OF CHAR);

(*  Read a quoted name from the (redirected) terminal       *)

VAR     ch      : CHAR;
        n       : CARDINAL;

BEGIN
    n := 0;
    REPEAT
        Read (ch)
    UNTIL ch = '"';                     (*  get rid of spaces   *)
    LOOP
        Read (ch);
        IF ch = '"' THEN EXIT END;      (*  If ch = '"' THEN exit loop  *)
        buffer [n] := ch;               (*  Else store ch in Array      *)
        INC (n)
    END;
    IF n <= HIGH (buffer) THEN
        buffer [n] := 0C
    END
END ReadName;


PROCEDURE CompressName (in  : ARRAY OF CHAR; VAR out  : ARRAY OF CHAR);

(*  Remove ALL spaces and control characters from the string       *)

VAR     i, j    : CARDINAL;

BEGIN
    j := 0;
    FOR i := 0 TO HIGH (in) DO
        IF in [i] > ' ' THEN            (*  IF alphanum THEN store in array OUT     *)
            out [j] := in [i];
            INC (j)
        END
    END;
    out [j] := 0C
END CompressName;

END Xchar.
   

Page created August 26, 2010 and