0FAH: DECLARE BDOS LITERALLY '3206H';

/* TO COMPILE THIS LOADER FOR CP/M 2 USE: */
/*0FAH: DECLARE BDOS LITERALLY '5';*/

  /*              TRANSIENT COMMAND LOADER PROGRAM

      AUTHOR UNKNOWN, IT MOST LIKELY WAS WRITTEN BY GARY KILDALL
      AT NARVAL POSTGRADUATE SCHOOL.

      OLD FRIEND, THE INDENTATION YOU LEFT FOR US IS A MESS. I HAVE
      FIXED THAT. NOW LOOK THROUGH MY EYES AT THE BEAUTY OF THE SOURCE,
      I HOPE THIS IS OK WITH YOU, AND IF NOT... TOO BAD.
      NOTE TO THOSE WHO MESS WITH THE SOURCES AFTER ME:
          A FRIEND, J.R.D., USED TO SAY:
              OK, I FIXED THAT FOR YOU.
              IF YOU BREAK IT AGAIN, I WILL BREAK YOUR FINGERS.

      THE ORIGINAL PROGRAM INCLUDES LIBRARY ROUTINES FROM ANOTHER
      FILE, IOLIB.PLM, WHICH IS LOST. IN A DISCUSSION ON C.O.C
      JEFFREY W. SHOOK POINTED OUT, THAT THE LIBRARY ROUTINES
      INCLUDED IN CCP.PLM MAKE A GOOD SUBSTITUTE. THIS ROUTINES
      ARE USED HERE, THANKS JEFF.

      THE ORIGINAL PROGRAM LOOPED ENDLESS IF THE READER WAS NOT
      READY AND RETURNED CTRL-Z (EOF). THIS IS FIXED.

      IF THE ORIGINAL PROGRAM WAS USED WITHOUT A FILENAME, IT
      CREATED A BOGUS ONE. THIS IS FIXED, THIS VERSION CREATES
      THE FILE $$$.COM IN THIS CASE.

      IF YOU DO NOT HAVE A LOADER THAT CAN LOAD A HEX FILE
      ORIGINATED AT 0FAH, YOU HAVE A BOOTSTRAP PROBLEM THAT
      CAN BE SOLVED:
          - COMPILE FIRST VERSION ORIGINATED AT 0100H
          - USE DDT AND PATCH FIRST 6 BYTES WITH NOP
          - COMPILE SECOND VERSION ORIGINATED AT 0FAH
          - USE FIRST VERSION TO LOAD SECOND ONE

      OCTOBER 2007, UDO MUNK
                                                                         */


LOADCOM: PROCEDURE BYTE;
    DECLARE FCBA ADDRESS INITIAL(5CH);
    DECLARE FCB BASED FCBA (33) BYTE;

    DECLARE BUFFA ADDRESS INITIAL(80H), /* I/O BUFFER ADDRESS */
        BUFFER BASED BUFFA (128) BYTE;

    DECLARE SFCB(33) BYTE,  /* SOURCE FILE CONTROL BLOCK */
        BSIZE LITERALLY '1024',
        EOFILE LITERALLY '1AH',
        SBUFF(BSIZE) BYTE   /* SOURCE FILE BUFFER */
            INITIAL(EOFILE),
        RFLAG BYTE,         /* READER FLAG */
        SBP ADDRESS;        /* SOURCE FILE BUFFER POINTER */

    /* LOADCOM LOADS TRANSIENT COMMAND FILES TO THE DISK FROM THE
       CURRENTLY DEFINED READER PERIPHERAL.  THE LOADER PLACES THE MACHINE
       CODE INTO A FILE WHICH APPEARS IN THE LOADCOM COMMAND */


 /* **************** LIBRARY PROCEDURES FOR DISKIO ************* */


    MON1: PROCEDURE(F,A);
        DECLARE F BYTE,
        A ADDRESS;
        GO TO BDOS;
        END MON1;

    MON2: PROCEDURE(F,A) BYTE;
        DECLARE F BYTE,
        A ADDRESS;
        GO TO BDOS;
        END MON2;

    READRDR: PROCEDURE BYTE;
        /* READ FROM CURRENTLY ASSIGNED READER DEVICE */
        RETURN MON2(3,0);
        END READRDR;

    READCHAR: PROCEDURE BYTE;
        RETURN MON2(1,0);
        END READCHAR;

    DECLARE
        TRUE LITERALLY '1',
        FALSE LITERALLY '0',
        FOREVER LITERALLY 'WHILE TRUE',
        CR LITERALLY '13',
        LF LITERALLY '10',
        WHAT LITERALLY '63';

    PRINTCHAR: PROCEDURE(CHAR);
        DECLARE CHAR BYTE;
        CALL MON1(2,CHAR);
        END PRINTCHAR;

    CRLF: PROCEDURE;
        CALL PRINTCHAR(CR);
        CALL PRINTCHAR(LF);
        END CRLF;

    PRINT: PROCEDURE(A);
        DECLARE A ADDRESS;
        /* PRINT THE STRING STARTING AT ADDRESS A UNTIL THE
        NEXT DOLLAR SIGN IS ENCOUNTERED */
        CALL CRLF;
        CALL MON1(9,A);
        END PRINT;

    READ: PROCEDURE(A);
        DECLARE A ADDRESS;
        /* READ INTO BUFFER AT A+2 */
        CALL MON1(10,A);
        END READ;

    DECLARE DCNT BYTE;

    INITIALIZE: PROCEDURE;
        CALL MON1(13,0);
        END INITIALIZE;

    SELECT: PROCEDURE(D);
        DECLARE D BYTE;
        CALL MON1(14,D);
        END SELECT;

    OPEN: PROCEDURE(FCB);
        DECLARE FCB ADDRESS;
        DCNT = MON2(15,FCB);
        END OPEN;

    CLOSE: PROCEDURE(FCB);
        DECLARE FCB ADDRESS;
        DCNT = MON2(16,FCB);
        END CLOSE;

    SEARCH: PROCEDURE(FCB);
        DECLARE FCB ADDRESS;
        DCNT = MON2(17,FCB);
        END SEARCH;

    SEARCHN: PROCEDURE;
        DCNT = MON2(18,0);
        END SEARCHN;

    DELETE: PROCEDURE(FCB);
        DECLARE FCB ADDRESS;
        CALL MON1(19,FCB);
        END DELETE;

    DISKREAD: PROCEDURE(FCB) BYTE;
        DECLARE FCB ADDRESS;
        RETURN MON2(20,FCB);
        END DISKREAD;

    DISKWRITE: PROCEDURE(FCB) BYTE;
        DECLARE FCB ADDRESS;
        RETURN MON2(21,FCB);
        END DISKWRITE;

    MAKE: PROCEDURE(FCB);
        DECLARE FCB ADDRESS;
        DCNT = MON2(22,FCB);
        END MAKE;

    RENAME: PROCEDURE(FCB);
        DECLARE FCB ADDRESS;
        CALL MON1(23,FCB);
        END RENAME;

    DECLARE (MAXLEN,COMLEN) BYTE, /* MAXIMUM AND CURRENT LENGTH */
    COMBUFF(128) BYTE,                /* COMMAND BUFFER */
    (TCBP,CBP) BYTE;                  /* BUFFER POINTERS */

    READCOM: PROCEDURE;
        /* READ INTO COMMAND BUFFER */
        MAXLEN = 128;
        CALL READ(.MAXLEN);
        END READCOM;


 /* **************** END OF LIBRARY PROCEDURES ***************** */


    MOVE: PROCEDURE(S,D,N);
        DECLARE (S,D) ADDRESS, N BYTE,
        A BASED S BYTE, B BASED D BYTE;
        DO WHILE (N:=N-1) <> 255;
            B = A; S=S+1; D=D+1;
        END;
        END MOVE;

    GETCHAR: PROCEDURE BYTE;
        /* GET NEXT CHARACTER */
        DECLARE I BYTE;
        IF RFLAG THEN RETURN READRDR;
        IF (SBP := SBP+1) <= LAST(SBUFF) THEN
            RETURN SBUFF(SBP);
        /* OTHERWISE READ ANOTHER BUFFER FULL */
        DO SBP = 0 TO LAST(SBUFF) BY 128;
            IF (I:=DISKREAD(.SFCB)) = 0 THEN
                CALL MOVE(80H,.SBUFF(SBP),80H);
            ELSE DO;
                IF I<>1 THEN CALL PRINT(.'DISK READ ERROR$');
                SBUFF(SBP) = EOFILE;
                SBP = LAST(SBUFF);
            END;
        END;
        SBP = 0; RETURN SBUFF;
        END GETCHAR;

    DECLARE
        STACKPOINTER LITERALLY 'STACKPTR';

    PRINTNIB: PROCEDURE(N);
        DECLARE N BYTE;
        IF N > 9 THEN CALL PRINTCHAR(N+'A'-10); ELSE
            CALL PRINTCHAR(N+'0');
        END PRINTNIB;

    PRINTHEX: PROCEDURE(B);
        DECLARE B BYTE;
        CALL PRINTNIB(SHR(B,4)); CALL PRINTNIB(B AND 0FH);
        END PRINTHEX;

    PRINTADDR: PROCEDURE(A);
        DECLARE A ADDRESS;
        CALL PRINTHEX(HIGH(A)); CALL PRINTHEX(LOW(A));
        END PRINTADDR;

 /* INTEL HEX FORMAT LOADER */

    RELOC: PROCEDURE;
        DECLARE (RL, CS, RT) BYTE;
        DECLARE
            LA ADDRESS,     /* LOAD ADDRESS */
            TA ADDRESS,     /* TEMP ADDRESS */
            SA ADDRESS,     /* START ADDRESS */
            FA ADDRESS,     /* FINAL ADDRESS */
            NB ADDRESS,     /* NUMBER OF BYTES LOADED */
            SP ADDRESS,     /* STACK POINTER UPON ENTRY TO RELOC */
            MBUFF(256) BYTE,
            P BYTE,
            L ADDRESS,
            I BYTE;

        SETMEM: PROCEDURE(B);
            /* SET MBUFF TO B AT LOCATION LA MOD LENGTH(MBUFF) */
            DECLARE (B,I) BYTE;
            IF LA < L THEN /* MAY BE A RETRY */ RETURN;
            DO WHILE LA > L + LAST(MBUFF); /* WRITE A PARAGRAPH */
                DO I = 0 TO 127; /* COPY INTO BUFFER */
                    BUFFER(I) = MBUFF(LOW(L)); L = L + 1;
                END;
                /* WRITE BUFFER ONTO DISK */
                P = P + 1;
                IF DISKWRITE(FCBA) <> 0 THEN DO;
                    CALL PRINT(.'DISK WRITE ERROR$');
                    HALT;
                    /* RETRY AFTER INTERRUPT NOP */
                    L = L - 128;
                END;
            END;
            MBUFF(LOW(LA)) = B;
            END SETMEM;

        READHEX: PROCEDURE BYTE;
            /* READ ONE HEX CHARACTER FROM THE INPUT */
            DECLARE H BYTE;
            IF (H := GETCHAR) - '0' <= 9 THEN RETURN H - '0';
            IF H - 'A' > 5 THEN GO TO CHARERR;
            RETURN H - 'A' + 10;
            END READHEX;

        READBYTE: PROCEDURE BYTE;
            /* READ TWO HEX DIGITS */
            RETURN SHL(READHEX,4) OR READHEX;
            END READBYTE;

        READCS: PROCEDURE BYTE;
            /* READ BYTE WHILE COMPUTING CHECKSUM */
            DECLARE B BYTE;
            CS = CS + (B := READBYTE);
            RETURN B;
            END READCS;

        MAKE$DOUBLE: PROCEDURE(H,L) ADDRESS;
            /* CREATE A BOUBLE BYTE VALUE FROM TWO SINGLE BYTES */
            DECLARE (H,L) BYTE;
            RETURN SHL(DOUBLE(H),8) OR L;
            END MAKE$DOUBLE;

        DIAGNOSE: PROCEDURE;
            DECLARE M BASED TA BYTE;

            NEWLINE: PROCEDURE;
                CALL CRLF; CALL PRINTADDR(TA); CALL PRINTCHAR(':');
                CALL PRINTCHAR(' ');
                END NEWLINE;

            /* PRINT DIAGNOSTIC INFORMATION AT THE CONSOLE */
            CALL PRINT(.'LOAD  ADDRESS $'); CALL PRINTADDR(TA);
            CALL PRINT(.'ERROR ADDRESS $'); CALL PRINTADDR(LA);

            CALL PRINT(.'BYTES READ:$'); CALL NEWLINE;
            DO WHILE TA < LA;
                IF (LOW(TA) AND 0FH) = 0  THEN CALL NEWLINE;
                CALL PRINTHEX(MBUFF(TA-L)); TA=TA+1;
                CALL PRINTCHAR(' ');
            END;
            CALL CRLF;
            HALT;
            END DIAGNOSE;

        /* INITIALIZE */
        SA, FA, NB = 0;
        SP = STACKPOINTER;
        P = 0; /* PARAGRAPH COUNT */
        TA,LA,L = 100H;  /* BASE ADDRESS OF TRANSIENT ROUTINES */
        IF FALSE THEN
        CHARERR:  /* ARRIVE HERE IF NON-HEX DIGIT IS ENCOUNTERED */
        DO;
            /* RESTORE STACKPOINTER */
            STACKPOINTER = SP;
            CALL PRINT(.'NON-HEXADECIMAL DIGIT ENCOUNTERED $');
            CALL DIAGNOSE;
        END;

        /* READ RECORDS UNTIL :00XXXX IS ENCOUNTERED */
        DO FOREVER;
            /* SCAN THE : */
            DO WHILE (I := GETCHAR) <> ':';
                /* BUT ABORT IF EOF */
                IF I = EOFILE THEN GO TO FIN;
            END;

            /* SET CHECK SUM TO ZERO, AND SAVE THE RECORD LENGTH */
            CS = 0;
            /* MAY BE THE END OF TAPE */
            IF (RL := READCS) = 0 THEN
                GO TO FIN;
            NB = NB + RL;

            TA, LA = MAKE$DOUBLE(READCS,READCS);
            IF SA = 0 THEN SA = LA;

            /* READ THE RECORD TYPE (NOT CURRENTLY USED) */
            RT = READCS;

            /* PROCESS EACH BYTE */
            DO WHILE (RL := RL - 1) <> 255;
                CALL SETMEM(READCS); LA = LA+1;
            END;
            IF LA > FA THEN FA = LA - 1;

            /* NOW READ CHECKSUM AND COMPARE */
            IF CS + READBYTE <> 0 THEN DO;
                CALL PRINT(.'CHECK SUM ERROR $');
                CALL DIAGNOSE;
            END;
        END; /* FOREVER */

        FIN:
        /* EMPTY THE BUFFERS */
        TA = LA;
        DO WHILE L < TA;
            CALL SETMEM(0); LA = LA+1;
        END;
        /* PRINT FINAL STATISTICS */
        CALL PRINT(.'FIRST ADDRESS $'); CALL PRINTADDR(SA);
        CALL PRINT(.'LAST  ADDRESS $'); CALL PRINTADDR(FA);
        CALL PRINT(.'BYTES READ    $'); CALL PRINTADDR(NB);
        CALL PRINT(.'RECORDS WRITTEN $'); CALL PRINTHEX(P);
        CALL CRLF;

        END RELOC;

    /* ARRIVE HERE FROM THE SYSTEM MONITOR, READY TO READ THE HEX TAPE */

    /* SET UP STACKPOINTER IN THE LOCAL AREA */
    DECLARE STACK(16) ADDRESS, SP ADDRESS;
    SP = STACKPOINTER; STACKPOINTER = .STACK(LENGTH(STACK));

    SBP = LENGTH(SBUFF);
    /* SET UP THE SOURCE FILE */
    CALL MOVE(FCBA,.SFCB,33);
    CALL MOVE(.('HEX',0),.SFCB(9),4);
    CALL SEARCH(.SFCB);
    IF (RFLAG := DCNT = 255) THEN
        CALL PRINT(.'SOURCE IS READER$');
    ELSE DO;
        CALL PRINT(.'SOURCE IS DISK$');
        CALL OPEN(.SFCB);
        IF DCNT = 255 THEN CALL PRINT(.'-CANNOT OPEN SOURCE$');
    END;
    CALL CRLF;

    CALL MOVE(.'COM',FCBA+9,3);
    /* IF NO SOURCE FILE NAME USE A TEMPORARY ONE */
    IF SFCB(1) = 20H THEN CALL MOVE(.'$$$',FCBA+1,3);

    /* REMOVE ANY EXISTING FILE BY THIS NAME */
    CALL DELETE(FCBA);
    /* THEN OPEN A NEW FILE */
    CALL MAKE(FCBA); CALL OPEN(FCBA);
    IF DCNT = 255 THEN CALL PRINT(.'NO MORE DIRECTORY SPACE$');
    ELSE DO;
        CALL RELOC;
        CALL CLOSE(FCBA);
        IF DCNT = 255 THEN CALL PRINT(.'CANNOT CLOSE FILE$');
    END;
    CALL CRLF;

    /* RESTORE STACKPOINTER FOR RETURN */
    STACKPOINTER = SP;
    RETURN 0;
    END LOADCOM;

EOF