* * * DATA AND REM STATEMENTS * DATA CALL DIRT DATA STATEMENT ILLEGAL AS DIRECT * DATA1 XRA A * FALL THROUGH TO NEXTS (NON REM ENTRY PT) * * ADVANCE TXA TO TERMINATOR OF CURRENT STATEMENT * IF ACC HAS REMRW, THEN IGNORE EOSRW * NEXTS MVI B,CR CPI REMRW JZ NEXS0 MVI B,EOSRW * NEXS0 LHLD TXA NEXS1 MOV A,M CPI LNRW SKIP LN'S JNZ NEXS9 INX H LNRW INX H LOW INX H HIGH JMP NEXS1 NEXS9 CPI CR JZ NEXS2 CMP B INX H JNZ NEXS1 DCX H NEXS2 SHLD TXA RET * REM MVI A,REMRW JMP NEXTS * * * DIMENSION STATEMENT * DIM CALL ANAME JC DIM1 VECTOR CASE * * STRING CASE * CALL STLK JNC DMERR CALL EATLP CALL PFIXE JZ DMERR CALL EATRP CALL DIMST DIM0 CALL SCOMA RC . SEE IF MORE TO DO JMP DIM * * VECTOR CASE * DIM1 MOV A,C ORI MTYPE MOV C,A CALL STLK JNC DMERR CALL EATLP LXI H,2 CALL ASTAB ALLOCATE SPACE OF MAX SIZE PUSH H CALL PFIXE PUSH D PUSH D * * BEGIN LOOP WHICH GETS DIMENSIONS * DIM2 LXI H,2 ALLOCATE DIMENSION IN DIMENTION TABLE CALL ASTAB POP D DIMENSION SIZE MOV A,D ORA E JZ DMERR CAN'T BE ZERO CALL DSTOR STORE DIMENSION IN TABLE CALL SCOMA JC DIM3 JMP IF NO MORE DIMENSIONS CALL PFIXE GET NEXT DIMENSION POP B ACCUMULATING SIZE IN ELEMENTS PUSH D CALL IMUL XTHL . DO THIS SO THE CURRENT INDEX SIZE WILL BE ON TOP A PUSH H JMP DIM2 * * DONE COLLECTING DIMENSIONS DIM3 CALL EATRP POP D ACCUMULATED SIZE POP H SYMTAB ADDR TO MAX SIZE FIELD CALL DIMM JMP DIM0 * * * STOP STATEMENT * STOP CALL DIRT LXI H,IL1 XTHL SAVE CONTINUE ADDRESS, DESTROY RETURN LINK PUSH B SAVE REGISTORS PUSH D PUSH H * STOP1 MVI A,1 THIS ENTRY POINT FROM PCHECK STA CONTF STA DIRF * LHLD TXA PUSH H SAVE TXA ON STACK * LXI H,0 DAD SP SHLD SPTR * CALL CCRLF LXI H,STOPS CALL PRNT LXI H,STOP2 SHLD IBUF ADDR OF SECOND PART TO IBUF JMP ERM1 * * STOPS ASC 'STOP "' * * * END STATEMENT * END CALL DIRT END1 XRA A STA CONTF JMP CMND0 * * * READ STATEMENT * RTXA SHOULD POINT TO EITHER A ',' OR A CR * READ CALL GC TEST FOR FILE READ CPI '#' JZ SFREAD READ7 CALL XTXA READ1 CALL SCOMA JNC READ2 PROCESS INPUT VALUE * * SCAN FOR NEXT DATA STATEMENT LXI B,DATARW*256+DATARW CALL LSTAT * * PROCESS VALUE (GIVE ERROR IF CARRY IS SET) * READ2 CALL XTXA TXA TO PROGRAM AGAIN JC RDERR NOTE THAT CARRY ONLY SET ON ERROR HERE CALL VAR CALL XTXA JZ READ5 STRING CASE * * NUMERIC CASE * PUSH H CALL CONST JC RDERR BAD CONSTANT POP D CALL POPA1 STORE VALUE IN VARIABLE JMP READ6 * * STRING CASE * READ5 MVI A,'"' CALL STASS * READ6 CALL XTXA CALL SCOMA MORE TO DO? JNC READ7 RET * * * RESTORE STATEMENT * RESTOR CALL LNUM XCHG LHLD BOFA IN CASE NO LINE NUMBER SUPPLIED REST0 CNC FNEQLN DCX H POINT TO THE CR BEFORE SPECIFIED LINE SHLD RTXA RET * * * PRINT STATEMENT * PRINT CALL CFD CALL GC TEST FOR FILE PRINT CPI '#' JZ SFPRINT * * IF IN KEYBOARD MODE THEN CRLF * PUSH PSW LDA DIRF ORA A CNZ CRLF NEWLINE POP PSW * * SPECIAL CASE WHERE FIRST THING IS AN EOS MARK * CPI CR JZ CRLF CPI EOSRW JZ CRLF LXI H,IFTERM CMP M JZ CRLF * PR0 CALL GC CPI CR RZ . END OF STATEMENT * CPI EOSRW RZ . END OF STATEMENT * CPI ',' JZ PR1 * CPI ';' JZ PR1 * LXI H,IFTERM CMP M RZ END OF STATEMENT * CPI TABRW JZ PTAB GO DO TABULATION * CPI '%' JZ PFORM GO DO SET FORMAT * CALL STEST JZ PSTR GO PRINT A STRING * CALL EXPRB MUST BE EXPRESSION TO PRINT CALL POPFP POP VALUE TO FPSINK LHLD TSTKA POINTS TO WHERE THE VALUE WAS ON TOP OF STACK CALL FPOUT GO PRINT THE NUMERIC RESULT * * CHECK LINE WILL OVERFLOW, LENGTH OF OUTPUT VALUE STRING IN * REG B * LDA PHEAD ADD B MOV B,A LDA LINLEN CMP B CC CRLF CALL PRNT PRINT TO '"' (STRING POINTER IN HL) CALL PCHECK * PR1 MVI A,';' CALL SCANC JZ PR0 MORE ITEMS TO PROCESS (OR END OF LIST) MVI A,',' CALL SCANC JZ CTAB JMP CRLF NO MORE ITEMS, CRLF AND RETURN * PSTR LHLD TSTKA REMEMBER BASE ADDRESS OF STRING WE ARE ABO PUSH H CALL SEXPG POP D BASE ADDRESS OF STRING (COUNT IS IN HL) XCHG SHLD TSTKA * PSTR1 MOV A,D ORA E JZ PR1 LDA LINLEN MOV B,A LDA PHEAD CMP B CNC CRLF MOV B,M CALL OF1 THIS WILL PRINT CTRL-CHARACTERS IN NON-EXPANDED FORM CALL PCHECK DCX H DCX D JMP PSTR1 * PFORM CALL FORMAT JMP PR1 * CTAB LDA TWIDTH GET TAB FIELD WIDTH MVI E,0 MOV B,A LDA PHEAD PRINTER HEAD POSITION CT0 MOV D,A MOV A,E ADD B NEW POSITION=NEW POSITION+FIELD WIDTH MOV E,A MOV A,D SUB B OLD POSITION=OLD POSITION-FIELD WIDTH JNC CT0 DONE IF UNDERFLOW CALL PTAB1 TAB TO NEW POSITION IN E JMP PR0 * PTAB CALL GCI GOBBLE TAB RW CALL EATLP CALL PFIXE CALL EATRP MOV A,D CHECK MAGNITUDE BETWEEN 0 AND 255 INCLUSIVE ORA A JNZ OBERR CALL PTAB1 JMP PR1 * PTAB1 LDA PHEAD CMP E RNC MVI B,' ' CALL CHOUT CALL PCHECK JMP PTAB1 * * * FORMAT PROCESSOR * FORMAT CALL CFF * PFRM1 CALL GCI CALL INTGER JNC PFRM2 JUMP IF FOUND WIDTH CPI 'D' JZ PFTWO LXI H,COPT MVI B,200Q CPI 'Z' JZ PFONE MVI B,100Q CPI 'C' JZ PFONE MVI B,40Q CPI PLSRW JZ PFONE MVI B,1 CPI '$' JZ PFONE MVI B,2 CPI '#' JNZ PFRM3 * PFONE MOV A,M ORA B MOV M,A JMP PFRM1 * PFTWO CALL CFD JMP PFRM1 * * INTEGER WIDTH IN DE PFRM2 MOV A,H ORA A JNZ FMERR MOV A,L ORA A JZ FMERR CPI WMAX+1 JNC FMERR STA CWIDTH * * GET TYPE OF FORMAT CALL GCI CPI 'I' JZ PF3 CPI 'E' JZ PF4 CPI 'F' JNZ FMERR * * GET CFRACT PF4 PUSH PSW CALL INTGER JC FMERR MOV A,H ORA A JNZ FMERR MOV A,L LXI H,CWIDTH CMP M JNC FMERR STA CFRAC POP PSW CPI 'E' JNZ PF3 IF NOT E THEN SKIP THIS TEST * LDA CFRACT MOV B,A LDA CWIDTH SUB B CPI 5+1 JC FMERR CWIDTH MUST BE 6 GREATER THAN CFRACT MVI A,'E' * PF3 STA CFORM * PFRM3 LXI H,COPT MOV B,M MOV A,M ANI 375Q MOV M,A MOV A,B ANI 2 CNZ DFC RET * * * INPUT STATEMENT * INPUT LHLD TXA PUSH H SAVE TXA * CALL SCOMA PUSH PSW REMEMBER WHETHER OR NOT TO ECHO CARRIAGE RETTUR * MVI A,LPARRW TEST FOR LIMIT OPTION CALL SCANC CNC IN10 * MVI A,'"' CALL SCANC JNC IN9 GO PRINT INITIAL QUOTED STRING * INP0 MVI B,'?' CALL CHOUT * INP1 CALL INLINE POP PSW PUSH PSW CNZ CRLF LXI D,IBUF1 INPUT ARRIVES AT IBUF1 * IN1 PUSH D SAVE FOR FPIN CALL VAR JZ IN5 STRING CASE POP D IN1B LDAX D EAT LEADING SPACES CPI ' ' JNZ IN1A INX D JMP IN1B IN1A CALL FPIN INPUT FP NUMBER JC IN8 * IN4 CALL SCOMA JC IN7 JMP IF NO MORE TO DO MOV A,B GET THE TERMINATOR TO A CPI ',' JZ IN1 GET THE NEXT INPUT VALUE FROM STRING CPI CR JNZ IN8 * * GET NEW LINE FROM USER MVI B,'?' CALL CHOUT JMP INP0 * * STRING CASE IN5 CALL FTXA SWITCH TOP OF STACK WITH TXA MVI A,CR CALL STASS ASS STRING TO VARIABLE FROM INPUT LINE POP H SHLD TXA RESTORE TXA MVI B,CR JMP IN4 * * NO MORE INPUT DESIRED IN7 MOV A,B CPI CR POP D POP THE "CR FLAG" POP H ORIGINAL TXA RZ PUSH H RESTORE SAVED TXA TO STACK PUSH D RESTORE CRFLAG * * INPUT ERROR, START OVER * IN8 LHLD ERRLN TEST FOR ERROR TRAPPING MOV A,H ORA L JNZ INERR IF SO THEN INPUT ERROR * * HANDEL THE ERROR LOCALY * POP PSW CNZ CRLF NO CRLF IF IN NOCRLF MODE LXI H,INSTR CALL PRNT POP H POP ORIGINAL TXA OF PRINT STATEMENT SHLD TXA RESTORE ORIGINAL TXA JMP INPUT * * PRINT INITIAL QUOTED STRING (TXA IN HL) IN9 MOV B,M MOV A,B INX H CPI '"' JZ IN9A CPI CR JZ BSERR NO CLOSING QUOTE CALL OF1 JMP IN9 IN9A SHLD TXA CALL PCHECK MVI B,',' CALL EATC JMP INP1 * IN10 CALL DIRT CALL PFIXE GET COUNT LIMIT EXPRESSION MOV A,D ORA A JNZ OBERR TOO BIG MOV A,E CPI LINMAX+1 TOO BIG? JNC OBERR YES STA ICNT INPUT COUNT LIMIT * MVI B,',' CALL EATC * CALL PFIXE GET TIME LIMIT EXPRESSION XCHG SHLD ITIM SAVE IT * JMP EATRP EAT RP AND RETURN * INSTR ASC 'INPUT ERROR, RETYPE "' * * * DEF STATEMENT * DEF CALL DIRT0 CALL FEND JMP DATA * FN CALL DIRT0 JMP CSERR CAN'T BE A STATEMENT * * * OUT , * OUT CALL PFIXE PUSH D SAVE PORT ADDR IN E CALL SCOMA , CALL PFIXE XCHG . MOVE TO HL POP D GET PORT ADDR PUSH H SAVE VALUE MVI A,323Q 'OUT' OP CODE CALL OSET SETUP POP H MOV A,L GET VALUE TO A JMP OBUF * * OBUF SETUP ROUTINE * OSET LXI H,OBUF MOV M,A OPCODE MOV A,D HIGH ORDER BITS SHOULD BE 0 ORA A JNZ OBERR INX H MOV M,E DEVICE CODE INX H MVI M,311Q RETURN INSTRUCTION RET * * * FILL A BYTE FILL(ADDRESS,BYTE) * FILL CALL PFIXE PUSH D MEMORY ADDRESS CALL SCOMA CALL PFIXE POP H MOV M,E RET * * * WAIT FOR SOME BITS IN AN I/O PORT * SWAIT CALL DIRT CALL PFIXE GET PORT MVI A,0DBH A 'IN' INST CALL OSET * MVI B,',' CALL EATC * CALL PFIXE GET MASK MOV A,D ORA A JNZ OBERR PUSH D * MVI B,',' CALL EATC * CALL PFIXE GET WORD MOV A,D ORA A JNZ OBERR PUSH D * SW0 CALL OBUF CALL THE IN INST POP B POP D ANA E MASK CMP C AND TEST RZ . BIT FOUND! PUSH D PUSH B CALL PCHECK IN CASE OF A LONG WAIT JMP SW0 WAIT FOR IT * * * * SET CURSOR POSITION * SCURS LDA XOPORT ORA A JNZ NAERR * CALL SCOMA JNC SCUR0 TAKE DEFAULT FOR Y CALL GC DEFAULTS? CPI CR JZ SCUR1 FOR X AND Y CPI EOSRW JZ SCUR1 FOR Y AND X CALL PFIXE MOV A,E RESULT MOD 256 STA LY SET LAST Y POS * CALL SCOMA JC SCUR1 TAKE DEFAULT SCUR0 CALL GC CPI ',' JZ SCUR1 TAKE DEFAULT CALL PFIXE MOV A,E RESULT MOD 256 STA LX SET LAST X POS * IF SOLOS SCUR1 LDA LX ANI 64-1 STA PHEAD MVI B,1 THE X ... CALL ESCSEQ ESCAPE SEQUENCE ENDF IF PTDOS SCUR1 CALL CREM REMOVE PRESENT CURSOR LDA LX ANI 64-1 0 TO 63 STA PHEAD STA VLX ENDF * LDA LY IF SOLOS MVI B,2 THE Y ... CALL ESCSEQ ESCAPE SEQUENCE ENDF IF PTDOS STA VLY ENDF * * TEST FOR CHAR PLOP * CALL SCOMA SEE IF THIRD PARM PRESENT IF PTDOS JC SCUR2 NO COMMA, TURN CURSOR ON CALL PFIXE GET EXPR TO DE PUSH D CALL VDADD POP D MOV M,E PLOP! RET * * SCUR2 LDA CURFG GET CURSOR FLAG ORA A RZ . THEY DIDN'T WANT ONE ANYWAY CALL VDADD LDA CURFG XRA M PUT IT ON IN THE RIGHT POLARITY MOV M,A ENDF IF SOLOS DB !!! CURSOR !!! ENDF RET . DONE * * LX DB 0 THE LAST X POSITION LY DB 0 THE LAST Y POSITION * * * SEARCH STATEMENT * SSEAR LHLD TSTKA SAVE LEFT HAND STRING ADDRESS SHLD LHSBA CALL SEXPG GET STRING TO STACK PUSH H SAVE LHS SIZE * MVI B,',' SYNTAX CALL EATC * LHLD TSTKA SAVE RHS BA SHLD RHSBA CALL SEXPG PUSH H RHSSZ * MVI B,',' CALL EATC * CALL VAR GET INDEX VAR ADDR INTO... JZ TYERR SHLD XC XC CALL ZEX INITIALIZE IT TO ZERO (NOT FOUND) * LHLD LHSBA POP THE STACK SHLD TSTKA * POP H RHSSZ POP D LSHSZ CALL DSUB LH:=HL (RHSSZ) - DE (LHSSZ) INX H SHLD XA :=NUMBER OF TIMES TO COMPARE * LXI H,0 INIT INDEX SHLD XB MOV B,D DE (LHSSZ) TO BC MOV C,E RC . FLAGS FROM CALL TO DSUB ABOVE (LHS>RHS?) * SSEA0 PUSH B LHSSZ PUSH D RHSSZ CALL SCOMP COMPARE POP D POP B JZ SSEA1 EQU, SET INDEX AND RETURN * LHLD XA # OF TIMES DCX H LESS 1 SHLD XA MOV A,H TEST FOR DONE ORA L RZ . NO MATCH * LHLD XB INDEX:=INDEX+1 INX H SHLD XB * LHLD RHSBA MOVE UP ONE POSITION IN RHS DCX H SHLD RHSBA * JMP SSEA0 NEXT! * * SSEA1 LHLD XB INDEX INX H CALL FLOAT TO ARG STACK LHLD XC ADDR OF VAR CALL POPAS POP ARG STACK TO VAR RET . ALL DONE * * * PAUSE * SPAW CALL DIRT CALL PFIXE MOV A,D ORA E RZ . VERRY FUNNY !!! * PAW0 LXI H,TIMCONST GET TIMMING CONSTANT PAW1 DCX H TICK... CALL PCHECK INCASE USER WANTS NOT TO WAIT MOV A,H ORA L JNZ PAW1 * DCX D ...TOCK MOV A,D ORA E JNZ PAW0 * RET . TIME'S UP, BYE...BYE... * *