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

Text File | 1985-03-23 | 20.7 KB | 1,459 lines

TOP;METATERP 8086 IMPLEMENTATION UNDER CP/M
;PROGRAMMED BY A. L. BENDER, M. D.
PARAMETER KEF=026;CP/M END OF FILE
PARAMETER KHT=009;HORIZONTAL TAB
PARAMETER KQM=039;QUOTE MARK
PARAMETER KEL=013;CARRIAGE RETURN CODE
PARAMETER KNL=010;LINE FEED
;COPYRIGHT (C) W.A.GALE
BYTE AA;ALL LOW DOUBLE LETTERS ARE TEMPORARY VARIABLES
BYTE BB
BYTE BO(080);OUTPUT STRING
BYTE C0;NUMBER 0
BYTE C1;NUMBER 1
BYTE C2;NUMBER 2
BYTE C3;NUMBER 3
BYTE C9;NUMBER 9
BYTE CB;BLANK
BYTE CC
BYTE CD;'.' DOT
BYTE CE;'/' ESCAPE FOR NUMBERS
BYTE CG;'>'
BYTE CL;'<'
BYTE CM;'-'
BYTE CP;'+'
BYTE CQ;'''
BYTE CS;'*'
BYTE CT;HORIZONTAL TAB
BYTE CU;'='
BYTE CV;NUMBER 25
BYTE CX;'!'
BYTE DD
BYTE DS(010);DIGIT STACK FOR WRITING NUMBERS
BYTE EE
BYTE EF;CP/M END OF FILE CODE (CTL-Z)
BYTE EL;CARRIAGE RETURN CODE
BYTE F1(128);INPUT BUFFER
BYTE F2(128);OUTPUT BUFFER
BYTE FL;FLAG FOR TRUE AND FALSE JUMPS
BYTE KA;SPECIAL BYTE FOR TESTS IN KG ROUTINE
BYTE KB;SPECIAL BYTE FOR TESTS IN KG
BYTE KC;WRITE OUTPUT TO CRT TOO
BYTE KS(06000);PROGRAM MEMORY SPACE
BYTE LI;INSTRUCTION LENGTH
BYTE LL;LINE LENGTH DURING LOADING
BYTE MC(03000);SYMBOLIC MEMORY CHARACTER VECTOR
BYTE MK;MEMORY SIZE CELL
BYTE MN;DIMENSIONS OF NS LESS ONE
BYTE ND;NUMBER OF DIGITS FOR WRITING NUMBERS
BYTE NL;NEW LINE !!!! PARAMETERIZED SYSTEM DEPENDENT
BYTE NS(080);CIRCULAR INPUT BUFFER
BYTE OS(080);INPUT STRING
BYTE PB;POINTER INTO BO
BYTE PI;INDEX INTO RI
BYTE PL;POINTER INTO NS
BYTE PM;LOCUS IN NS WHERE INPUT NOT ACCEPTED
BYTE PN;COUNT OF SUBROUTINES LOADED
BYTE PO;POINTER INTO OS
BYTE QI;POINTER INTO RI
BYTE RC;COMMAND READ
BYTE RI(080);INSTRUCTION REGISTER
BYTE SD;STACK DIMENSIONS BOTH Y AND Z
BYTE WA;WORK IN PACK
BYTE WB;WORK IN PACK
BYTE X0;CHARACTER ZERO
BYTE X1; 1
BYTE X2; 2
BYTE X3; 3
BYTE X9; 9
BYTE XA; A
BYTE XB; B
BYTE XC; C
BYTE XD; D
BYTE XE; E
BYTE XF; F
BYTE XG; G
BYTE XH; H
BYTE XI; I
BYTE XJ; J
BYTE XK; K
BYTE XL; L
BYTE XM; M
BYTE XN; N
BYTE XO; O
BYTE XP; P
BYTE XQ; Q
BYTE XR; R
BYTE XS; S
BYTE XT; T
BYTE XU; U
BYTE XV; V
BYTE XW; W
BYTE XX; X
BYTE XY; Y
BYTE XZ; Z
BYTE YP;STACK POINTER
BYTE ZP;STACK POINTER
BYTE ZX;STORAGE FOR ERROR RECOVERY SYMBOL
;
;INTEGER STORAGE
;
INT I00;NUMBER 000
INT I01;NUMBER 001
INT I03;NUMBER 003
INT I10;NUMBER 10
INT I16;NUMBER 16
INT IAA;WORKING STORAGE
INT IBB;WORKING STORAGE
INT IBK;BLOCK NUMBER (FILE NUMBER)
INT ICC;WORKING STORAGE
INT IDD;WORKING STORAGE
INT ILB;POINTER INTO ILT
INT ILN;LINE NUMBER OF INPUT
INT ILT(01000);LOCATION TABLE FOR NUMBER LABELS
INT IMB;MEMORY BASE INDEX FOR CURRENT LEVEL
INT IMD;DIMENSION OF MC AND IMI
INT IMF;MEMORY FREE INDEX
INT IMI(03000);SYMBOLIC MEMORY INDEX VECTOR
INT IML;NUMBER OF LOCAL PARAMETERS PER MEMORY LEVEL
INT IMM;MAX MEMORY COUNTER
INT IMT;TOP OF FREE MEMORY, REST TAKEN BY CELL STACK
INT IMX;NULL MEMORY INDEX
INT IMZ;TEMP VBL FOR MEM SRCH
INT INL;NUMBER OF NUMERICAL LABELS
INT IPC;PROGRAM COUNTER INDEX TO CURRENT INSTRUCTION
INT IPL;CODE POINTER WHILE LOADING
INT IPR(010);REGISTER VECTOR
INT IPT;POINTER INTO IST SUBROO STACK
INT IRN;NUMBER RETURNED BY READ NUMBER ROUTINE
INT ISM;SYMBOL NUMBER OF INPUT
INT IST(00600);SUBROUTINE AND LABEL STACK
INT ITU;RESULT OF DIRECT FETCH
INT IUU;UNIQUE SYMBOL GENERATOR
INT IXX;WORK DURING NUMBER MANIP
INT IYS(080);Y STACK
INT IYY;WORK DURING NUMBER MANIP
INT IZC;ERROR PROGRAM COUNTER
INT IZS(080);Z STACK
INT IZT;ERROR STACK POINTER
BEGINMAIN(AC,IAV)
EL=+KEL
NL=+KNL
MS 'METATERP '
MS 'Ver 1.2  '
GOSUB CR
MS '8086 VERS'
MS 'ION FOR C'
MS 'P/M-86   '
GOSUB CR
MS 'COPYRIGHT'
MS ' 1984 A. '
MS 'L. BENDER'
MS ', M. D.  '
GOSUB IN; INITIALIZATION
GOSUB CR; DON'T DO UNTIL IN HAS EXECUTED
GOSUB RC; READ COMMANDS
GOSUB LI;LEXICAL INITIALIZATION
IPC=+00000
LOC 00
GOSUB GI
CC=RI(C0)
CHOOSE ON CC
CASE XL;LEXICAL ANALYSIS COMMANDS
    AA=PI==C1
    IF AA
        IF FL
            GOSUB LW;SEEK WHITE SPACE MOVE UP BASE
            ISM++;    INCREMENT SYMBOL COUNT
        ELSE
            PL=PM;RESET LOOK AHEAD POINTER
        ENDIF
    ELSE;LONGER THAN ONE
    CC=RI(C1)
    CHOOSE ON CC
    CASE XM;MATCH SPECIFIC STRING
        FL=+000
        BB=+002
        WHILE
            AA=BB<!PI
        ON AA
            AA=RI(BB)
            DD=NS(PL)
            AA=AA!=DD
            IF AA
                GOTO 99;NO MATCH
            ENDIF
            BB++
            GOSUB LA
        ENDWHILE
        FL=+001
        GOSUB LB
    CASE XI;ID TEST
        FL=+000
        CC=NS(PL)
        PO=+000
        GOSUB ZA
        WHILE
        ON AA;
            OS(PO)=CC
            PO++
            GOSUB LA
            CC=NS(PL)
            GOSUB ZA
            DD=AA
            GOSUB ZN
            AA=DD?AA
        ENDWHILE
        AA=PO==C0
        IF AA
            GOTO 99
        ENDIF
        GOSUB MS;SEARCH ALL LEVELS
        IPR(C0)=IAA
        FL=+001
    CASE XN;    POSITIVE INTEGER TEST
;            ---------------------
        FL=+000
    IAA=I00
    WHILE
        CC=NS(PL)
        GOSUB ZN
    ON AA
        FL=+001
        IAA=IAA*I10
        CC=CC-X0
        IBB=CC
        IAA=IAA+IBB
        GOSUB LA
    ENDWHILE
    IPR(C0)=IAA
    CASE XH;    HEXADECIMAL NUMBER TEST
;            -----------------------
    FL=+000
    IAA=+00000
    WHILE
        CC=NS(PL)
        GOSUB ZH
    ON AA
        FL=+001
        IAA=IAA*I16
        IBB=CC
        IAA=IAA+IBB
        GOSUB LA
    ENDWHILE
    IPR(C0)=IAA
    CASE XQ;    STRING QUOTED BY
;            ----------------
        DD=RI(C2)
            CC=NS(PL)
            PO=+000
            AA=CC==DD
            IF AA
                GOSUB LA
                WHILE
                    CC=NS(PL)
                    AA=CC!=NL
                    BB=CC!=DD
                    AA=AA&BB
                ON AA
                    OS(PO)=CC
                    PO++
                    GOSUB LA
                ENDWHILE
                GOSUB LA
                AA=CC==NL
                IF AA
                    ILN++
                    ISM=I00
                ENDIF
                FL=+001
            ELSE
                FL=+000
            ENDIF
    DEFAULT;
        WRITE CC
        MS ' NOT LEX!'
        GOSUB CR
    ENDCHOOSE
    ENDIF; TWO LETTER COMMANDS
CASE XF;    FALSE JUMP
    IF FL
    ELSE
        GOTO 20
    ENDIF
CASE XP;    PRINT STRING GIVEN
    BB=+001
    WHILE
        AA=BB<!PI
    ON AA
        CC=RI(BB)
        BO(PB)=CC
        PB++
        BB++
    ENDWHILE
CASE XO;    OUT
    BB=+000
    WHILE
        AA=BB<!PB
    ON AA
        CC=BO(BB)
        BB++
        WRITE CC INTO F2
    ENDWHILE
    PB=+000

    AA=PI==C1
    IF AA
        WRITE EL INTO F2
        WRITE NL INTO F2
    ENDIF
CASE XX;    ERROR JUMP
    AA=PI==C1
    IF AA;JUST AN X
        IF FL
        ELSE
    LOC 98;
        MS 'ERROR AT '
        MS 'LINE NUM '
        IAA=ILN
        GOSUB PN
        MS ' SYMBOL  '
        IAA=ISM
        GOSUB PN
        WRITE CB
        GOSUB CR
        WHILE
            CC=NS(PL)
            AA=CC!=ZX;COMPARE TO SPECIAL CHARACTER
            BB=CC!=C0;AND EOF SIGNAL (CC=0)
            AA=AA&BB
        ON AA
            AA=CC==NL
            IF AA
                ILN++
                ISM=+00000
            ENDIF
            GOSUB LA;READ ONE MORE
            GOSUB LB;AND BRING UP REAR
        ENDWHILE;HAVE JUST READ SPECIAL CHARACTER
        BB=CC==C0
        IF BB;OR EOF CHARACTER
            MS 'END FILE '
            GOTO 21
        ENDIF
        GOSUB LA;NOW MOVE BEYOND ZX
        GOSUB LB
        GOSUB LW;EAT UP WHITE SPACE
        IPC=IZC;RESTORE PROGRAM COUNTER
        IPT=IZT;AND STACK POINTER
        FL=+001;TRUE
        ENDIF
    ELSE;A LONGER COMMAND
    CC=RI(C1)
    CHOOSE ON CC
    CASE XN;    WRITE LINE NUMBER INTO OUTBUF
        IAA=ILN
        GOSUB WN
    CASE XO;    WRITE OUTBUF TO ERROR OUTPUT
        BB=+000
        WHILE
            AA=BB<!PB
        ON AA
            CC=BO(BB)
            BB++
            WRITE CC
        ENDWHILE
        GOSUB CR
        PB=+000
    CASE XM;    MARK FOR ERROR RETURN
        IZC=IPC;SAVE CODE POSITION
        IZT=IPT;SAVE STACK POSITION
        ZX=RI(C2);AND SPECIAL CHARACTER TO READ THRU
    DEFAULT
    ENDCHOOSE
    ENDIF; X + LETTER
CASE XT;        TRUE JUMP
    IF FL
        GOTO 20
    ENDIF
CASE XG;        GOSUB LABEL MUST BE ALPHA
    WA=RI(C1)
    WB=RI(C2)
    IPT=IPT+I03
    IAA=+00597;STACK DEPTH-3
    AA=IAA<=IPT
    IF AA
        MS 'STACK OVE'
        MS 'R FLOW>>>'
        GOTO 98
    ENDIF
    IST(IPT)=IPC
    PACK(IPC,WA,WB)
    IAA=IPT
    IAA++
    IST(IAA)=I00
    IAA++
    IST(IAA)=I00
CASE XR;        RETURN
    IPC=IST(IPT)
    AA=IPT<!I03
    IF AA
        MS 'STACK UND'
        MS 'ERFLOW...'
        GOTO 98
    ENDIF
    IPT=IPT-I03
CASE XS;        SET
    AA=PI==C1
    IF AA

        FL=+001
    ELSE
        CC=RI(C1)
        CHOOSE ON CC
        CASE XF;    SET FALSE
            FL=+000
        CASE XC;    SET CHANGED
            FL=C1-FL
        DEFAULT;    SET ERROR
            MS 'SET ERROR'
            GOSUB CR
        ENDCHOOSE
    ENDIF
CASE XU;        UNIQUE NUMBER GENERATED AND STACKED
AA=PI==C1
IF AA;    THEN DO A LOT OF WORK
    IAA=IPT
    IAA++
LOC 10
    IBB=IST(IAA); CURRENT UNIQUE
    AA=IBB<!I01;    IE NEVER FILLED IN (YET)
    IF AA
        IUU++
        IBB=IUU
        IST(IAA)=IUU
    ENDIF
    IAA=IBB
    IPR(C0)=IAA
    GOSUB WN;    WRITE NUMBER INTO BUFFER
ELSE;    THIS IS A FETCH FROM U
    GOTO 22
ENDIF

CASE XC;        COPY INPUT

    BB=+000
    WHILE
        AA=BB<!PO
    ON AA
        CC=OS(BB)
        BO(PB)=CC
        PB++
        BB++
    ENDWHILE

CASE XV;        UNIQUE NUMBER 2

AA=PI==C1
IF AA;    THEN THIS IS TO GENERATE A NUMBER
    IAA=IPT
    IAA++
    IAA++
    GOTO 10;    IAA=>SECOND UNIQUE
ELSE;    JUST A FETCH...
    GOTO 22
ENDIF

CASE XM;        MEMORY OPERATIONS

    CC=RI(C1)
    CHOOSE ON CC

    CASE XS;    STACK MEMORY
        GOSUB MH
    CASE XP;    POP MEMORY
        GOSUB MP
    CASE XE;    DEFINE A CELL ON TOP
        GOSUB ME
        IPR(C0)=IAA
    CASE XQ;    QUERY
        GOSUB MS
        IPR(C0)=IAA
    CASE XC;    CREATE CELL
        GOSUB MC
        IPR(C0)=IAA
    CASE XD;    DESTROY CELL
        GOSUB MD
        IPR(C0)=IAA
    CASE XI;    INITIALIZE
        CC=RI(C2)
        GOSUB ZN
        IF AA
            MK=CC-X0
        ELSE
            MK=+002
        ENDIF
        GOSUB MI
    DEFAULT
        MS 'ILLEGAL M'
        MS 'EM OPN>>>'
        GOSUB CR
    ENDCHOOSE
CASE XJ;        JUMP UNCONDITIONAL - LABEL MUST BE NUMBER
LOC 20
    AA=RI(C1)
    BB=RI(C2)
    PACK(ILB,AA,BB)
    IPC=ILT(ILB)
CASE XE;        STOP HERE
LOC 21
    CLOSE F1
    CLOSE F2
    IAA=IMM;    MAXIMUM MEMORY USED
    GOSUB PN;    PRINT MAX MEMORY USAGE
    MS ' MAX MEM '
    MS 'USAGE.   '
    GOSUB CR
    MS 'PROGRAMME'
    MS 'D TERMINA'
    MS 'TION     '
    GOSUB CR
    STOP 0
DEFAULT;        LOOK FOR FETCH AND STORE INSTRUCTION
LOC 22
    QI=+000
    GOSUB FT
    GOSUB FI
    GOSUB ST
ENDCHOOSE
GOTO 00
LOC 99
    FL=+000
    GOTO 00
ENDMAIN

        SUB CK;        CHECK OPENED
AA=ER!=C0
IF AA
    MS 'CANT OPEN'
    IAA=IBK
    GOSUB PN
    GOSUB CR
    STOP 1
ENDIF
ENDSUB

        SUB CR;        CR/LF SUBROUTINE

WRITE EL
WRITE NL
ENDSUB

        SUB DS;        DIGIT STACK
AA=IAA<!I00
IF AA
    BB=+001
    IAA=-IAA
ELSE
    BB=+000
ENDIF
AA=IAA==I00
IF AA
    ND=C1
    DS(C0)=X0
ELSE
    ND=C0
    WHILE
        AA=I00<!IAA
    ON AA
        IYY=IAA/I10
        IBB=I10*IYY
        IXX=IAA-IBB
        IAA=IYY
        AA=IXX
        AA=AA+X0
        DS(ND)=AA
        ND++
    ENDWHILE
ENDIF
DS(ND)=CM;'-'
ND=ND+BB;    INCR ONLY IF MINUS
ENDSUB

        SUB FI;        FETCH INDIRECT
QI++
CC=RI(QI)
CHOOSE ON CC

CASE XM;    MEMORY FETCH
    QI++
    CC=RI(QI)
    GOSUB ZN
    IF AA
        BB=CC-X0
    ELSE
    LOC 11
    MS 'INDEX TO '
    MS 'MEM CELL '
    BB=+000
    ENDIF
AA=BB<!MK
IF AA
    IAA=BB
    IAA=IAA+ITU
    ITU=IMI(IAA)
    RETURN
ELSE
    BB=BB-MK
    AA=BB<!MK
    IF AA
        IAA=BB
        IAA=ITU+IAA
        AA=MC(IAA)
        ITU=AA
    ELSE
        GOTO 11
    ENDIF
ENDIF

CASE XS;        FETCH FROM STRING REGISTER

    AA=ITU
    BB=OS(AA)
    ITU=BB
DEFAULT
    QI--
ENDCHOOSE
ENDSUB
            SUB FT; FETCHES DIRECT
CC=RI(QI)
CHOOSE ON CC
CASE XY;        Y STACK
    ITU=IYS(YP)
CASE CX;        '!' POP Y STACK
    ITU=IYS(YP)
    GOSUB PY
CASE XZ;        Z STACK ALWAYS POP
    ITU=IZS(ZP)
    AA=ZP==C0
    IF AA
        MS 'Z STACKER'
        GOSUB CR
        ZP=+001
        FL=+000
    ENDIF
    ZP--
CASE XN;        LITERAL FETCH OF NUMBER
    QI++
    AA=RI(QI)
    QI++
    BB=RI(QI)
    PACK(ITU,AA,BB)
CASE XH;        FETCH HIGH OF STACK
    ITU=IYS(YP)
    UNPACK(ITU,AA,BB)
    ITU=AA
CASE XB;        FETCH BREDTH OF STRING
    ITU=PO
CASE XU;        FIRST STACK NUMBER
    IAA=IPT
LOC 38
    IAA++
    ITU=IST(IAA)
CASE XV;        SECOND STACK NUMBER
    IAA=IPT
    IAA++
    GOTO 38
DEFAULT;        NUMBER OR ERROR

    GOSUB ZN
    IF AA
        AA=CC-X0
    ELSE
        MS 'ILLEGAL F'
        MS 'ETCH OPN '
        GOSUB CR
        AA=+000
    ENDIF
    ITU=IPR(AA)
ENDCHOOSE
ENDSUB;    FT


            SUB GI;        GET INSTRUCTION
PI=+000
LI=KS(IPC)
IPC++
WHILE
    AA=PI<!LI
ON AA
    AA=KS(IPC)
    IPC++
    RI(PI)=AA
    PI++
ENDWHILE
ENDSUB;    GI

            SUB IN;        INITIALIZATION
KB=+000
KC=+000
ZX=+000
YP=+000
ZP=+000
C0=+000
FL=+000
PI=+000
PB=+000
PO=+000
PN=+000
IZC=+00000
IZT=+00000
I00=+00000
IPC=+00000
IPT=+00000
ILB=+00000
IUU=+00000
ISM=+00000
INL=+00000
C1=+001
C2=+002
MK=+002
I01=+00001
ILN=+00001
C3=+003
I03=+00003
C9=+009
CV=+025
EL=+KEL
NL=+KNL
EF=+KEF
I10=+00010
I16=+00016
SD=+080
MN=+079
XA='A'
XB='B'
XC='C'
XD='D'
XE='E'
XF='F'
XG='G'
XH='H'
XI='I'
XJ='J'
XK='K'
XL='L'
XM='M'
XN='N'
XO='O'
XP='P'
XQ='Q'
XR='R'
XS='S'
XT='T'
XU='U'
XV='V'
XW='W'
XX='X'
XY='Y'
XZ='Z'
X0='0'
X1='1'
X2='2'
X3='3'
X9='9'
CB=' '
CX='!'
CS='*'
CM='-'
CP='+'
CG='>'
CU='='
CL='<'
CT=+KHT;HORIZONTAL TAB
CE='/'
CD='.'
CQ=+KQM;QUOTE MARK
IBK=+00003;FILE 3
ASSOCIATE FCB 3 WITH IBK; ***CP/M DEPENDENT***
OPEN F2 FOR XW AT IBK;    OPEN OUTPUT FILE
GOSUB MI;    INITIALIZE MEMORY
ENDSUB;    IN
            SUB LA; L IS FOR LEX, A IS FOR AHEAD
AA=PL==MN;MAX FOR NS
IF AA
    PL=+000
ELSE
    PL++
ENDIF
ENDSUB;    LA
            SUB LB; MOVE UP THE BASE
WHILE
    AA=PL!=PM
ON AA
    GOSUB KG;READ CC FROM F1
    AA=ER!=C0
    IF AA
        CC=+000
    ENDIF
    NS(PM)=CC
    AA=PM==MN
    IF AA
        PM=+000
    ELSE
        PM++
    ENDIF
ENDWHILE
ENDSUB; LB
            SUB LI; INITIALIZE LEX
PM=+000
PL=+000
BB=+000
WHILE

    AA=BB<=MN
    CC=ER==C0
    AA=AA&CC
ON AA
    GOSUB KG;READ CC FROM F1; - SPECIAL READ FOR CP/M
    NS(BB)=CC
    BB++
ENDWHILE
ENDSUB; LI
            SUB LW; TEST AND  DISCARD WHITE SPACE
CC=NS(PL)
WHILE
    AA=CC==NL
    IF AA
        ILN++
        ISM=+00000
    ENDIF
    BB=CC==CB
    AA=AA?BB
    BB=CC==CT
    AA=AA?BB
    BB=CC==EL
    AA=BB?AA
ON AA
    GOSUB LA
    CC=NS(PL)
ENDWHILE
GOSUB LB
ENDSUB; LW
            SUB MC; CREATE CELL AT THTE TOP
IAA=MK
IMT=IMT-IAA
GOSUB MO;CHECK FOR OVERFLOW
IAA=IMT;POINT TO CELL
GOSUB MZ;ZERO IT
ENDSUB; MC
            SUB MD; DESTROY CELL
IAA=MK
IMT=IMT+IAA;RAISE TOP BY CELL SIZE
AA=IMD<!IMT
IF AA
    MS 'DESTROY C'
    MS 'ELL ERROR'
    GOSUB CR
ENDIF
IAA=IMT
ENDSUB; MD
            SUB ME; ENTER INTO TOP LEVEL
;RETURNS IAA AS INDEX TO CELL
GOSUB ML;    SEARCH TOP LEVEL
EE=IAA!=I00;    FOUND IT HERE
IF EE
    RETURN
ENDIF
IMI(IBB)=IMF;    IBB FROM ML, STORE TO SHOW THIS OPTION
WHILE
    MC(IMF)=CC; CC FROM ML ONCE
    IMI(IMF)=IMX; NO ALTERNATIVES NOW
    IMF++
    GOSUB MO;    CHECK OVERFLOW
    AA=CC!=C0;    NOT LAST CHARACTER
ON AA
    BB++;    BB FROM ML TO START
    CC=OS(BB)
ENDWHILE
IAA=IMF
IDD=MK
IMF=IDD+IMF
GOSUB MO
GOSUB MZ
ENDSUB; ME
            SUB MH; PUSH A NEW LEVEL
IMI(IMF)=IMB;    POINT TO CURRENT BASE
IMB=IMF
IMF=IMF+IML
MC(IMF)=C0
IMI(IMF)=I00
ENDSUB; MH
            SUB MI; MEMORY INITIALIZE
IMB=+00000
IMM=+00000
IMD=+03000; DIMENSION OF MC AND IMI
IMT=IMD
IML=+00001
IMF=IMB+IML
IMX=+00000
IMI(IMB)=I00
MC(IMF)=C0
IMI(IMF)=I00
ENDSUB; MI
            SUB ML; LEVEL SEARCH PATTERN ENDS WITH NULL
IBB=IMB+IML;        FIRST CHAR IN MEMORY
BB=+000;        SUBSCRIPT FOR PATTERN
WHILE
    CC=OS(BB);    PATTERN CHARACTER
    DD=MC(IBB);    MEMORY CHARACTER
    EE=CC==DD;    MATCH
    IF EE;        MATCHING?
        EE=CC==C0;    END OF STRING SIGNAL
        IF EE;        ENTIRE MATCH?
        IAA=IBB+I01;
        GOTO 77
        ENDIF
        IBB++
        BB++
    ELSE;        FAILED
        IAA=IMI(IBB)
        EE=IAA==IMX
        IF EE;    END OF THE ROAD
            IAA=+00000
            GOTO 77
        ENDIF
        IBB=IAA
    ENDIF
    EE=IBB<!IMF
ON EE
ENDWHILE
IAA=+00000;    FAILED TO FIND BELOW FREE MARKER
LOC 77
ENDSUB; ML
            SUB MO;    CHECK FOR MEMORY OVERFLOW
AA=IMT<!IMF
IF AA
    MS 'OUT OF ME'
    MS 'MORY ERR.'
    STOP 3
ENDIF
AA=IMM<!IMF
IF AA
    IMM=IMF;    MAXIMUM MEMORY IN USE
ENDIF
ENDSUB; MO
            SUB MP; POP A LEVEL
AA=IMB!=I00
IF AA
    IMF=IMB
    IMB=IMI(IMB)
ELSE
    IMF=IML
    MC(IMF)=C0
    IMI(IMF)=I00
ENDIF
ENDSUB; MP
            SUB MS; SEARCH ALL LEVELS
OS(PO)=C0

IMZ=IMB
WHILE
    GOSUB ML
    EE=IAA==I00
    IMB=IMI(IMB)
    DD=IMB!=I00
    CC=EE&DD
ON CC
ENDWHILE
IMB=IMZ; TO TOP LEVEL
ENDSUB; MS
            SUB MZ; ZERO A MEMORY CELL
BB=+000
IDD=IAA;    RETAIN POINTER TO CELL
WHILE
    AA=BB<!MK
    BB++
ON AA
    MC(IDD)=C0
    IMI(IDD)=I00
    IDD++
ENDWHILE
ENDSUB; MZ
            SUB PN; PRINT NUMBER ON THE TERMINAL
GOSUB DS;    STACK THE DIGITS
WHILE
    IBB=ND
    AA=I00<!IBB
ON AA
    ND--
    AA=DS(ND)
    WRITE AA
ENDWHILE
WRITE CB
ENDSUB; PN
            SUB PY; POP Y STACK
AA=YP==C0
IF AA
    MS 'Y STACKER'
    GOSUB CR
    YP=C1
    FL=+000
ENDIF
YP--
ENDSUB; PY
            SUB RA; READ ALPHA LABEL
;FIRST COPY LABEL TO STRING INDEX
OS(C0)=CC
PO=+001
WHILE
    GOSUB KG;READ CC FROM F1
    GOSUB ZA
    DD=AA;SAVE THE RESULT
GOSUB ZN;ALLOW EITHER ALPHA OR NUMERIC AFTER FIRST ALPHA
    AA=AA?DD
ON AA

    OS(PO)=CC
    PO++
ENDWHILE
;NOW, EAT UP LINE
AA=CC==NL
IF AA
ELSE
    WHILE
        GOSUB KG;READ CC FROM F1
        AA=CC!=NL
    ON AA
    ENDWHILE
ENDIF
ENDSUB;    RA

        SUB RC; READ COMMANDS
CLOSE F1
IBK=+00001;    FILE #1 IN TBUFF
ASSOCIATE FCB 1 WITH IBK;    *** CPM SENSITIVE ***
OPEN F1 FOR XR AT IBK;    BUFFER1/FILE1/READ
GOSUB CK;    DID FILE OPEN OK
IPC=+00001
LL=+000
IPL=+00000
WHILE
AA=AA; DUMMY TO FIX LABELING ERROR IN MACRO GENERATOR
LOC 67;
    READ RC FROM F1
    AA=RC==EL;
    IF AA
        GOTO 67
    ENDIF
LOC 33
    AA=ER==C0
ON AA
    CHOOSE ON RC
    CASE CE; '/' NUMBER FOLLOWS
        GOSUB KG;READ CC FROM F1
        AA=CC==CM;'-'
        IF AA; MINUS SIGN
            GOSUB KG;READ CC FROM F1
            GOSUB RN;READ NUMBER
            IRN=-IRN;INVERT IT
            GOTO 37
        ENDIF
        GOSUB ZN
        IF AA
            GOSUB RN;READ NUMBER
        LOC 37;
            UNPACK(IRN,AA,BB)
            KS(IPC)=AA
            IPC++
            LL++
            KS(IPC)=BB
            IPC++
            LL++
            RC=CC
            AA=RC==CB
            IF AA
            ELSE
                GOTO 33
            ENDIF
        ELSE
            KS(IPC)=CE
            IPC++
            LL++
            RC=CC
            GOTO 33
        ENDIF
    CASE NL;    END OF COMMAND
        KS(IPL)=LL; PUT THE LENGTH OF THE INSTRUCTION AT THE FRONT!
        IPL=IPC
        IPC++
        LL=+000
    CASE CD;    '.' LABEL FOLLOWS
        AA=LL==C0
        IF AA
            GOSUB RL
            RC=NL
            IPC--
            GOTO 33
        ELSE
            GOTO 35
        ENDIF
    CASE XG;    IF AT BEGINNING, A GOSUB TO COMPILE
        AA=LL==C0
        IF AA
            GOSUB KG;READ CC FROM F1
            GOSUB RA;    READ ALPHA LABEL
            OS(PO)=C0
            GOSUB ME;    FIND OR DEFINE
            IRN=IMI(IAA);    DEFINED VALUE
            AA=IRN==I00
            IF AA
                IRN=IAA;    NOT YET DEFINED
                KS(IPC)=NL;    SET WARNING
            ELSE
                KS(IPC)=RC;    WAS DEFINED, VALUE FILLED
            ENDIF
            IPC++
            UNPACK(IRN,AA,BB)
            KS(IPC)=AA
            IPC++
            KS(IPC)=BB
            IPC++
            LL=C3
            RC=NL
            GOTO 33
            ELSE
            GOTO 35
            ENDIF
        CASE EL; THIS IS TO THROW AWAY THE 0DH CODE BEFORE LF
        ;DO NOTHING
        DEFAULT;    ACCEPT
        LOC 35
        KS(IPC)=RC
        IPC++
        LL++
        ENDCHOOSE
    ENDWHILE
;HAVE REACHED END
IPC--

AA=ER!=C1
IF AA;NO, AN ERROR
    MS 'CANT READ'
    MS ' COMMANDS'
    GOSUB CR
    STOP 1
ENDIF
CLOSE F1
IBK=+00002
ASSOCIATE FCB 2 WITH IBK
OPEN F1 FOR XR AT IBK
GOSUB CK
;PATCH ALL THE UNDEFINED GOSUBS
IAA=+00000
WHILE
    AA=IAA<!IPC
ON AA
    LL=KS(IAA)
    IBB=IAA+I01
    AA=KS(IBB);THE COMMAND
    AA=AA==NL
    IF AA;A GOSUB NEEDING PATCH
        KS(IBB)=XG
        IBB++
        AA=KS(IBB);GET INDEX TO DEFINE
        IBB++
        BB=KS(IBB)
        PACK(IRN,AA,BB)
        BB=MC(IRN)
        AA=BB!=C1
        IF AA;THE SUB WASN'T DEFINED, WE DON'T KNOW NAME
            ICC=IRN-I10
            WHILE
                AA=ICC<!IRN
            ON AA
                BB=MC(ICC)
                WRITE BB
                ICC++
            ENDWHILE
            WRITE CB
            MS 'SUB UNDEF'
            GOSUB CR
        ENDIF
        ICC=IMI(IRN)
        UNPACK(ICC,AA,BB);ICC=REAL LOC OF SUB
        KS(IBB)=BB;STORE IT
        IBB--
        KS(IBB)=AA
    ENDIF
    IBB=LL
    IAA=IAA+IBB
    IAA=IAA+I01
ENDWHILE
GOSUB MP;POP MEMORY, FORGET NAMES
IAA=IPC
GOSUB PN
MS 'CMD BYTS '
IAA=INL
GOSUB PN
MS 'NUM LABS '
IAA=PN
GOSUB PN
MS 'SUBROUTIN'
GOSUB CR
ENDSUB;    RC
        SUB RL;    READ LABEL
;FIRST DISCARD ANY ALPHANUMERICS
WHILE
    GOSUB KG;READ CC FROM F1
    GOSUB ZA
    IF AA
        GOTO 80;ALPHA LABEL
    ENDIF
    GOSUB ZN
    IF AA
        GOTO 85;NUMBER LABEL
    ENDIF
    AA=CC!=NL;IF NO LABEL, NO ACTION
ON AA
ENDWHILE
RETURN
LOC 80;ALPHA LABEL
GOSUB RA;READ ALPHA LABEL
OS(PO)=C0
GOSUB ME; SEARCH MEMORY
IMI(IAA)=IPL;SAVE VALUE
MC(IAA)=C1;MARK DEFINED
PN++;COUNT SUBROUTINES
RETURN
LOC 85;NUMBER LABEL
INL++
GOSUB RN;READ A NUMBER
ILT(IRN)=IPL
ENDSUB;    RL
            SUB RN;READ A NUMBER
IRN=+00000
WHILE
    CC=CC-X0
    IAA=CC
    IRN=IRN*I10;    CONVERT TO BINARY
    IRN=IRN+IAA
    GOSUB KG;READ CC FROM F1
    GOSUB ZN
ON AA
ENDWHILE
ENDSUB;    RN
            SUB ST; STORE A NUMBER
QI++
CC=RI(QI)
CHOOSE ON CC
CASE XY;    Y STACK
    YP++
    AA=SD<=YP
    IF AA
        MS 'Y OVERFLW'
        GOSUB CR
        YP=SD
        FL=+000
    ENDIF
    IYS(YP)=ITU
CASE XZ;    Z STACK
    ZP++
    AA=SD<=ZP
    IF AA
        MS 'Z OVERFLW'
        GOSUB CR
        ZP=SD
        FL=+000
    ENDIF
    IZS(ZP)=ITU
CASE CP;    "+" ADD TO S
    IAA=IYS(YP)
    IAA=IAA+ITU
    IYS(YP)=IAA
CASE CM;    "-" SUBTRACT FROM TOP OF STACK
    IAA=IYS(YP)
    IAA=IAA-ITU
    IYS(YP)=IAA
CASE CS;    "*" MULTIPLY TOP OF STACK BY TO USE
    IAA=IYS(YP)
    IAA=IAA*ITU
    IYS(YP)=IAA
CASE CG;    ">" GREATER - SET FLAGS ACCORDINGLY
    IAA=IYS(YP)
    AA=IAA<!ITU
LOC 12;
    IF AA
        FL=+001;    T R U E
    ELSE
        FL=+000;    F A L S E
    ENDIF
    GOSUB PY;    POP Y STACK
CASE CL;    "<" LESS THAN - SET FLAGS
    IAA=IYS(YP)
    AA=ITU<!IAA
    GOTO 12
CASE CU;    "=" EQUAL
    IAA=IYS(YP)
    AA=ITU==IAA
    GOTO 12
CASE XI;    INDIRECT TO MEMORY
    QI++
    DD=RI(QI)
    IBB=ITU
    QI++
    GOSUB FT
    CC=DD
    GOSUB ZN
    IF AA
        BB=CC-X0;    REMOVE ASCII BIAS
    ELSE
    LOC 13;
        MS 'BAD INDIR'
        MS 'ECT INDEX'
        GOSUB CR
        BB=+000
    ENDIF
    AA=BB<!MK
    IF AA
        IAA=BB
        IAA=ITU+IAA
        IMI(IAA)=IBB
        RETURN
    ELSE
        BB=BB-MK
        AA=BB<!MK
        IF AA
            IAA=BB
            IAA=IAA+ITU
            AA=IBB
            MC(IAA)=AA
        ELSE
            GOTO 13
        ENDIF
    ENDIF
CASE XC;    CONVERT NUMERIC TO STRING, WRITE IT OUT
    IAA=ITU
    GOSUB WN
CASE XL;    WRITE LOW BYTE OF FETCHED TO OUTPUT BUFFER
    AA=ITU
    BO(PB)=AA
    PB++
CASE XA;    APPEND LOW BYTE OF FETCHED TO STRING BUFFER
    AA=ITU
    OS(PO)=AA
    PO++
    OS(PO)=C0
CASE XB;    SET LENGTH OF STRING BUFFER
    PO=ITU
    OS(PO)=C0
CASE XG;    SET GENERATOR
    IUU=ITU
CASE XU;    FIRST STACK NUMBER
    IAA=IPT
LOC 39;
    IAA++
    IST(IAA)=ITU
CASE XV;    SECOND STACK NUMBER
    IAA=IPT
    IAA++
    GOTO 39
CASE XD;    DUMP IT, NULL OPERATION
CASE XH;    WRITE LOW BYTE IN HEX
    AA=ITU
    ITU=AA
    IAA=ITU/I16;    HIGH HEX DIGIT
    IBB=IAA*I16;    FANCY MASKER
    IBB=ITU-IBB;    LOW HEX DIGIT
    CC=IAA
    GOSUB WH
    CC=IBB
    GOSUB WH;    WRITE HEX DIGITS
DEFAULT;    NUMBER OR ERROR
    CC=RI(QI)
    GOSUB ZN
    IF AA
        AA=CC-X0
    ELSE
        MS 'ILLEGAL S'
        MS 'TORE ATMP'
        GOSUB CR
        AA=+000
    ENDIF
    IPR(AA)=ITU
ENDCHOOSE
ENDSUB;    ST
            SUB WH; WRITE HEX DIGIT TO OBUFF
AA=CC<=C9
IF AA
    CC=CC+X0
ELSE
    CC=CC+XA
    CC=CC-C9
    CC=CC-C1
ENDIF
BO(PB)=CC
PB++
ENDSUB;    WH
            SUB WN; WRITE NUMBER INTO OBUFF
GOSUB DS;    STACK THE DIGITS
WHILE
    IBB=ND
    AA=I00<!IBB
ON AA
    ND--
    AA=DS(ND)
    BO(PB)=AA
    PB++
ENDWHILE
ENDSUB;    WN
            SUB ZA;    ALPHA TEST CC ASSUMES LINEAR MONOTONIC
AA=CC-XA
BB=XZ-CC;IZIT A TO Z?
AA=AA<=CV
BB=BB<=CV
AA=AA&BB
ENDSUB;    ZA
            SUB ZH; TEST AND CONVERT HEX DIGIT
AA=X0<=CC
BB=CC<=X9
AA=AA&BB
IF AA
    CC=CC-X0
    RETURN
ENDIF
AA=XA<=CC
BB=CC<=XF;    CHECK 0-9, A-F
AA=AA&BB
IF AA
    CC=CC-XA
    BB=+010
    CC=CC+BB
    RETURN
ENDIF
ENDSUB;    ZH AA IS FALSE HERE
            SUB ZN;    CC IS A NUMBER
AA=CC-X0
BB=X9-CC
AA=AA<=C9
BB=BB<=C9
AA=AA&BB
ENDSUB
            SUB ZW;    CC IS WHITE SPACE
AA=CC==CB;BLANK
BB=CC==CT;TAB
AA=AA?BB;EITHER?
BB=CC==EL;RETURN
AA=AA?BB
BB=CC==NL;NEW LINE (LF)
AA=AA?BB
ENDSUB;    ZW
            SUB KG; READ CC FROM FILE 1 - DISCARD C/R
READ CC FROM F1;    READ A CHARACTER
KA=CC==EL
    IF KA
    READ CC FROM F1;    IF LAST CHARACTER WAS C/R
    ENDIF
ENDSUB;    KG
BOTTOM