Oakland CPM Archive/oakcpm.iso/sigm/vol159/tincmp86.pgn

Text File | 1985-03-23 | 10.6 KB | 652 lines

 TOP; TINCMP COPYRIGHT (C) 1981 W.A.GALE
 PARAMETER KLF=010; CP/M MODIFICATION AND 8086 RECODING
 PARAMETER KCR=013; BY A. L. BENDER, M. D.
 PARAMETER KEF=026; NEW MODS AND REWORKING COPYRIGHT (C) 1981 A L BENDER, M D
 BYTE AA; WORK
 BYTE BB; WORK BYTE
 BYTE DD; WORK
 BYTE EE; WORK BYTE

 BYTE BF(080); EXPANSION BUFFER
 BYTE BL; BLANK
 BYTE BP; POINTER INTO BF
 BYTE C0; CONSTANT ZERO
 BYTE C1; CONSTANT ONE
 BYTE C2; CONSTANT TWO
 BYTE C3; CONSTANT 3
 BYTE C4; CONSTANT  040
 BYTE C8; CONSTANT 080
 BYTE C9; CONSTANT 9
 BYTE CC; INPUT CHARACTER
 BYTE CX; CONSTANT TEN

 BYTE DG; DIGIT FROM PARAMTER TREATMENT DEFINITION
 BYTE DS(010); DIGIT STACK FOR SUB SD
 BYTE EF; END FILE CHARACTER
 BYTE F1(00128); INPUT BUFFER
 BYTE F2(00128); OUTPUT BUFFER
 BYTE HA; 'A'
 BYTE HF; 'F'
 BYTE LE; END OF LIST
 BYTE LF; LINE FEED CHARACTER
 BYTE LS(09000); LIST OF MACRO DEFINITIONS
 BYTE MF; MACRO REPLACEMENT OPERATOR FLAG
 BYTE ML; MACRO LENGTH
 BYTE MM; MINIMUM MACRO LENGTH

 BYTE ND; NUMBER OF DIGITS USED IN SUB SD FOR NUMBER OUTPUT
 BYTE NL; NEW LINE
 BYTE O1; FETCH CODE
 BYTE O2; INDEX CODE
 BYTE O3; DISPOSE CODE
 BYTE OA; '+' ADD OPERATOR
 BYTE OB; '!' POP STACK OPERATOR
 BYTE OC; 'C' CHARACTER DISPOSE
 BYTE OD; 'V' DIGIT CONVERSION FETCH
 BYTE OE; ESCAPE CHARACTER
 BYTE OG; IGNORE CHARACTER
 BYTE OH; 'H' HEX CONVERSION FETCH
 BYTE OL; 'L' LITERAL FETCH
 BYTE OM; '*' MULTIPLY DISPOSE
 BYTE ON; 'N' NUMERIC LITERAL FETCH

 BYTE OP; 'P' PARAMETER FETCH OR DISPOSE
 BYTE OR; '-' REDUCE (SUBTRACT) DISPOSE
 BYTE OS; 'S' STACK FETCH OR DISPOSE
 BYTE OT; TRACE FLAG TURN ON
 BYTE PP; POINTER INTO IPR
 BYTE RB; BEGIN DEFINITION FLAG
 BYTE RC; (COMMENT) END OF LINE FLAG
 BYTE SF; SUBSTITUTION PARAMETER FLAG
 BYTE SP; STACK POINTER
 BYTE TR; TRUE IF NO TRACE
 BYTE UG; USE IGNORE;  TRUE UNLESS OG IS 'X'

 BYTE UN; NOT X-- FLAG FOR NOT SUPPRESSING NEW LINES ON OUTPUT
 BYTE UO; USE OPERATIONS-- TRUE UNLESS MF IS 'X'
 BYTE UT; USE TRACE  TRACE MODE IS ON
 BYTE ZR; CHARACTER ZERO
 INT I00; CONSTANT ZERO
 INT I01; CONSTANT 1
 INT I09; CONSTANT 9
 INT I10; CONSTANT 10
 INT I16; CONSTANT 16
 INT IAA; WORK
 INT IBB;  WORKING STORAGE
 INT IBC; BUCKET NUMBER
 INT IDP; DEFINITION POINTER WHILE MATCH
 INT IED; POINTS TO END OF DEFINITIONS
 INT III; POINTER TO L WHILE READING
 INT IJJ; POINTER TO L READING CODE
 INT ILM; MAXIMUM LIMIT FOR STORING IN L

 INT ILP(01000); POINTERS TO MACROS
 INT IMP; MACRO POINTER DURING EXPANSION
 INT INM; NUMBER OF MACROS
 INT IPR(010); PARAMETER VALUES
 INT ISS(040);   INT TO HOLD NUMBERS-MAIN STACK
 INT ITU; VALUE OF PARAMETER TO USE
 INT IUU; SYMBOL GENERATOR(UNIQUE)
 INT IXX; WORK
 INT IYY; WORK
 BEGINMAIN(AC,IAV)
 NL=+KCR
 LF=+KLF
 GOSUB CR

 MS 'COPYRIGHT'
 MS ' (C) 1981'
 MS ' W.A.GALE'
 GOSUB CR
 MS '8086 TINC'
 MS 'MP COMPIL'
 MS 'ER CP/M V'
 MS 'ERSION 1.'
 MS '00/TINCMP'
 GOSUB CR
 MS 'COPYRIGHT'
 MS ' (C) 1984'
 MS ' A L BEND'
 MS 'ER, MD   '
 GOSUB CR
MS 'COLLECTED'
MS ' WITH VER'
MS ' 1.3 I/O '
MS 'PACKAGE. '
GOSUB CR
 GOSUB IN
 GOSUB RM
 LOC 00
 WHILE
    READ CC FROM F1
    AA=ER==C0
 ON AA; THAT IS, UNTIL EOF IS REACHED ON INPUT

      IF UG

        WHILE
            BB=CC==NL
            DD=CC==LF
            AA=CC==OG
            EE=BB?DD
            BB=CC==BL
            AA=BB?AA
            AA=EE?AA
        ON AA; IGNORE LEADING CHARACTERS
            GOSUB GC; READ CC FROM F1
        ENDWHILE
      ENDIF
      BP=C1; BUF POINTER
      BF(C0)=CC
      WHILE
        GOSUB GC; READ CC FROM F1
            AA=CC==NL
            IF AA
            GOSUB GC; READ CC FROM F1
            AA=CC==LF
            IF AA
            CC=NL
            ENDIF
            ENDIF
        AA=CC!=NL
        BB=BP!=C8
        AA=AA&BB
      ON AA; WHILE LESS THAN 80 CHAR AND NOT NEWLINE
        BF(BP)=CC; THEN PUT IT IN BUFFER FOR MULT COMP
        BP++

    ENDWHILE
    WHILE
    AA=CC!=NL
    ON AA


        GOSUB GC; READ CC FROM F1
    ENDWHILE; HERE WE ARE DUMPING A LONG INPUT LINE
    BF(BP)=RC
    BP++
    BF(BP)=NL
    LE=BP
    AA=BP<=MM
    IF AA; TOO SHORT TO MATCH
        ML=+000
        GOTO 17
    ELSE
        ML=+001
    ENDIF
    IDP=I00
    PP=C0
    IJJ=I00
    INM=C0
    WHILE
        AA=IDP<!IED; DEF PTR < END OF DEFINITIONS
    ON AA
        BP=C0
        WHILE
            AA=BP<=LE
        ON AA
            AA=LS(IJJ)
            AA=AA==RC
            O3=BF(BP)
            O3=O3==RC
            AA=AA&O3;  CHECK EOL MATCH TARG & TEMPLATE
            IF AA
                GOSUB DM;  DO MACRO EXPANSION
                GOTO 00
            ELSE
            AA=BF(BP)
            BB=LS(IJJ)
            AA=AA==BB
            IF AA
                GOTO 01;  MATCHING
            ELSE
            AA=BB!=SF;  NOT A TEMPLATE PARAMETER FLAG
            IF AA
                GOTO 10;  MISMATCHED
            ELSE;  THIS IS A PARAMETER
                PP++
                AA=BF(BP)
                IAA=AA
                IPR(PP)=IAA
            ENDIF
            ENDIF
            ENDIF
        LOC 01

            BP++
            IJJ++
        ENDWHILE
    LOC 10
        PP=C0
        INM++
        IDP=ILP(INM)
        IJJ=IDP
    ENDWHILE
  LOC 17
    BP=C0
    WHILE
        CC=BF(BP)
        O1=BP+C1
        AA=BF(O1)
        AA=AA!=NL
    ON AA
        IF ML;  THEN ALSO WRITE
            WRITE CC
        ENDIF
        WRITE CC INTO F2
        BP++
    ENDWHILE
    IF ML
        GOSUB CR
    ENDIF
    IF UN;  ONLY IF NOT SUPPRESSING
        WRITE NL INTO F2
        WRITE LF INTO F2
    ENDIF
  ENDWHILE
LOC 88; END OF SATISFACTORY COMPILATION
  MS 'TINCMP CO'
  MS 'MPILATION'
  MS ' FINISHED'
GOSUB CR;
  CLOSE F1
  CLOSE F2
  ENDMAIN
        SUB GC; GETS THE NEXT CHARACTER INTO CC GOES TO 88 ON END
    READ CC FROM F1
    AA=ER!=C0
    IF AA; IF NOT NORMAL READ OPERATION
        GOTO 88; !!!! NOT GOOD PROGRAMMING PRACTICE AT ALL !!!!
    ENDIF
    AA=CC==EF; IF CHARACTER WAS EOF MARK
    IF AA; IN CP/M SYSTEM THIS CAN BE RETURNED TO USER
        GOTO 88; !!!! NOT GOOD PROGRAMMING PRACTICE AT ALL !!!!
    ENDIF
        ENDSUB; GC - GET CHARACTER FROM INPUT FILE
        SUB SD;   CONVERTS TOUSE TO A NUMBER WITHOUT ZRO LEADING
 AA=ITU<!I00
 IF AA
    BB=+001
    ITU=-ITU
 ELSE
    BB=+000
 ENDIF
 AA=ITU==I00
 IF AA
    ND=C1
    DS(C0)=ZR
 ELSE
    ND=C0
    WHILE
        AA=I00<!ITU
    ON AA
        IYY=ITU/I10
        IAA=I10*IYY
        IXX=ITU-IAA
    ITU=IYY
    AA=IXX

    AA=AA+ZR
    DS(ND)=AA
    ND++
    ENDWHILE
 ENDIF
 DS(ND)=OR
 ND=ND+BB;  INCR FOR NEG INTEGER ONLY
 ENDSUB

        SUB WN;   WRITE NUMBER INTO F2

 GOSUB SD;  STACK THE DIGITS
 WHILE;  NOW WRITE THEM OUT FIRST TO LAST
    IAA=ND
    AA=I00<!IAA
 ON AA
    ND--
    AA=DS(ND)
    WRITE AA INTO F2
 ENDWHILE
 ENDSUB

        SUB PN;  WRITE THE NUMBER ON THE TERMINAL

 GOSUB SD;  STACK THE DIGITS
 WHILE
    IAA=ND
    AA=I00<!IAA
 ON AA
    ND--
    AA=DS(ND)
    WRITE AA
 ENDWHILE
 WRITE BL
 ENDSUB

        SUB CD;  CONVERT AA AS A DECIMAL DIGIT

 BB=ZR<=AA
 CC=AA<=C9
 BB=BB&CC
 IF BB

    AA=AA-ZR
    RETURN
 ENDIF
 AA=C0
 ENDSUB

        SUB CH;  CONVERT AA AS HEX DIGIT

 BB=ZR<=AA
 CC=AA<=C9
 BB=BB&CC
 IF BB
    AA=AA-ZR
    RETURN
 ENDIF
 BB=HA<=AA
 CC=AA<=HF
 BB=BB&CC
 IF BB
    AA=AA-HA
    AA=AA+CX

    RETURN
 ENDIF
 AA=C0
 ENDSUB

        SUB IN;  INITIALIZE

 ILM=+08920
 I00=+00000
 I01=+00001
 I10=+00010
 I09=+00009
 C0=+000
 C1=+001
 C2=+002
 C3=+003
 EF=+KEF
 C4=+040
 C8=+080
 I16=+00016
 SP=+000
 C9='9'
 ZR='0'
 BL=' '
 HF='F'
 HA='A'
 CX=+010
 IBC=I01
 TR='R'
 ASSOCIATE FCB 1 WITH IBC
 OPEN F1 FOR TR AT IBC
 TR='W'
 IBC++
 ASSOCIATE FCB 2 WITH IBC
 OPEN F2 FOR TR AT IBC
 READ AA FROM F1;  X SUPPRESSES NEW LINE OUTPUT
 OT='T'
 UT=+000
 BB='X'
 UN=AA!=BB;  UN SAYS CHARACTER WAS NOT X SO DONT SUPPRESS
 READ RB FROM F1
 READ RC FROM F1;  COMMENT AND EOL FLAG
 READ SF FROM F1;  TEMPLATE PARAMETER FLAG
 READ MF FROM F1;  EXPANSION OPERATION FLAG
 BB='X'
 AA=MF==BB
 IF AA
    UO=C0
 ELSE
    UO=C1
 ENDIF
 OP='P'; PARAMETER DESIGNATOR IN OPERATION SEQUENCE
 OE='@'; ESCAPE CHARACTER
 OD='V'; CONVERT PARAMETER TO DIGIT IN ACTION SEQUENCE
 OB='!'; POP STACK DESIGNATOR IN OPERATION SEQUENCE
 OS='S'; STACK DESIGNATOR IN OPERATION SEQUENCE
 OH='H'; HEX CONSTANT FETCH AND WRITE

 ON='N'; LITERAL NUMERIC FETCH
 OL='L'; LITERAL BYTE FETCH
 OC='C'; CHARACTER OUT DESIGNATION
 OA='+'; ADD TO STACK DESIGNATION
 OR='-'; SUBTRACT (REDUCE) FROM STACK
 OM='*'; MULTIPLY STACK BY BASE AND ADD
 READ OG FROM F1; IGNORE CHARACTER
 AA='X'
 BB=AA==OG
 IF BB
    UG=+000
 ELSE
    UG=+001
 ENDIF
 READ CC FROM F1; NEW LINE
 AA=NL!=CC; NL IS NEWLINE
 IF AA
    MS 'FLAG LINE'
    STOP 1
 ENDIF
 IUU=+00100
 ENDSUB; IN
        SUB RM;  READ MACROS
 III=I00
 INM=C0
 MM=+127
 WHILE
    READ CC FROM F1
    AA=ER==C0

 ON AA
    CHOOSE ON CC
    CASE OE;ACCEPT THE NEXT CHARACTER UNCRITICALLY
        READ CC FROM F1
        GOTO 77
    CASE RB;BEGIN A DEFINITION
        ILP(INM)=III
        INM++
        ML=+000

    CASE NL;IGNORE
    CASE LF;IGNORE
    CASE RC;IGNORE FOLLOWING COMMENTS AND MARK LINE END
        LS(III)=RC
        III++
        AA=ML<!MM
        IF AA;THIS LINE IS SHORTEST YET
            MM=ML

        ENDIF
        WHILE
            READ CC FROM F1
            AA=CC!=LF
        ON AA
        ENDWHILE
    CASE OG;IF USING IGNORE, IGNORE
        IF UG
        ELSE
            GOTO 77


        ENDIF
    DEFAULT;
    LOC 77
        LS(III)=CC
        III++
        AA=ILM<!III
        IF AA
            MS 'MACMEMXST'
            GOSUB CR
            CLOSE F1
            STOP 5
        ENDIF
        ML++
    ENDCHOOSE
 ENDWHILE
 AA=CC!=EF
 IF AA
    MS 'DEFN READ'
    STOP 2
 ENDIF
 CLOSE F1
 IBC=+00003
 ASSOCIATE FCB 3 WITH IBC
 TR='R'
 OPEN F1 FOR TR AT IBC
 IED=III;END OF DEFINITIONS
 MS 'LOADED...'
 ITU=III
 GOSUB PN
 MS '.BYTES FO'
 MS 'R DEFINES'
 GOSUB CR
 ILP(INM)=III
 ITU=INM
 GOSUB PN
 MS '.MACROS..'
 ITU=MM
 GOSUB PN
 MS ' MIN LEN.'
 GOSUB CR
 ENDSUB; RM
        SUB CR; DO CARRIAGE RETURN/LINE FEED SEQUENCE
 WRITE NL
 WRITE LF
 ENDSUB; CR

        SUB DM; DO MACRO EXPANSION

 IMP=IJJ+I01
 INM++
 IDP=ILP(INM)
 WHILE
    AA=IMP<!IDP
 ON AA; UNTIL WE HAVE READ UP TO THE NEXT MACRO DEFINITION
    AA=LS(IMP)
    IF UO
        AA=AA==MF
    ELSE
        AA=C0
    ENDIF
    IF AA; OPERATION CODE
        IMP++
        O1=LS(IMP); FROM INDICATOR
        IMP++
        AA=LS(IMP)
        O2=AA
        GOSUB CD; FOR DIGIT CONVERSION
        DG=AA
        IMP++
        O3=LS(IMP); DESTAD
    IF UT
            WRITE O1
            WRITE O2
            WRITE O3
    ENDIF
        CHOOSE ON O1
        CASE OP; FETCH PARAMETER
        ITU=IPR(DG)
        CASE OD; CONVERT FROM DIGIT TO CHARACTER
        IAA=IPR(DG)
        AA=IAA
        GOSUB CD
        ITU=AA
        CASE OB; POP STACK
            ITU=ISS(SP)
            AA=SP<=C0
            IF AA
                MS 'S STACKER'
                GOSUB CR
                SP=C1
            ENDIF
            SP--
        CASE OS; FETCH FROM STACK WITHOUT POPPING IT
            ITU=ISS(SP)
        CASE OH; FETCH AND WRITE HEX CONSTANT BYTE
            AA=O2
            GOSUB CH
            IAA=AA
            IAA=IAA*I16
            AA=O3
            GOSUB CH
            IBB=AA
            ITU=IAA+IBB
            O3=OC
        CASE OL; LITERAL BYTE FETCH
            ITU=O2
        CASE ON; LITERAL DIGIT FETCH
            AA=O2
            GOSUB CD
            ITU=AA
        CASE OT; TURN ON TRACE MODE
            UT=+001
        DEFAULT; FETCH  A UNIQUE NUMBER
            ITU=IUU
            IUU++
        ENDCHOOSE
        IF UT
            III=ITU
            GOSUB PN
            ITU=ISS(SP)
            GOSUB PN
            ITU=SP
            GOSUB PN
            ITU=III
            GOSUB CR
        ENDIF
        CHOOSE ON O3
        CASE OC; CHARACTER OUTPUT
            AA=ITU
            WRITE AA INTO F2
        CASE OS; PUT ON STACK
            SP++
            AA=C4<=SP
            IF AA
                MS 'S OVERFLO'
                GOSUB CR
                SP=C4
            ENDIF
            ISS(SP)=ITU
        CASE OP; PUT INTO PARAMETER LOCATION
            IPR(DG)=ITU
        CASE OA; ADD TO STACK
            IAA=ISS(SP)
            IAA=IAA+ITU
            ISS(SP)=IAA
        CASE OR; REDUCE (SUBTRACT) FROM STACK
            IAA=ISS(SP)
            IAA=IAA-ITU
            ISS(SP)=IAA
        CASE OM; MULTIPLY BY BASE AND ADD
            IAA=ISS(SP)
            IAA=IAA*I10
            IAA=IAA+ITU
            ISS(SP)=IAA
        CASE OH; OUTPUT HIGH BYTE
            UNPACK(ITU,AA,BB)
            WRITE AA INTO F2
        DEFAULT; WRITE OUT AS A DECIMAL NUMBER
            GOSUB WN
        ENDCHOOSE
    ELSE; END OF ACTION SECTION
    AA=LS(IMP)
    IF UN
        BB=AA!=RC
    ELSE
        BB=C1
    ENDIF
    IF BB
        WRITE AA INTO F2
    ELSE
        WRITE NL INTO F2
        WRITE LF INTO F2
    ENDIF
    ENDIF
    IMP++
 ENDWHILE
 UT=+000
 ENDSUB; DM
 BOTTOM; END OF TINCMP 8086 CP/M COMPILER