TITLE 'PASCAL/MT RUN TIME PACKAGE RELEASE 3.0' ;-------------------------------------------------------; ; Pascal/MT RUN-TIME PACKAGE ; ;-------------------------------------------------------; ; ; ; REV 0 JULY 22, 1979 Original Entry ; ; Rev 16 Oct 12, 1979 Release 2.5 ; ; Rev 17 Oct 20, 1979 FXP routines added ; ; Rev 18 Nov 18, 1979 Bfloat,and bcd added ; ; REV 20 DEC 2, 1979 UNDERCPM + RAMADDR ADDED; ; REV 21 DEC 13, 1979 FLOAT.LIB + S/W I/O ; ; Rev 22 Dec 27, 1979 Release 2.6 ; ; Rev 23 Jan 23, 1980 Release 3.0 ; ; Rev 24 Feb 14, 1980 Release 3.0b ; ; Rev 25 Apr 25, 1980 Release 3.0k ; ; ; ; WRITTEN BY Michael G. Lehman ; ; (C) 1979 MT MicroSYSTEMS ALL RIGHTS RESERVED ; ; Information contained herein is proprietary to ; ; MT MicroSYSTEMS. All terms of licence agreement; ; apply to this software in object or source form ; ;-------------------------------------------------------; PAGE MACLIB CONFIG RTPCONFIG MACLIB MATH IF BFLOAT MACLIB RMACS MACLIB DECCONV IF NOT HARDWARE MACLIB SW9511 MACLIB FLOAT MACLIB REAL2FP ENDIF ENDIF PAGE ;---------------------------------------------------------------; ; JUMP TABLE THE COMPILER ASSUMES IS HERE ; ;---------------------------------------------------------------; JMP DEBUGGER JMP DIV XMUL: JMP MUL XMULX: JMP MULX XMOD: JMP MOD16 XWINT: JMP WINT XRINT: JMP RINT XWCHR: JMP WCHR XCHRW: JMP CHRW XRCHR: JMP RCHR IF FILESTUF XFOPEN: JMP FOPEN ; XFCLOSE: JMP FCLOSE ;CP/M FILE XFREAD: JMP FREAD ;PRIMITIVE ROUTINES XFWRITE: JMP FWRITE ; ELSE REPT 4 JMP UNIMP ;FOR FILE ROUTINES ENDM ENDIF XCRLF: JMP CRLF XCRWAIT: JMP CRWAIT XINTEQ: JMP INTEQ XINTNE: JMP INTNE XINTGT: JMP INTGT XINTLT: JMP INTLT XINTGE: JMP INTGE XINTLE: JMP INTLE XCJMP: JMP CASEJMP XFOR: JMP FORASSIST XMOVE: JMP BLKMOVE IF FILESTUF XDELETE: JMP FDELETE XCREATE: JMP FCREATE ELSE JMP UNIMP ;FOR FDELETE JMP UNIMP ;FOR FCREATE ENDIF IF CHARSTUF XCHREQ: JMP CHREQ XCHRNE: JMP CHRNE XCHRGT: JMP CHRGT XCHRLT: JMP CHRLT XCHRGE: JMP CHRGE XCHRLE: JMP CHRLE ELSE REPT 6 JMP UNIMP ;FOR CHAR ARRAY COMPARES ENDM ENDIF XCHKBPT: JMP CHKBPT ;USED FOR DEBUGGER XPROCENT: JMP PROCENT ;USED FOR DEBUGGER XBOOLEQ: JMP BOOLEQ XBOOLNE: JMP BOOLNE XBOOLGT: JMP BOOLGT XBOOLLT: JMP BOOLLT XBOOLGE: JMP BOOLGE XBOOLLE: JMP BOOLLE XPCHRW JMP PCHRW ;PRINTER CHRW XPWCHR JMP PWCHR ;PRINTER WCHR XPWINT JMP PWINT ;PRINTER WINT XPCRLF JMP PCRLF ;PRINTER CRLF XINITRTP: JMP INITRTP ;LOAD RST VECTORS IF BITSTUF XSHL: JMP SHIFTLEFT XSHR: JMP SHIFTRIGHT XTST: JMP TSTBIT XSET: JMP SETBIT XCLR: JMP CLRBIT ELSE REPT 5 JMP UNIMP ;FOR BIT ROUTINES ENDM ENDIF XSETIO: JMP SETIOADDR IF CHAINSTUF XRTPCHN: JMP RTPCHAIN ;PROGRAM CHAINING ROUTINE ELSE JMP UNIMP ENDIF IF RANDOMSTUF XRNDRD: JMP RANDOMREAD XRNDWR: JMP RANDOMWRITE ELSE JMP UNIMP JMP UNIMP ENDIF IF BFLOAT OR BCD XREALEQ: JMP REALEQ XREALNE: JMP REALNE XREALGT: JMP REALGT XREALLT: JMP REALLT XREALGE: JMP REALGE XREALLE: JMP REALLE XRREAL: JMP RREAL XWREAL: JMP WREAL IF BFLOAT AND (NOT HARDWARE) JMP SWRADD ;USE SOFTWARE ROUTINES JMP SWRSUB JMP SWRMUL JMP SWRDIV ELSE XRADD: JMP RADD XRSUB: JMP RSUB XRMUL: JMP RMUL XRDIV: JMP RDIV ENDIF XRNEG: JMP RNEG XRABS: JMP RABS IF bfloat AND HARDWARE XRSQRT: JMP RSQRT ENDIF IF BFLOAT AND (NOT HARDWARE) XRSQRT: JMP SWRSQRT ENDIF XTRUNC: JMP TRUNC XROUND: JMP ROUND XPWREAL JMP PWREAL IF bfloat XREALOP JMP BINOP ;EXTENDED LOAD/STORES FOR 4-BYTE REALS ELSE XREALOP JMP FXPOP ;EXTENDED LOAD/STORES FOR 10-BYTE FXP ENDIF ENDIF ;IF BFLOAT OR BCD IF BCD XHLTIMES5 JMP HLTIMES5 ;HL := HL * 5 XFLIP10 JMP FLIP10 ;"FLIP" A 10-BYTE FXP ON THE STACK ENDIF IF BFLOAT XATOR JMP ATOR ;SETUP TO CALL FLTIN ROUTINE XGETADR JMP GETADR ;RETURNS ADDRESS OF A VARIABLE ENDIF IF BFLOAT GETADR: XCHG MOV M,C INX H MOV M,B RET ATOR: ; ; ROUTINE USED TO CALL FLTIN FROM A PASCAL PROGRAM ; ; ; PASCAL DECLARATION: ; ; PROCEDURE EXTERNAL[CNVRTADDR] XATOR(VAR ERR:INTEGER; ; PTR:INTEGER; ; VAR PARR:BUFFER); ; ATOR: PUSH B ;SAVE ADDR OF ERR VARIABLE MOV C,M ;GET FIRST BYTE OF BUFFER INX H CALL FLTIN POP H ;STUFF ERR BYTE IN ERR VARIABLE MOV M,A INX H MVI M,0 RET endif PAGE $-print if bcd $+print ; ; HLTIMES5 - USED IN SUBSCRIPTING 10-BYTE FXP NUMBERS ; ; COMPILER GENERATES CODE TO MULTIPLY BY 2 BUT ; WE NEED 10 SO WE MULTIPLY BY 5 HERE ; HLTIMES5: PUSH D XCHG LXI H,0 DAD D DAD D DAD D DAD D DAD D POP D RET ; ; FLIP10 - "FLIP" A 10-BYTE FXP NUMBER ON THE STACK ; THIS IS CALLED WHEN A 10-BYTE FXP NUMBER IS TO BE PASSED ; AS A PROCEDURE PARAMETER ; FLIP10: POP H ;SAVE RET ADDR SHLD FLIPRET LXI H,0 DAD SP XCHG LXI H,TEMP10 LXI B,10 CALL BLKMOVE ;"REMOVE" THE NUMBER LXI H,10 DAD SP SPHL ;RELOAD THE SP LHLD TEMP10 ;NOW "PUSH" ON IN REVERSE ORDER PUSH H LHLD TEMP10+2 PUSH H LHLD TEMP10+4 PUSH H LHLD TEMP10+6 PUSH H LHLD TEMP10+8 PUSH H LHLD FLIPRET PCHL ;AND WE ARE DONE endif ;BCD $+print PAGE ; ; ROUTINE TO INITIALIZE RESTART VECTORS ; ; INITRTP: ; if bfloat AND HARDWARE INI9511 ;INITIALIZE 9511 CHIP ENDIF RET PAGE ; ; ROUTINE CALLED BY RUN-TIME CODE TO SET UP I/O ADDRESS ; IF HL CONTAINS FFFF THEN CONSOLE I/O IS SELECTED ; ELSE A USER ROUTINE ADDRESSS MAY BE PASSED ; ; FOR INPUT THE ROUTINE SHOULD RETURN WITH THE CHAR ; ON THE STACK IN THE LOW ORDER BYTE ; E.G. POP B WILL GET THE CHAR IN THE C-REG ; NOTE THAT PUSH PSW WILL RETURN THE CHAR IN THE B-REG IF ; POP B IS USED TO RETRIEVE IT AND THEREFORE CANNOT BE USED ; TO PUSH THE CHARACTER ; ; NOTE ALSO IF A USER INPUT ROUTINE IS USED THEN ECHOING IS ; NOT DONE AND IS LEFT UP TO THE USER INPUT ROUTINE ; ; FOR OUTPUT THE CHAR WILL BE SENT ON THE STACK IN ; THE LOW ORDER BYTE UNDER THE RETURN ADDRESS ; SETIOADDR: SHLD IOADDR RET ; ; UNIMPLEMENTED ROUTINE CODE ; ; THE CONDITIONAL ASSEMBLY USED TO SELECT JUST THE ; REQUIRED RTP ROUTINES WILL POSSIBLE GENERATE A JUMP ; TO THIS ROUTINE ; ; IF A USER USES A FEATURE THAT THE RTP WHICH HE HAS USED ; DOES NOT CONTAIN THE THIS ROUTINE SHOULD HANDLE THE ERROR ; ; WE HAVE SUPPLIED A ROUTINE TO PRINT "UNIMPLEMENTED ROUTINE USED" ; ON THE CONSOLE FOR CP/M SYSTEMS ; UNIMP: LXI H,UNMSG PUSH H LXI H,UNLEN CALL WCHR JMP 0 ;AND STOP HERE UNMSG: DB 13,10 DB 'ERROR' DB 13,10 UNLEN EQU $-UNMSG BIOSCALL MACRO LOCAL PASTSUB JMP PASTSUB ; PARAMETERS: L CONTAINS OFFSET INTO JUMP TABLE ; ANY OTHER REGS MUST BE SAVED BY CALLER ; B$CALL: if trs80 lda 4202H else LDA 2 endif MOV H,A PCHL ;AND OFF WE GO! PASTSUB BIOSCALL MACRO CALL B$CALL ENDM BIOSCALL ENDM PAGE ; ; PROCEDURE: CASEJMP ; PARMS: DE = ^CASETABLE ; TOS:CASEVARIABLE ; ; ; CASE TABLE FORMAT: ; +0 : NUMBER OF ENTRIES ; { +2 : VALUE SELECTOR ; REPEATED N TIMES { +4 : ADDR TO GOTO IF THIS VALUE ; CASEJMP: POP H ;THROW AWAY RETURN ADDRESS POP H ;GET CASEVARIABLE XCHG ;HL NOW IS ^TABLE ;DE IS CASEVARIABLE MOV C,M INX H MOV B,M ;GET # ENTRIES IN CASE TABLE INX H ;MAKE HL = FIRST VALUE SELECTOR CASELOOP: MOV A,B ORA C JZ NOTFOUND ;BRANCH IF NOT IN TABLE (OR TABLE EMPTY) MOV A,M INX H CMP E ;COMPARE WITH CASEVARIABLE INX H JNZ X2 DCX H MOV A,M INX H CMP D ;HI BYTE MATCH? JZ FOUND X2: ;NOT THIS ONE, SKIP OVER ADDR INX H INX H DCX B JMP CASELOOP ; ; FOUND, GET ADDR FROM TABLE AND BLAST OFF ; FOUND: MOV A,M INX H MOV H,M MOV L,A PCHL ; NOTFOUND: PCHL PAGE ; ; PROCEDURE: CHRW ; PARMS : SINGLE CHARACTER ON TOS ; chrw: xra a sta printflag CHRW1: POP H ;GET RETADDR POP B ;GET CHAR INTO C PUSH H ;PUT RETADDR BACK ON STACK PUSH B ;PUT CHAR BACK ON STACK FOR CR CHECK MOV E,C ;FOR BDOS I/O CALL PUTCHR ;USES IOADDR PASSED BY USER PROGRAM POP B MOV A,C CPI 0DH RNZ ;IF NOT CR THEN EXIT MVI E,0AH CALL PUTCHR ;USES IOADDR PASSED BY USER PROGRAM RET ;AND GET OUT OF HERE PUTCHR: LHLD IOADDR MOV A,H CPI 0FFH JNZ USEROUT ;BR IF USER SUPPLIED A ROUTINE MOV A,L CPI 0FFH JNZ USEROUT ;AGAIN IF USER SUPPLIED ROUTINE ; ; IF TO USE CP/M THEN IOADDR = FFFF (AN UNLIKELY ADDR FOR USER ROUTINE) ; CALL GETFUNC CALL BDOS ;AND OUTPUT THE CHAR RET USEROUT: ; ; CHAR IS IN E-REG AND ON THE STACK UNDER THE RET ADDR ; THE REASON IT IS ON THE STACK IS SO THAT THE USER MAY ; USE A ROUTINE WRITTEN IN PASCAL AS A CHAR OUTPUT ROUTINE ; ; POP H ;GET "RETURN" ADDRESS BACK PUSH D ;PUT CHAR ON STACK PUSH H ;PUT "RETURN" ADDR ON STACK LHLD IOADDR PCHL ;AND GO TO USER ROUTINE ;RETURN IS TO CALLER OF PUTCHR ; ; CHRW FOR PRINTER ; PCHRW: IF AUTOENGR LDA CONFLAG ORA A JZ CHRW ;IF = 0 THEN GOTO CONSOLE ROUTINE ENDIF MVI A,1 STA PRINTFLAG JMP CHRW1 PAGE ;***** Word comparisons. pop b; pop a; push (a b) BOOLEQ: CALL BOOLFIXUP ;GO STRIP OFF BITS INTEQ: ; Compare for = POP B ;SAVE RET ADDR POP D POP H MOV A,L SUB E JNZ PSHFLS MOV A,H SBB D JZ PSHTRU PSHFLS: LXI H,0 PUSH H MOV H,B MOV L,C PCHL BOOLGE: CALL BOOLFIXUP INTGE: ; Compare for >= POP B POP D POP H GEQ0: MOV A,D XRA H JM GEQ1 MOV A,L SUB E MOV A,H SBB D JP PSHTRU JMP PSHFLS GEQ1: ANA H JP PSHTRU JMP PSHFLS BOOLGT: CALL BOOLFIXUP INTGT: ; Compare for > POP B POP D POP H GTR0: MOV A,D XRA H JM GEQ1 MOV A,E SUB L MOV A,D SBB H JC PSHTRU JMP PSHFLS BOOLNE: CALL BOOLFIXUP INTNE: ; Compare for <> POP B POP D POP H MOV A,L SUB E JNZ PSHTRU MOV A,H SBB D JZ PSHFLS PSHTRU: LXI H,1 PUSH H MOV H,B MOV L,C PCHL BOOLLE: CALL BOOLFIXUP INTLE: ; Compare for <= POP B POP H POP D JMP GEQ0 BOOLLT: CALL BOOLFIXUP INTLT: ; Compare for < POP B POP H POP D JMP GTR0 ; ; BOOLFIXUP ROUTINE: ; STRIP OFF ALL BUT LOW ORDER BIT FOR ; BOOLEAN COMPARE ; BOOLFIXUP: POP B ;GET RET ADR POP D ;GET SECOND RETURN ADDR POP H ;GET OPERAND MVI H,0 ;ZERO HI BYTE MOV A,L ANI 1 MOV L,A XTHL ;GET OTHER OPERAND TO HL MVI H,0 MOV A,L ANI 1 MOV L,A XTHL ;PUT THEM BACK ON IN RIGHT ORDER PUSH H PUSH D PUSH B RET ;PUT STUFF BACK AND RETURN PAGE ; ; PROCEDURE: CRLF ; PARAMETERS:NONE ; CRLF: XRA A STA PRINTFLAG CRLF1: ; ; MVI C,0DH PUSH B CALL CHRW1 RET GETFUNC: MVI C,2 LDA PRINTFLAG ORA A RZ MVI C,5 RET ; ; CRLF FOR PRINTER ; PCRLF: IF AUTOENGR LDA CONFLAG ORA A JZ CRLF ENDIF MVI A,1 STA PRINTFLAG JMP CRLF1 PAGE ; ; TWO'S COMPLEMENT DIVIDE ROUTINE ; DIVDX MACRO LOCAL PASTSUB LOCAL X10,X20,X30,X40 LOCAL Y10,Y20,Y30,Y40,Y50,Y60,Y70,Y80,Y99 JMP PASTSUB DIVPOS: ; Divide two positive integers ; Entry BC = divisor, HL = dividend ; Exit HL = remainder ; DE = quotient ; make HL divisor, DE dividend while shifting divisor left XCHG LXI H,0 DHLDEBYBC ;USE MATH.LIB MACRO BECAUSE ;IT IS ROMABLE XCHG ;DO AS ADVERTISED RET XDIVDX: ; Two's complement divide - mathematically correct even! ; NOTE WELL. Does not return values as specified in J & W. ; Entry BC = divisor, DE = dividend ; Exit HL = remainder, DE = quotient XRA A ; make sure divisor isn't 0 or -32768 ORA C JNZ Y10 ORA B JZ Y99 XRI 80H JZ Y99 Y10: MOV A,B ; check divisor sign ANA A JM Y50 Y20: ORA D ; check dividend sign JM Y40 Y30: XCHG ; divide positive by positive CALL DIVPOS RET Y40: MOV A,E CMA MOV L,A MOV A,D CMA MOV H,A CALL DIVPOS MOV A,E CMA MOV E,A MOV A,D CMA MOV D,A STC MOV A,C SBB L MOV L,A MOV A,B SBB H MOV H,A RET Y50: XRA A SUB C MOV C,A MVI A,00H SBB B MOV B,A MOV A,D ANA A JM Y80 JNZ Y60 ORA E JZ Y80 Y60: XCHG DCX H CALL DIVPOS MOV A,E CMA MOV E,A MOV A,D CMA MOV D,A Y70: MOV A,L SUB C MOV L,A MOV A,H SBB B MOV H,A INX H RET Y80: XRA A SUB E MOV L,A MVI A,00H SBB D MOV H,A CALL DIVPOS XRA A SUB L MOV L,A MVI A,00H SBB H MOV H,A RET Y99: POP H PUSH D HLT PASTSUB DIVDX MACRO CALL XDIVDX ENDM DIVDX ENDM DIV: POP H ;GET RET ADDR POP B ;DIVISOR POP D ;DIVIDEND PUSH H ;PUT RET ADDR BACK ON STACK DIVDX POP H PUSH D PCHL MOD16: POP H ;GET RET ADDR POP B ;DIVISOR POP D ;DIVIDEND PUSH H ;PUT RET ADDR BACK ON STACK DIVDX XTHL ;PUT HL ON STACK AND GET RET FROM STACK PCHL PAGE ; BLKMOVE: XCHG IF Z80CPU DB 0EDH,0B0H ;LDIR INSTRUCTION ELSE X1: MOV A,M STAX D INX H INX D DCX B MOV A,B ORA C JNZ X1 ENDIF XCHG ;PUT REGS BACK FOR RECURSION CODE RET PAGE MULTX: MULT: ; Two's complement integer multiply routine ; Entry BC = multiplicand, DE = multiplier, TOS = ret addr ; Exit TOS = product XCHG LXI D,0000H MOV A,C X10: MOV C,B MVI B,08H X20: RAR JNC X30 XCHG DAD D XCHG X30: DAD H DCR B JNZ X20 MOV A,C ANA A JNZ X10 XCHG XTHL PCHL MUL: POP H ;GET RET ADDR POP B ;GET ONE OPERAND POP D ;GET THE OTHER PUSH H ;PUT RET ADDR BACK ON STACK JMP MULTX ; ; USED BY SUBSCRIPTING ; MULX: MOV C,L MOV B,H CALL MULTX POP H ;GET VALUE BACK RET ;AND EXIT PAGE RCHR: PUSH H ;SAVE BUFFER ADDRESS CALL GETCHR ;GO GET CHAR FROM ROUTINE POP B ;GET CHAR TO C-REG POP H ;GET POINTER OF WHERE TO STORE CHAR MOV M,C ;STORE IT IN BUFFER ; ; IF NOT CONSOLE THEN DON'T ECHO ; LHLD IOADDR MOV A,H CPI 0FFH RNZ MOV A,L CPI 0FFH RNZ PUSH B CALL CHRW ;ECHO THE CHAR (INCLUDING LF AFTER CR IF NECESSARY) RET ; ; CRWAIT: CRWAIT1: CALL GETCHR ;GET CHAR POP B ;GET INTO C-REG MOV A,C ;CR? CPI 0DH JNZ CRWAIT1 ;IF NOT TRY AGAIN ; ; IF NOT CONSOLE THEN EXIT ; LHLD IOADDR MOV A,H CPI 0FFH RNZ MOV A,L CPI 0FFH RNZ PUSH B ;ECHO CR/LF CALL CHRW RET ;AND RETURN PAGE PWCHR: ; ; PROCEDURE: PWCHR - WRITE STRING ON PRINTER ; PARAMETERS: TOS: ^STRING ; HL = LENGTH OF STRING ; IF AUTOENGR LDA CONFLAG ORA A JZ WCHR ENDIF MVI A,1 STA PRINTFLAG JMP WCHR1 WCHR: XRA A STA PRINTFLAG WCHR1: ; ; PROCEDURE: WCHR ; PARAMETERS: TOS: ^STRING ; HL = LENGTH OF STRING ; POP B ;GET RETURN ADDR XCHG ;GET NUMBER OF BYTES POP H ;GET ^STRING PUSH B ;PUT RETURN ADDR BACK ON STACK WC$1: PUSH D MOV C,M PUSH H PUSH B CALL CHRW1 POP H POP D INX H DCX D MOV A,D ORA E JNZ WC$1 RET PAGE ; ; FORASSIST : CODE TO BULKY TO PLACE IN LINE ; SO WE MADE IT A SUBROUTINE ; ; FUNCTION: (TOS) - (TOS+2) => HL ; FORASSIST: POP D ;GET RETURN ADDRESS POP B ;GET LEFT OPERAND POP H ;GET RIGHT OPERAND PUSH D ;PUT RET ADDR BACK ON STACK MOV A,C SUB L MOV L,A MOV A,B SBB H MOV H,A RET PAGE ; ; write the integer which is on top of the stack ; WRITE TO PRINTER ; (under the return address) ; ; PWINT: IF AUTOENGR LDA CONFLAG ORA A JZ WINT ENDIF MVI A,1 STA PRINTFLAG JMP WINT0 ;; ; write the integer which is on top of the stack ; (under the return address) ; ; WINT: XRA A STA PRINTFLAG WINT0: POP H POP D ;get integer to write out PUSH H ;PUT RET ADDR BACK ON STACK CALL ICOLON ;HANDLE COLON WIDTH EXTRA SPACES ; ; FIRST SEE IF IT IS NEGATIVE ; MOV A,D ANI 80H JP WINT1 ;BRANCH IF NOT PUSH D MVI E,'-' CALL WDIG2 ;WRITE OUT '-' POP D MOV A,E ! CMA ! MOV E,A MOV A,D ! CMA ! MOV D,A INX D ;NEGATE IT (WE ALREADY WROTE -) ; ; NOW CHECK TO SEE IF IT IS -32768 ; MOV A,D ORA A JM WINTMAGIC ;BRANCH IF YES WINT1: MVI B,0 ;SET NOTYET FLAG PUSH B LXI B,10000 CALL XDIVDX ;GET DIV 10000 AND MOD 10000 POP B CALL WDIG ;WRITE THE DIGIT E-REG + '0' XCHG PUSH B LXI B,1000 CALL XDIVDX POP B CALL WDIG XCHG PUSH B LXI B,100 CALL XDIVDX POP B CALL WDIG XCHG PUSH B LXI B,10 CALL XDIVDX POP B CALL WDIG XCHG MVI B,1 ;FORCE THIS ONE ON CALL WDIG RET ; ; WINTMAGIC : WRITE OUT THE CHARS 32768 BECAUSE ; WE ALREADY WROTE OUT MINUS ; WINTMAGIC: LXI H,WINTMSG PUSH H LXI H,5 LDA PRINTFLAG ORA A JNZ WINTMM1 CALL WCHR RET WINTMM1: CALL PWCHR RET WINTMSG: DB '32768' WDIG: PUSH H MVI A,'0' ORA E MOV E,A CPI '0' JZ WDIG1 ;BRANCH IF A 0 MVI B,1 ;SET THE FLAG POP H WDIG2: PUSH H PUSH B PUSH D LDA PRINTFLAG ORA A JNZ WDIG3 CALL CHRW JMP WDIG3A WDIG3: CALL PCHRW WDIG3A: POP B POP H RET WDIG1: MOV A,B ORA A POP H RZ ;RETURN IF NOTYET JMP WDIG2 ; ; ICOLON: HANDLE WIDTH SPECIFICATION FOR INTEGERS ; INTEGER IN DE, (TO REMAIN THERE WHEN WE EXIT) ; WIDTH IN B-REG, 0FFH IF NOT SPECIFIED ; IF IWIDTHSTUF ICOLON MOV A,B CPI 0FFH RZ ;EXIT IF WIDTH NOT SPECIFIED PUSH D ;SAVE INTEGER MOV A,D ORA A JP ICPOS ;BRANCH IF POSITIVE CPI 80H JNZ ICNEG1 ;BRANCH IF NOT POSSIBLE -32768 MOV A,E ORA A JNZ ICNEG1 ;BRANCH IF NOT EXACTLY -32768 MOV A,B SUI 6 MOV B,A JMP ICNEG2 ;HANDLE 32768 CHARS ICNEG1: DCR B ;ACCOUNT FOR MINUS SIGN MOV A,D CMA MOV D,A MOV A,E CMA MOV E,A INX D ;TAKE ABSOLUTE VALUE ICPOS: ; ; NOW LOOP AND COUNT DIGITS ; PUSH B ;SAVE WIDTH LXI B,10 CALL XDIVDX POP B DCR B ;DECREMENT WIDTH MOV A,D ORA E JNZ ICPOS ;LOOP UNTIL RESULT IS = 0 ICNEG2: ; ; NOW WRITE OUT APPROPRIATE NUMBER OF SPACES ; MOV A,B ORA A JM ICXIT ;BRANCH IF WIDTH < 0 JZ ICXIT ;BRANCH IF WIDTH = 0 MVI E,' ' PUSH B PUSH D LDA PRINTFLAG ORA A JNZ ICPRINTER CALL CHRW JMP IC3 ICPRINTER: CALL PCHRW IC3: POP B DCR B JMP ICNEG2 ICXIT: POP D ;GET VALUE BACK RET ;AND EXIT ELSE ICOLON: RET ENDIF ;IWIDTHSTUF PAGE ; ; READ INTEGER ROUTINE ; SIMPLE ROUTINE TO READ AN INTEGER FROM THE KEYBOARD ; HL = ADDR OF PLACE TO STORE INTEGER ; TERM = , OR ; ON EXIT A-REG = TERM CHAR (FOR READLN OF AN INTEGER) ; RINT: PUSH H ;SAVE ADDR ON STACK LXI H,0 ;STARTING VALUE MVI C,0 ;INITIALLY - FLAG = NO RINT1: PUSH H PUSH B CALL GETCHR ;GO GET INPUT CHAR POP B ;GET CHAR MOV A,C POP B POP H CPI ' ' JZ RXIT CPI ',' JZ RXIT CPI 0DH JZ RXIT CPI '-' JNZ RINT2 MVI C,1 CALL ECHOIT JMP RINT1 RINT2: CPI '0' JC RINT1 ;IGNORE < '0' CPI '9'+1 JNC RINT1 ;IGNORE > '9' ; ; OTHERWISE ECHO THE CHAR ; CALL ECHOIT MOV E,L MOV D,H DAD H DAD H DAD H DAD D DAD D ;*8 + *2 = *10 ANI 0FH MOV E,A MVI D,0 DAD D JMP RINT1 ; ; NOW STORE RESULT AWAY ; RXIT: ; ; FIRST ECHO TERM CHAR ; CALL ECHOIT CPI 0DH JNZ RXIT1 MVI A,0AH CALL ECHOIT MVI A,0DH ;CR IS REALLY TERM CHAR RXIT1: PUSH PSW ;SAVE TERM CHAR MOV A,C ORA A JZ RINT3 ;BRANCH IF NOT NEGATIVE MOV A,L ! CMA ! MOV L,A MOV A,H ! CMA ! MOV H,A INX H ;NEGATE IT RINT3: POP PSW XCHG ;NUMBER IN DE POP H ;ADDR IN HL MOV M,E INX H MOV M,D RET ;AND EXIT ; ECHOIT: PUSH H PUSH B PUSH PSW MOV C,A ; ; IF NOT CONSOLE THEN DON'T ECHO ; LHLD IOADDR MOV A,H CPI 0FFH JNZ ECHO1 MOV A,L CPI 0FFH JNZ ECHO2 ECHO1: PUSH B ;CONSOLE, ECHO IT CALL CHRW ECHO2: ; MOV C,A ; MVI L,12 ; BIOSCALL POP PSW POP B POP H RET ; ; GETCHR - GET CHAR EITHER FROM BIOS OR FROM ; USER SUPPLIED INPUT ROUTINE ; GETCHR: LHLD IOADDR MOV A,H CPI 0FFH JNZ USERIN MOV A,L JNZ USERIN ;IF NOT FFFF THEN USE USER SUPPLIED ROUTINE ; ; ELSE USE BIOS ; MVI L,9 BIOSCALL ;*******ONLY DIRECT CALL TO THE BIOS******* ; ; CHAR COMES BACK IN A-REG ; GETCHR1: MOV C,A MVI B,0 POP H ;GET RETURN ADDR PUSH B PCHL ;AND EXIT GETCHR USERIN: LXI H,USERIN1 ;GET "RETURN" ADDRESS PUSH H LHLD IOADDR PCHL ;"CALL" USER ROUTINE USERIN1: POP B ;"GET " CHAR FROM USER ROUTINE POP H ;GET GETCHR RET ADDR PUSH B ;PUT CHAR ON STACK PCHL ;AND EXIT GETCHR PAGE IF FILESTUF ; ; CP/M FILE I/O ; ; OPEN,CLOSE,CREATE,DELETE TAKE AS PARMS: ; ; HL = ADDR OF FCB ; DE = ADDR OF FILE TITLE (ARRAY [0..11] OF CHAR) (NOT FOR CLOSE,DELETE) ; BC = ADDR OF INTEGER RESULT ; A = EXTENT NUMBER (OPEN ONLY) ; FOPEN: PUSH B ;SAVE ADDR OF RESULT PUSH H ;SAVE ADDR OF FCB LXI B,12 DAD B MOV M,A ;ZERO REEL # LXI B,20 DAD B MVI M,0 ;ZERO NR POP H PUSH H MVI M,0 ;FORCE TO DEFAULT DISK LXI B,12 ;NUMBER OF BYTES IN A FILE TITLE CALL BLKMOVE ;AND MOVE NAME INTO FCB POP D ;GET FCB ADDR BACK MVI C,15 ;OPEN FUNCTION CODE CALL BDOS POP H ;GET ADDR OF RESULT AREA BACK AGAIN MOV M,A ;STUFF IT AWAY INX H MVI M,0 ;BECAUSE IT IS AN INTEGER RET FCLOSE: PUSH B ;SEE ABOVE FOR COMMENTS XCHG ;GET FCB INTO DE MVI C,16 CALL BDOS POP H MOV M,A INX H MVI M,0 RET FCREATE: PUSH B ;SEE OPEN FOR COMMENTS PUSH H LXI B,12 DAD B MVI M,0 ;ZERO REEL # LXI B,20 DAD B MVI M,0 ;ZERO NR POP H PUSH H MVI M,0 LXI B,12 CALL BLKMOVE POP D MVI C,22 CALL BDOS POP H MOV M,A INX H MVI M,0 RET FDELETE: XCHG MVI C,19 CALL BDOS RET ; ; FREAD / FWRITE TAKE THE FOLLOWING PARMS: ; ; HL = ADDR OF FCB ; DE = ADDR OF 128 BYTE BUFFER (ARRAY [0..127] OF CHAR) ; BC = ADDR OF RESULT WORD ; A = 0FFH IF SEQUENTIAL ELSE IT EQUALS RECORD NUMBER FREAD: PUSH B ;SAVE RESULT ADDR PUSH H ;SAVE POINTER TO FCB CPI 0FFH ;SEQUENTIAL? JZ FR1 ;BRANCH IF YET LXI B,32 DAD B MOV M,A ;ELSE SET NR BYTE FIRST FR1: MVI C,26 CALL BDOS ;SET DMA POP D ;GET PTR TO FCB BACK MVI C,20 ;READ FUNCTION CALL BDOS ;DO THE READ POP H ;GET PTR TO RESULT AREA MOV M,A INX H MVI M,0 RET FWRITE: PUSH B PUSH H ;SEE FREAD FOR COMMENTS CPI 0FFH JZ FW1 LXI B,32 DAD B MOV M,A FW1: MVI C,26 CALL BDOS POP D MVI C,21 CALL BDOS POP H MOV M,A INX H MVI M,0 RET ENDIF ;FILESTUF PAGE IF RANDOMSTUF ;#######################################################; ; ; ; CP/M 2 RANDOM FILE READ/WRITE ; ; ; ;#######################################################; ; ; ON ENTRY ; HL = RANDOM RECORD NUMBER ; DE = BUFFER POINTER ; BC = FCB ADDRESS ; RANDOMREAD: CALL RANDOMSETUP ;GO SET UP ; ; RETURNS BUFFER ADDRESS SET, FCB ADDR IN DE ; MVI C,33 ;READ RANDOM RNDIO: CALL BDOS MOV C,A MVI B,0 POP H ;GET RETURN ADDRESS PUSH B ;PUSH RESULT PCHL RANDOMWRITE: CALL RANDOMSETUP MVI C,34 JMP RNDIO RANDOMSETUP: PUSH B ;PUSH FCB PTR PUSH H ;PUSH RECORD # MVI C,26 ;SET DMA FUNCTION CALL BDOS ;SET DMA POP D ;GET REC# POP H ;GET FCB PTR PUSH H ;SAVE IT LXI B,33 ;OFFSET TO RANDOM RECORD FIELD NUMBERS DAD B MOV M,E ;PUT RANDOM RECORD NUMBER INTO FCB INX H MOV M,D INX H MVI M,0 ;ZERO R3 POP D ;GET FCB ADDR BACK RET ENDIF PAGE IF CHARSTUF ; ; CMPCHR : COMPARE CHAR ARRAYS ; ; HL = ^STR1 ; DE = ^STR2 ; BC = LENGTH ; CMPCHR: LDAX D CMP M JNZ CMPCHR1 ;BRANCH IF NOT EQUAL INX D INX H DCX B MOV A,C ORA B JNZ CMPCHR LXI H,1 ;IF WE MAKE IT THROUGH THE LOOP ;PUSH TRUE XTHL PCHL ; ; NOT EQUAL, CLEAR CARRY TO INDICATE FALSE ; CMPCHR1: MOV A,C ;SAVE REGS FOR NON EQUALITY COMPARES ;THESE ARE LIMITED TO < 256 BYTES MOV C,L MOV B,H LXI H,0 XTHL ;PUT FALSE UNDER RET ADDR MOV H,B MOV L,C MOV C,A MVI B,0 ;AND RESTORE REGS MVI A,1 ORA A ;SET NZ FLAG FOR COMPLEX COMPARES PCHL ; ; NOW THE ROUTINES WHICH CALL CMPCHR ; CHREQ: EQU CMPCHR ;DOES ALL WE WANT TO DO CHRNE: CALL CMPCHR POP H ;JUST INVERT THE FLAG IF NOT EQUAL MOV A,L XRI 1 MOV L,A PUSH H RET ; ; COMPARE CHAR GREATER ; COMPARE AC : M ; CHRGT: CALL CMPCHR MOV A,C ORA B JZ CHRFALSE ;IF LENGTH = 0 THEN STRINGS ;WERE EQUAL (I.E. NOT GREATER) CHRGT1: LDAX D CMP M ;compare B:A JC CHRTRUE CHRFALSE: POP H ;FLUSH RESULT FROM CMPCHR LXI H,0 XTHL ;PUT FALSE ON STACK PCHL ;AND RETURN CHRTRUE: POP H ;FLUSH RESULT FROM CMPCHR LXI H,1 ;GET TRUE VALUE XTHL PCHL ;PUT IT ON STACK AND RETURN ; ; CHAR LESS THAN ; CHRLT: CALL CMPCHR MOV A,C ORA B JZ CHRFALSE ;IF EQUAL THEN NOT LESS CHRLT1: XCHG LDAX D CMP M ;COMPARE A:B JC CHRTRUE JMP CHRFALSE ; ; CHAR GREATER THAN OR EQUAL ; CHRGE: CALL CMPCHR RZ ;BRANCH IF EQUAL JMP CHRGT1 ; ; CHAR LESS THAN OR EQUAL ; CHRLE: CALL CMPCHR RZ ;RETURN IF EQUAL JMP CHRLT1 ENDIF ;CHARSTUF PAGE IF BITSTUF ; ; BIT MANIPULATION ROUTINES ; ; DE = VALUE ; HL = BIT NUMBER OR NUMBER OF BITS ; SHIFTLEFT: MOV A,L ORA A JZ SHEXIT DCR L ;DECREMENT NUMBER OF TIMES STC CMC MOV A,E RAL MOV E,A MOV A,D RAL MOV D,A JMP SHIFTLEFT SHEXIT: POP H PUSH D PCHL ; SHIFTRIGHT: MOV A,L ORA A JZ SHEXIT DCR L STC CMC MOV A,D RAR MOV D,A MOV A,E RAR MOV E,A JMP SHIFTRIGHT ; ; TSTBIT(EXPR,BIT#) ; ; DE = EXPR ; HL = BIT # ; TSTBIT: DAD H ;DOUBLE BIT # LXI B,BITTER DAD B MOV A,E ANA M MOV E,A INX H MOV A,D ANA M ORA E JNZ TRUEBIT FALSEBIT: POP H LXI D,0 PUSH D PCHL TRUEBIT: POP H LXI D,1 PUSH D PCHL BITTER: DW 0001H DW 0002H DW 0004H DW 0008H DW 0010H DW 0020H DW 0040H DW 0080H DW 0100H DW 0200H DW 0400H DW 0800H DW 1000H DW 2000H DW 4000H DW 8000H ; ; SETBIT(VAR,BIT#) ; SETBIT: DAD H LXI B,BITTER DAD B MOV C,M INX H MOV B,M XCHG MOV A,M ORA C MOV M,A INX H MOV A,M ORA B MOV M,A RET ; ; CLRBIT(VAR,BIT#) ; CLRBIT: DAD H LXI B,BITTER DAD B MOV A,M CMA MOV C,A INX H MOV A,M CMA MOV B,A XCHG MOV A,M ANA C MOV M,A INX H MOV A,M ANA B MOV M,A RET ENDIF ;BITSTUF PAGE IF CHAINSTUF ; ; PROGRAM CHAINING ROUTINE ; RTPCHAIN: ; ; FIRST STEP, SAVE THE FCB ADDRESS ; PUSH H ;COMES IN IN HL ; ; NOW FIND OUT WHERE THE USER PROGRAM STARTS ; IF TRS80 LHLD 4301H ELSE LHLD 101H ENDIF ;GET THE "ADDR" FROM THE INITIAL JMP INST ; ; NOW SET UP THE APPROPRIATE "OFFSET" TO READ FROM ; PUSH H ;AND SAVE IT MOV A,H DCR A ;BECAUSE FILE STARTS AT 100/4300 RLC ;MULTIPLY TIMES TWO ANI 07FH ;GET "RECORD NUMBER" POP D ;GET BUFFER ADDRESS POP H ;GET FCB ADDRESS AGAIN PUSH H ;SAVE FCB ADDR PUSH D ;SAVE BUFFER ADDR LXI D,32 DAD D ;POINT TO NR BYTE MOV M,A ;STUFF NR BYTE POP H ;GET I/O ADDRESS POP D ;GET FCB ADDRESS IF TRS80 LXI SP,4300H ELSE LXI SP,100H ENDIF ;LOAD UP TEMPORARY STACK POINTER PUSH D ;SAVE FCB ADDR ON NEW STACK PUSH H ;PUSH I/O ADDRESS RTPCHN1: POP D ;GET I/O ADDR PUSH D ;SAVE IT AGAIN MVI C,26 CALL BDOS ;SETDMA POP H ;GET I/O ADDR LXI D,128 DAD D POP D PUSH D PUSH H ;SAVE NEW DMA ADDRESS MVI C,20 CALL BDOS ;GO READ A SECTOR CPI 1 JNZ RTPCHN1 ;GO DO AGAIN IF NOT END OF FILE POP H ;FLUSH BUFFER ADDRESS POP H ;FLUSH FCB ADDRESS IF TRS80 JMP 4300H ELSE JMP 100H ;GO START PROGRAM ENDIF ENDIF ;CHAINSTUF SMALLRTP EQU $ ;SIZE OF INTEGER/BOOL/CHAR/FILE ONLY RTP PAGE $-print if bcd $+print ;-----------------------------------------------; ; FIXED POINT ARITHMETIC PACKAGE ; ; ORIGINALLY WRITTEN BY MGL DURING ; ; FEBRUARY OF 1977 ; ; SUBSEQUENTLY USED IN SIMPLE 2.0 ; ; HELP 1.0 FOR NORAND ; ; SIMS INVENTORY PACKAGE IN 1978 ; ; AND NOW IN PASCAL/MT IN OCTOBER 1979 ; ;-----------------------------------------------; ; REV 5 21-OCTOBER-79 MGL ; ; FOR PASCAL/MT 2.5 ; ; WITH REV 5 NOW ARE 4 DECIMAL PLACES ; ;-----------------------------------------------; ; PAGE ; PACKAGE IS LOADED VIA DDT TO MAKE COMPLETE PROGRAM ; ; ; JUMP TABLE ; ; ; ; ; FIXED POINT ARITHMETIC PACKAGE PAGE ; ; ; ALL NUMBERS ARE 2*FPLEN DIGITS LONG ; ; ALL NUMBERS ARE FPLEN+1 BYTES LONG IN THE FORMAT: ; ; AABBCC...ZZ** WHERE AA-ZZ ARE PAIRS OF DIGITS ; AND ** IS A SIGN 00=POS,FF=NEG ; ; ; ROUTINES INCLUDED: ; ; FPADD ; FPSUB ; FPMUL ; FPDIV ; FPC2D ; FPEDIT ; ; TO CALL: LXI D,SRC ; LXI H,SRC2 ; LXI B,DEST ; CALL FP(OPERATION) ; ; WHERE OPERATION IS: ADD,SUB,MUL,DIV ; ; AND RESULT IS: DEST=SRC OP SRC2 ;--------------------------------------------------------------; PAGE ; ; ; ; FIXED POINT SYSTEM EQUATES ; ; FPLEN: EQU 9 ;FOR 18 (14,4) DIGIT NUMBERS PAGE ; ; ; ; ; FIXED POINT ADDITION ROUTINE ; FPADD: MVI A,FPLEN STA XLENGTH ;INITIAL VALUE PUSH B ;SAVE RESULT POINTER LDAX D CMP M ;ARE THE SIGNS THE SAME? JZ FPADD1+2 ;IF SO THEN DO THE OPERATION NORMALLY DCX D DCX H LDA XLENGTH MOV B,A CALL FPCMPR ;COMPARE THE ARGUMENTS JNC FPADD2 ;IF SRC <= SRC2 THEN REGS ARE OK XCHG FPADD2: JMP FPSUB1 ;GO DO IT AS A SUBTRACT ; ; FPADD1: INX D INX H POP B ;RESTORE RESULT POINTER LDAX D ;GET SIGN OF FIRST OPERAND STAX B ;SAVE IT IN THE RESULT FPADD5: EQU $ DCX B FPADD4: EQU $ ;USED BY FPMUL PUSH B MOV B,H ;MOVE POINTER TO BC SO WE CAN USE XTHL MOV C,L LDA XLENGTH MOV L,A ;SET UP LENGTH OF ARGUMENTS DCX D ;RESET PONTER TO ELEMENT DCX B STC CMC ;CLEAR CARRY ; FPADD3: LDAX B MOV H,A ;SAVE VALUE LDAX D ADC H DAA XTHL ;GET DESTINATION POINTER MOV M,A DCX H XTHL DCX B DCX D DCR L ;ARE WE THROUGH? JNZ FPADD3 POP B ;FLUSH STACK RET ;DONE, RETURN PAGE ; ; ; FIXED POINT SUBTRACTION ROUTINE ; ; ; ; ; ; ; FPSUB: MVI A,FPLEN STA XLENGTH PUSH B ;SAVE DEST POINTER LDAX D CMP M ;SIGNS THE SAME? JZ FPSUB4 ;IF SO THE NORMAL OPERATION DCX D DCX H LDA XLENGTH MOV B,A CALL FPCMPR JNC FPADD1 XCHG INX D INX H ;IF WE HAD TO SWITCH GET NEW SIGN POP B LDAX D CMA STAX B JMP FPADD5 ; ; ; IF SIGNS ARE THE SAME AND A0 FLAG ; ; WE MUST FLUSH THE RESULT OF OUR SUBTRACT FROM THE ; STACK BEFORE WE LEAVE ; LXI H,10 DAD SP SPHL ;FLUSH IT LHLD RCOMPRET PCHL REALEQ: POP H SHLD COMPRET CALL RCOMPX LDA RZERO ORA A JNZ RFALSE RTRUE: LXI H,1 PUSH H LHLD COMPRET PCHL RFALSE: LXI H,0 PUSH H LHLD COMPRET PCHL REALNE: POP H SHLD COMPRET CALL RCOMPX LDA RZERO ORA A JNZ RTRUE JMP RFALSE REALGT: POP H SHLD COMPRET CALL RCOMPX LDA RZERO ORA A JZ RFALSE LDA RSIGN ORA A JNZ RFALSE JMP RTRUE REALLT: POP H SHLD COMPRET CALL RCOMPX LDA RZERO ORA A JZ RFALSE LDA RSIGN ORA A JNZ RTRUE JMP RFALSE REALGE: POP H SHLD COMPRET CALL RCOMPX LDA RZERO ORA A JZ RTRUE LDA RSIGN ORA A JNZ RFALSE JMP RTRUE REALLE: POP H SHLD COMPRET CALL RCOMPX LDA RZERO ORA A JZ RTRUE LDA RSIGN ORA A JNZ RTRUE JMP RFALSE PAGE ; ; READ REAL - HL = ADDR OF REAL NUMBER DESTINATION BUFFER ; RREAL: SHLD REALPTR ;SAVE POINTER TO REAL DESTINATION ; ; FIRST BLANK THE BUFFER ; LXI H,RBUF MVI B,32 ;SIZE OF BUFFER RR1: MVI M,' ' INX H DCR B JNZ RR1 ;BLANK THE BUFFER ; ; NOW READ IN THE TEXT FROM THE CONSOLE ; LXI H,RBUF RR2: PUSH H CALL GETCHR ;READ A CHAR, COMES BACK ON STACK POP B MOV A,C POP H CPI ' ' ;FIRST CHECK FOR A TERMINATOR JZ RRXIT CPI 0DH JZ RRXIT CPI ',' JZ RRXIT CPI '.' ;. IS VALID JZ RRVALID CPI '-' JZ RRVALID ;- IS VALID ; ; NOW CHECK FOR VALID DIGIT ; CPI '0' JC RR2 CPI '9'+1 JNC RR2 ;IF NONE OF THE ABOVE IGNORE RRVALID: PUSH H ;SAVE BUFFER POINTER PUSH PSW ;SAVE CHARACTER LDA IOADDR ;IF <> 0FFFFH THEN DON'T ECHO CPI 0FFH JNZ RNOECHO LDA IOADDR+1 CPI 0FFH JNZ RNOECHO POP PSW PUSH PSW MOV L,A ;SET UP FOR CHRW PUSH H ;PUT CHAR ON THE STACK CALL CHRW ;ECHO THE CHARACTER RNOECHO: POP PSW ;GET CHARACTER BACK POP H ;GET POINTER BACK MOV M,A ;STUFF IN BUFFER INX H JMP RR2 ; ; NOW TERMINATOR FOUND, SAVE TERM AND ; CALL C2D ; RRXIT: STA RRTERM MOV L,A LDA IOADDR CPI 0FFH JNZ RNOECHO2 LDA IOADDR+1 CPI 0FFH JNZ RNOECHO2 PUSH H CALL CHRW ;ECHO TERMINATION CHARACTER RNOECHO2: LXI H,RBUF XCHG LHLD REALPTR LXI B,FPLEN DAD B XCHG CALL FPC2D ;CONVERT IT LDA RRTERM RET ;AND EXIT BACK TO PROGRAM BCDRTP EQU $ ;END OF BCD-PACKAGE endif ;BCD PAGE $-print if bfloat $+print IF BFLOAT AND HARDWARE ; ; 9511 REAL NUMBER ROUTINES ; REALEQ: POP B ;SAVE RET ADDRESS CALL RSUB POP H ;FLUSH THE RESULT OF THE SUBTRACT POP H IN ACTRL ;GET STATUS ANI 20H ;IS TOP OF STACK ZERO? JZ FALSE1 ;NO LXI H,1 JMP DONE1 FALSE1: LXI H,0 DONE1: PUSH H PUSH B RET REALNE: POP B ;SAVE RET ADDRESS CALL RSUB POP H ;FLUSH THE RESULT OF THE SUBTRACT POP H IN ACTRL ;GET STATUS ANI 20H ;IS TOP OF STACK ZERO? JNZ FALSE2 ;YES, SO GO TO FALSE LXI H,1 ;NO, SO NOT EQUAL TEST IS TRUE JMP DONE2 FALSE2: LXI H,0 DONE2: PUSH H PUSH B RET REALGT: POP B ;SAVE RET ADDRESS CALL RSUB POP H ;FLUSH THE RESULT OF THE SUBTRACT POP H IN ACTRL ;GET STATUS MOV L,A ANI 40H ;IS TOP OF STACK NEGATIVE? JNZ FALSE3 ;YES, SO A IS NOT GREATER THAN B MOV A,L ANI 20H ;IS TOP OF STACK ZERO? JNZ FALSE3 ;YES, SO A IS NOT GREATER THAN B LXI H,1 ;NO, SO A > B IS TRUE JMP DONE3 FALSE3: LXI H,0 DONE3: PUSH H PUSH B RET REALLT: POP B ;SAVE RET ADDRESS CALL RSUB POP H ;FLUSH THE RESULT OF THE SUBTRACT POP H IN ACTRL ;GET STATUS ANI 40H ;IS TOP OF STACK NEGATIVE? JZ FALSE4 ;NO, SO A IS NOT < B LXI H,1 ;YES, SO A < B IS TRUE JMP DONE4 FALSE4: LXI H,0 DONE4: PUSH H PUSH B RET REALGE: POP B ;SAVE RET ADDRESS CALL RSUB POP H ;FLUSH THE RESULT OF THE SUBTRACT POP H IN ACTRL ;GET STATUS MOV D,A ANI 40H ;IS TOP OF STACK NEGATIVE? JNZ TESTEQ1 ;A IS'NT > B, IS IT EQUAL? TRUE1: LXI H,1 JMP DONEGE TESTEQ1: MOV A,D ANI 20H ;IS A = B? JZ FALSEGE ; JMP TRUE1 FALSEGE: LXI H,0 DONEGE: PUSH H PUSH B RET REALLE: POP B ;SAVE RET ADDRESS CALL RSUB POP H ;FLUSH THE RESULT OF THE SUBTRACT POP H IN ACTRL ;GET STATUS MOV D,A ANI 40H ;IS TOP OF STACK NEGATIVE? JZ TESTEQ2 ;A IS'NT < B, IS IT EQUAL? TRUE2: LXI H,1 JMP DONELE TESTEQ2: MOV A,D ANI 20H ;IS A = B? JZ FALSELE ; JMP TRUE2 FALSELE: LXI H,0 DONELE: PUSH H PUSH B RET ENDIF IF BFLOAT AND (NOT HARDWARE) REALEQ: POP H SHLD RNDRET CALL SWRSUB POP H POP D MOV A,L ORA H JNZ RCFALSE JMP RCTRUE REALNE: POP H SHLD RNDRET CALL SWRSUB POP H POP D MOV A,L ORA H JZ RCFALSE JMP RCTRUE REALGT: POP H SHLD RNDRET CALL SWRSUB POP H POP D MOV A,L ORA A JM RCFALSE ORA H JZ RCFALSE JMP RCTRUE REALLT: POP H SHLD RNDRET CALL SWRSUB POP H POP D MOV A,L ORA A JP RCFALSE JMP RCTRUE REALGE: POP H SHLD RNDRET CALL SWRSUB POP H POP D MOV A,L ORA A JM RCFALSE JMP RCTRUE REALLE: POP H SHLD RNDRET CALL SWRSUB POP H POP D MOV A,L ORA A JM RCTRUE ORA H JZ RCTRUE RCFALSE: LXI H,0 RCXIT: PUSH H LHLD RNDRET PCHL RCTRUE: LXI H,1 JMP RCXIT ENDIF PAGE RREAL: ; ;INPUTS: POINTER TO REAL IN HL ; ;READS A DECIMAL NUMBER FROM THE CONSOLE AND FILLS THE BUFFER. ;THIS STRING IS CONVERTED TO A FLOATING POINT REAL NUMBER BY ;FLTIN AND IS STORED IN THE ADDRESS SPECIFIED ON THE STACK. ; ; THE RESULT IS STORED IN 4 CONSECUTIVE ; LOCATIONS IN MEMORY POINTED TO BY DE. ; (THE SIGN AND EXP. IS IN LOW ADDRESS). ; AFTER THE CONVERSION ROUTINE, IF AN ERROR IS ; DETECTED IN THE DATA STREAM, CARRY IS SET AND ; REG. A CONTAINS THE ERROR CODE. THE ERROR ; CODE IS AS FOLLOWS: ; 1 = ILLEGAL CHARACTER ; 2 = OVERFLOW ; 3 = UNDERFLOW ; REG. A CONTAINS THE LAST CHARACTER READ ; HL POINTS TO THE LAST CHARACTER READ ; DE POINTS TO THE LOCATION AFTER THE LSB OF ; THE FLOATING POINT NUMBER ; @RREAL: XCHG ;POINTER TO REAL IN DE PUSH D ;SAVE COPY OF D FOR LOOP IF BAD INPUT @RREAL5: LXI H,LEN MVI M,79 ;LENGTH OF BUFFER = 79 CALL INPUT ;INPUT DECIMAL NUMBER LXI H,LEN MOV M,A ;LEN = LENGTH OF INPUT STRING MOV C,A ;LENGTH OF STRING IN REGISTER C INR C MVI B,0 PUSH H ;SAVE POINTER TO STRING DAD B ;HL POINTS BYTE FOLLOWING LAST CHAR MVI M,' ' ;PUT A BLANK TO MARK END OF STRING POP H INX H ;HL POINTS TO FIRST CHARACTER MOV C,M ;FIRST CHAR INTO C INX H ;HL POINTS TO SECOND CHARACTER POP D ;GET POINTER TO REAL FOR FLTIN PUSH D ;SAVE FOR REPEAT IF NECY CALL FLTIN CPI 1 ;IS STRING AN INVALID INTEGER? JNZ OFLOW ;NO LXI H,MSG1 ;YES JMP WCALL OFLOW: CPI 2 ;DID OVERFLOW OCCUR? JNZ UFLOW ;NO LXI H,MSG2 ;YES JMP WCALL UFLOW: CPI 3 ;DID UNDERFLOW OCCUR? JNZ DONE ;NO, SO NO ERRORS DETECTED. LXI H,MSG3 WCALL: ; PUSH H ;ADDRESS OF MESSAGE ON STACK ; MVI H,0 ; MVI L,8 ;NUMBER OF BYTES ; PUSH H ;PUSH BYTES ; WCHR ;WRITE OUT ERROR MESSAGE JMP @RREAL5 ;TRY AGAIN FOR A VALID INPUT. DONE: POP H ;THROW AWAY EXTRA COPY OF REAL PTR LDA RTERMCH ;GET TERMINATOR CHARACTER RET ; ; ;**************************************************************** ; ; INPUT - ; ; ROUTINE TO ACCEPT VARIABLE LENGTH INPUT FROM THE CONSOLE ; ; INPUT REQUIRED: ; H/L REGISTER PAIR MUST CONTAIN THE A(CALLERS INPUT BUFFER) ; THE 1ST BYTE OF THE BUFFER MUST CONTAIN THE L(CALLERS INPUT BUFFER) ; ; OUTPUT GENERATED: ; THE CALLERS BUFFER WILL BE FILLED WITH CHARACTERS FROM THE ; CONSOLE UNTIL THE BUFFER IS FULL OR A CR, ' ' OR ',' IS ENTERED ; ; A RUBOUT WILL CAUSE THE PREVIOUS ENTRY TO BE DELETED AND ; THE CURSOR WILL BE BACKED UP! ; ; 'A' REGISTER WILL CONTAIN THE NUMBER OF CHARACTERS ENTERED ; ; THE LENGTH BYTE WILL REMAIN UNCHANGED. ; ;****************************************************************** INPUT: MVI A,0 PUSH PSW ;INITIALIZE INPUT COUNT ON THE STACK. MOV D,M ;'D' REGISTER = ORIGINAL L(CALLERS BUFFER). MOV B,M ;'B' REGISTER = ORIGINAL L(CALLERS BUFFER) WORK CNT. INX H ;H/L = A(CALLERS BUFFER). XCHG ;D/E=A(CALLERS BUFFER), 'H' REG.=L(CALLERS BUFFER). IN10: PUSH B ;SAVE ORIG. L(BUFFER). PUSH H ;SAVE L(BUFFER). PUSH D ;SAVE A(BUFFER). LXI H,CHAR CALL RCHR ;GET CHARACTER FROM CONSOLE POP D ;RESTORE POP H ;RESTORE POP B ;RESTORE LDA CHAR ;GET CHARACTER FROM MEM CPI CR ;IS THE CHARACTER A CARRIAGE RETURN? JZ IN40 ;YES, DONE. CPI ' ' JZ IN40 CPI ',' JZ IN40 CPI RUBOUT ;IS THE CHARACTER A RUBOUT? JZ IN20 ;YES, DELETE PREVIOUS ENTRY. STAX D ;NO, PUT CHARACTER INTO CALLERS BUFFER. INX D ;POINT TO NEXT LOCATION. DCR H ;DECREMENT 'BYTES TO ACCEPT' COUNT. XTHL INR H ;INCREMENT 'BYTES RECEIVED' COUNT. XTHL MOV A,H ;IF COUNT CPI 0 ;-IS NOT ZERO, JNZ IN10 ;--CONTINUE TO ACCEPT CHARACTERS. JMP IN40 ;OTHERWISE, MAX COUNT ACCEPTED.LEAVE. ; ; IF RUBOUT AND 'H' NE 'B', DECREMENT A(BUFFER) AND L(BUFFER) ; AND INCREMENT L(BUFFER). OTHERWISE JUST OUTPUT A CRLF! ; IN20: MOV A,B CMP H ;IS CURRENT COUNT EQUAL TO ORIG.? JNZ IN30 ;NO, OK TO DECREMENT. JMP IN10 ;GO FOR ANOTHER CHARACTER. IN30: DCX D ;DECREMENT A(BUFFER). INR H ;INCREMENT L(BUFFER). XTHL DCR H ;DECREMENT 'BYTES RECEIVED' COUNT. XTHL IN35: MVI L,BS MVI H,0 PUSH H ;PUT BACKSPACE ON STACK FOR OUTPUT CALL CHRW ;WRITE CHARACTER JMP IN10 ;GO FOR ANOTHER CHARACTER. IN40: STA RTERMCH ;SAVE TERMINATOR CHARACTER POP PSW ;GET 'BYTES RECEIVED' COUNT. RET ;RETURN TO CALLER. PAGE IF HARDWARE AND (NOT BCD) ; ; ; FLTIN ; ;PARAMETERS: DE CONTAINS THE POINTER TO THE REAL NUMBER ; HL POINTS TO THE LENGTH BYTE. ;THIS STRING IS CONVERTED TO A FLOATING POINT REAL NUMBER BY ;FLTIN AND IS STORED IN THE ADDRESS SPECIFIED ON THE STACK. ; FLTIN: ; SHLD CMPTR ;SAVE PTR TO REAL IN CMPTR PUSH D ;SAVE PTR TO REAL LXI H,DTAREA ;CLEAR DATA AREA MVI B,DTALEN CALL CLEAR XCHG ;CLEAR RESULT MVI B,4 CALL CLEAR ; ; IF CHAR = + OR -, SIGN = CHAR. READ NEXT CHAR. ; LXI H,SIGN CALL CKSIGN MOV A,C POP D ;RESTORE DESTINATION POINTER PUSH D ;RESTORE D ON STACK CALL GTINT ;READ INTEGER PORTION CPI 1 JZ FIABORT ; ; IF INTEGER PORTION OVERFLOWS, LSD'S ARE IGNORED, ; BUT CNT2 SHOWS HOW MANY DIGITS WERE SCANNED ; AFTER OVERFFOW OCCURRED. THE DECIMAL EXPONENT ; MUST BE ADJUSTED BY THIS NUMBER ; LDA CNT2 STA EXP1 ; ; READ FRACTION PART IF PRESENT ; MOV A,C ;A=CHARACTER CPI '.' ;DECIMAL POINT? JNZ FIN10 ;NO. CALL NXCHR ;READ 1ST DIG. OF FRACTION CALL GTINT ;READ FRACTION CPI 1 ;ILLEGAL CHAR? JZ FIABORT ;YES. ABORT. ; ; X IS NOW AN INTEGER THAT REPRESENTS THE ; FRACTION DIGITS CONCATENATED ONTO THE INTEGER ; DIGITS. EXP MUST BE ADJUSTED BY SUBTRACTING ; THE NUMBER OF DIGITS READ BEFORE OVERFFOW. ; LDA EXP1 ;EXP1=EXP1-CNT1 LXI H,CNT1 SUB M STA EXP1 ; ; THE NUMBER READ SO FAR = X * 10**EXP1. ; FIN10: XRA A ;CLEAR ERCODE STA ERCODE CALL DFLOAT ; ; LOOK FOR E FIELD ; MOV A,C ;A=CHAR. CPI 'E' JNZ FIN30 ;NO E FIELD CALL NXCHR LXI H,SEXP ;LOOK FOR SIGN OF EXP CALL CKSIGN ; ; E MUST BE FOLLOWED BY A DIGIT ; MOV A,C CALL VALDIG JC FIN20 ;VALID DIGIT ; ; ILLEGAL CHAR IN EXP. ; MVI A,1 STA ERCODE JMP FIABORT ; FIN20: LXI D,EXP ;RESULT OF GTINT TO EXP CALL GTINT LDA ERCODE ;ABORT IF ANY ERROR ORA A JNZ FIABORT ; ; IF SEXP = '-', EXP = -EXP ; LDA SEXP CPI '-' JNZ FIN30 ;POS EXP LXI D,EXP CALL DCOMPL ;COMPLEMENT EXP ; ; ADJUST EXP FOR DECIMAL POINT OF INTG ; FIN30: LXI D,EXP LXI H,EXP1 CALL ADDQS ;EXP=EXP+EXP1 ; ; IF EXP > 18, OVERFLOW ; XCHG ;HL = EXP LXI D,P18 ;GET +18 CALL DPCMP ;EXP-(-18). A=STAT ANI SSTAT JNZ FIOVFL ;YES, OVERFLOW ; ; IF EXP < -18, UNDERFLOW ; LXI H,M18 ;GET -18 LXI D,EXP CALL DPCMP ;COMPARE 18 - EXP. A=STAT ANI SSTAT JNZ FIUFL ;EXP < -18 UNDERFLOW ; ; MULTIPLY OR DIVIDE DIGITS BY POWER OF 10. ; (SINCE -32 < EXP < 32, WE CAN USE JUST ; TH LAST BYTE OF EXP.) ; LDA EXP+3 ;SAVE SIGN OF EXP ORA A ;AND STATUS PUSH PSW ; ; SET A = ABS(EXP) ; JP FIN40 CMA ;COMPLEMENT A INR A ;NEGATE A ; ; USE A AS AN INDEX INTO TABLE OF POWERS OF 10 ; FIN40: LXI H,PWR10 CALL TINDEX ;HL = HL + 4*A POP PSW ;GET SIGN OF EXP POP D ;ADR OF RESULT PUSH D JM FIN50 ;NEG EXP ; ; POSITIVE EXP. MULTIPLY BY POWER OF 10 ; CALL FPMUL ;M(DE)=M(DE)*M(HL) ANI ECFIELD JZ FIN60 ;NO ERROR ; ; OVERFLOW ; FIOVFL: MVI A,2 LXI H,FLMAX ;SET X=MAX FLT. PT. # JMP FIU10 ;SHARE PART OF UNDERFLOW CODE ; ; NEGATIVE EXP. DIVIDE BY POWER OF 10 ; FIN50: CALL FPDIV ANI ECFIELD JNZ FIUFL ;UNDERFLOW ; ; ADJUST SIGN BIT ; FIN60: MVI B,0 LDA SIGN CPI '-' JNZ FIN70 ;POSITIVE MVI B,80H ;NEGATIVE FIN70: POP D ;ADR OF RESULT PUSH D LDAX D ;SIGN, EXP BYTE ORA B ;OR IN SIGN BIT STAX D ; ABORT FROM FIN FIABORT: LDA ERCODE ;PUT ERCODE INTO A FOR RETURN POP D ;RESTORE STACK PTR RET ; ; UNDERFLOW ; FIUFL: MVI A,3 LXI H,ZERO ;SET X=0 ; ; CODE SHARED BY OVERFLOW ROUTINE ; FIU10: STA ERCODE POP D ;ADR OF X CALL COPY4 ;COPY 4 BYTE & RETURN STC ;SET CARRTY TO INDICATE ERROR LDA ERCODE ;GET ERCODE BACK RET ;RETURN TO CALLER ; ; ; THIS ROUTINE CONCATENATES DIGITS FROM THE ; INPUT STRING ONTO THE INTEGER AT M(DE) UNTIL ; A NON-DIGIT CHARACTER IS ENCOUNTERED. ; IF INTEGER OVERFLOW OCCURS, THE INTEGER IS ; RESTORED TO ITS VALUE BEFORE OVERFLOW ; AND SCANNING CONTINUES. ; ; IF ERCODE IS NON-ZERO ON ENTRY, THE INTEGER IS ; NOT ALTERED, BUT THE SCANNING DOES TAKE PLACE. ; ; INPUT: C= 1ST CHAR OF INPUT STRING ; DE = ADR OF INTEGER ; SUBROUTINE NXCHR FURNISHES INPUT CHARS ; OUTPUT: DE = ADR OF INTEGER ; CNT1 = # OF DIGITS READ BEFORE OVERFLOW ; CNT2 = # OF DIGITS AFTER OVERFLOW ; C = 1ST CHAR. AFTER INTEGER ; ERCODE = 0 IF NO ERROR ; = 1 IF ALPHA CHAR OTHER THAN E ; = 2 IF INTEGER OVERFLOW ; A = ERCODE ; TEMPORARY STORAGE: OLDINT, DIGT ; GTINT: XRA A ;CLEAR COUNTS STA CNT1 STA CNT2 ; ; IF ERR, SCAN OVER DIGITS ; LDA ERCODE ORA A JNZ GTI30 ; ; BEGIN LOOP. EXIT IF NON-DIGIT GTI10: MOV A,C CALL VALDIG JNC GTI30 ;NOT DIGIT. EXIT. ; ; SAVE VALUE OF INTEGER IN OLDINT. ; XCHG LXI D,OLDINT CALL COPY4 ; XCHG CALL MPY10 ;M(DE) = M(DE)*10 ANI ECFIELD JNZ GTI20 ;OVERFLOW. EXIT LOOP MOV A,C ;GET CHAR SUI '0' ;CONVERT TO BINARY LXI H,DIGT MOV M,A CALL ADDQS ;M(DE) = M(DE) + DIGT LXI H,CNT1 ;INC. # OF DIGITS BEFORE OVFL INR M CALL NXCHR JMP GTI10 ;REPEAT LOOP ; END LOOP ; ; OVERFFOW. RESTORE OLD VALUE & SET ERCODE ; GTI20: MVI A,2 STA ERCODE LXI H,OLDINT CALL COPY4 ; GTI30: LXI H,CNT2 ; ; BEGIN LOOP TO SCAN OVER DIGITS AFTER OVERFLOW ; GTI40: MOV A,C CALL VALDIG JNC GTI50 ;NOT A DIGIT. EXIT LOOP. INR M ;INC. CNT2 CALL NXCHR JMP GTI40 ; ; CHECK FOR ALPHA OTHER THAN E ; GTI50: LXI H,ERCODE CALL ALPHA JNC GTI60 ;NOT ALPHA. OK. CPI 'E' JZ GTI60 ;'E', OK MVI M,1 ;ILL. CHAR. ERCODE=1 ; GTI60: MOV A,M ;A=ERCODE RET ELSE REALFROMFLOAT ;USE S/W ROUTINE ENDIF ; ; PWREAL: IF AUTOENGR LDA CONFLAG ORA A JZ WREAL ENDIF MVI A,1 STA PRINTFLAG JMP WREAL1 WREAL: XRA A STA PRINTFLAG WREAL1: ; ; SUBROUTINE FOR DECIMAL TO FLOATING ; POINT AND FLOATING POINT TO DECIMAL ; CONVERSIONS. ; ; JUNE 22, 1979 NJL ; UPDATED SEPT 29, 1979 BY MGL/NJL ; ; THIS ROUTINE CONVERTS THE FLOATING POINT ; NUMBER AT M(DE) INTO AN N-DIGIT BASE 10 ; MANTISSA PLUS A 2-DIGIT EXPONENT ; IT OUTPUTS ASCII CHARACTERS TO THE ; USER-SUPPLIED ROUTINE OUTCHR ; INPUT: C = # OF DIGITS IN MANTISSA (<7) ; DE = ADR OF NUMBER TO BE CONVERTED ; TEMPORARY STORAGE: PWR, SEXP, LOCLX, PROD ; MOV A,B CPI 0FFH JNZ WIDTH$NON$FF MVI B,10 WIDTH$NON$FF: MOV L,B MVI H,0 SHLD WIDTH ;SAVE DATA PRODUCED BY COMPILER MOV L,C MOV A,C CPI 0FFH JNZ DEC$NON$FF MVI L,0 DEC$NON$FF: SHLD DEC LXI H,2 DAD SP XCHG ;DE @ FLOATING PT NUMBER LXI H,BUFF+10 SHLD OUTPTR LXI H,BUFF MVI B,32 BLANKBUFF: MVI M,' ' INX H DCR B JNZ BLANKBUFF MVI C,7 ;C CONTAINS NUMBER OF DIGITS CALL FLTOUT ;CONVERT REAL NUMBER TO ASCII FORMATIT ;FORMAT NUMBER BASED UPON DEC AND WIDTH AND ;PRINT IT OUT POP H POP D POP D ;CLEAN UP STACK PCHL ;RETURN PAGE ; ; FLOATING POINT CONVERSION, INTERNAL TO ASCII ; ; IF HARDWARE AND (NOT BCD) FLTOUT: XCHG ;HL POINTS TO X LXI D,LOCLX CALL COPY4 ;COPY X TO LOCAL STORAGE PUSH B ;SAVE C CALL TEQ0 ;MANT=0 JNZ FLO05 ;NO ; ; MANT=0. PRINT 0.0 & SKIP C+3 SPACES ; MVI C,'0' CALL OUTCHR MVI C,'.' CALL OUTCHR MVI C,'0' CALL OUTCHR POP B ;RETRIEVE # OF CHARS IN MANT MOV A,C ADI 3 MOV B,A ;# OF SPACES ; ; OUTPUT 'B' SPACES ; ALTERS A,B, & C SPACES: MVI C,' ' CALL OUTCHR DCR B JNZ SPACES RET ; FLO05: MVI A,'+' ;CLEAR SEXP STA SEXP ; ; OUTPUT SIGN THEN SET X=ABS(X) ; CALL OUTSGN MVI C,'.' ;OUTPUT DP CALL OUTCHR ; ; IF X=0, SET PWR = 0. THERWISE SET PWR=18 ; LXI H,PWR MVI M,0 CALL TEQ0 ;TEST M(DE)=0 JZ FLO70 ;X=0 ; MVI M,18 ;X.NE.0 SET PWR=18 ; ; TEST FOR NEG. EXP. ; LXI H,PWR10 ;HL POINTS TO 1.0 CALL FLCMP ;TEST M(DE) - M(HL) ANI SSTAT JNZ FLO40 ;X < 1.0 ; ; POSITIVE EXPONENT ; ; BEGIN LOOP TO SEARCH TABLE OF POWERS OF 10 ; FLO10: LXI H,PWR10 LDA PWR CALL TINDEX ;HL = ADR(PWR10(PWR)) CALL FLCMP ;TEST X - 10**PWR MOV B,A ;SAVE A ANI SSTAT ;TEST SIGN JZ FLO20 ;X.GE. 10**PWR. EXIT LOOP LXI H,PWR ;DEC. PWR DCR M JMP FLO10 ; ; NOW 10**PWR.LE.X.LT.10**(PWR+1) ; OR .1.LE.X/10**(PWR+1) TO MAKE .1.LE.X.LT.1. ; BECAUSE OF TRUNCATION ERRORS. ; 10**P / 10**(P+1) < .1 ; IF X = 10**PWR, SET X = .1 TO CORRECT FOR THIS ; FLO20: MOV A,B ;RETRIEVE APU STAT ANI ZSTAT ;X = 10**PWR? JZ FLO25 ;NOT = LXI H,TENTH ;SET M(DE) = 1 CALL COPY4 JMP FLO30 ;NO NEED TO DIVIDE ; FLO25: INX H ;SET H = ADR(10**(PWR+1)) INX H INX H INX H CALL FPDIV ;X = X/10**(PWR+1) ; ; NOW .1.LE.X.LT.1. ; FLO30: LXI H,PWR ;INC. POWER INR M JMP FLO60 ; ; NEGATIVE EXP ; 10**(-19).LT.X.LT.1. ; ; BEGIN LOOP TO SEARCH TABLE ; FLO40: PUSH D XCHG ;HL=ADR(X) LXI D,PROD CALL COPY4 ;PROD = X LXI H,PWR10 LDA PWR CALL TINDEX ;HL = ADR(PWR10(PWR)) CALL FPMUL ;PROD = X*10**PWR LXI H,PWR10 ;HL = ADR(1.0) CALL FLCMP ;TEST PROD-1 ANI SSTAT JNZ FLO50 ;PROD < 1. EXIT LOOP LXI H,PWR ;DEC PWR DCR M POP D JMP FLO40 ; FLO50: POP D ;D=ADR(X) LXI H,PROD CALL COPY4 ;X = X* 10**PWR ; ; NOW .1.LE.X.LT.1 & PWR = POWER OF 10 ; IF PWR .NE. 0, SET SEXP = '-' ; LDA PWR ORA A JZ FLO60 ;PWR=0 MVI A,'-' STA SEXP ; ; COMMON CODE FOR POS. & NEG. EXPONENTS ; IN EITHER CASE .1.LE.X.LT.1. ; ROUND UP BY ADDING 5 TO THE N+1ST DIGIT ; POSITION. ; FLO60: POP B ;RETRIEVE C = # OF DIGITS PUSH B PUSH D LXI D,PROD LXI H,HALF CALL COPY4 ;PROD = .5 MOV A,C LXI H,PWR10 CALL TINDEX ;HL = ADR(PROD) CALL FPDIV ;FLOATING DIVIDE XCHG POP D ;DE = ADR(X) CALL FPADD ;X = X + .5/10**N ; ; ROUND UP MAY CAUSE X>1 ; E.G. 997 + .005 = 1.002 ; IF SO, ADJUST EXP ; LXI H,PWR10 CALL FLCMP ;TEST X - 1 ANI SSTAT JNZ FLO70 ;X < 1 LXI H,TENTH ;X.GE.1. SET X = .1 CALL COPY4 LXI H,PWR ;INC. OR DEC PWR INR M ;ASSUME + EXP LDA SEXP CPI '-' JNZ FLO70 ;EXP IS + DCR M ;- EXP. DEC. DCR M ; ; BINARY EXP IS BETWEEN -3 & 0. SHIFT MANTISSA ; LEFT INTO THE EXP BYTE 0-3 TIMES SO THAT ; THE MANTISSA CAN BE TREATED AS A FIXED ; POINT NUMBER WHOSE BINARY POINT IS BETWEEN ; BITS 2 & 3 OF THE MS BYTE ; FLO70: LDAX D ;A=BIN. EXP. ADI 3 ;SHIFT COUNT = EXP+3 ANI 7FH ;MASK OUT SIGN MOV C,A XRA A ;SET MSBYTE=0 STAX D CALL LSHQ ;LEFT SHIFT EXP+3 TIMES ; ; CONVERT MANTISSA TO DECIMAL STARTING WITH ; MSD. WHEN MANT. IS MULTIPLIED BY 10, THE ; INTEGER PORTION WILL OVERFLOW INTO BITS 7-4 ; OF THE MS BYTE ; FLO80: CALL MPY10 ;X = X*10 (INTEGER MUL) LDAX D ;A = MSBYTE RRC ;RIGHT JUSTIFY RRC RRC ANI 0FH ADI '0' ;CONV. TO ASCII MOV C,A CALL OUTCHR ;OUTPUT DIGIT LDAX D ;MASK OUT INTG. PART ANI 7 STAX D POP B ;C = # OF DIGITS IN MANT. DCR C PUSH B JNZ FLO80 ; POP B ;RESTORE STACK MVI C,'E' CALL OUTCHR ;OUTPUT SIGN OF EXP LDA SEXP MOV C,A CALL OUTCHR ;OUTPUT SIGN OF EXPONENT LDA PWR MVI B,0 ; ; BEGIN LOOP TO DIVIDE BY 10 ; FLO90: SUI 10 JC FO100 ;OVFL. EXIT LOOP INR B JMP FLO90 ; FO100: ADI 10 ;RESTORE PUSH PSW ;SAVE REMAINDER MOV A,B ADI '0' ;CONVERT TO ASCII MOV C,A CALL OUTCHR ;PRINT MSD OF EXP POP PSW ADI '0' ;CONVERT TO ASCII MOV C,A JMP OUTCHR ;PRINT LSD OF EXP & RET ENDIF IF (NOT HARDWARE) AND BFLOAT FLOATFROMREAL ;S/W CONVERSION ROUTINE ENDIF PAGE IF BFLOAT AND (NOT HARDWARE) SW9511 ;BRING IN S/W ADD,SUB,MUL,DIV,FIX,FLOAT ENDIF IF BFLOAT AND HARDWARE ; ; RMUL: ; MULTIPLY TWO REALS ON STACK. RETURNS ONE REAL TO STACK ; LXI H,5 DAD SP ;HL POINTS TO LSB OF FIRST REAL MDLOAD LXI D,7 DAD D ;HL POINTS TO LSB OF SECOND REAL MDLOAD CMDW FMUL ;ADD STKSTORE RADD: ; EXPECTS 2 REALS ON THE 8080 STACK, RETURNS 1 REAL TO 8080 STK. ; LXI H,5 DAD SP ;HL POINTS TO LSB OF FIRST REAL MDLOAD LXI D,7 DAD D ;HL POINTS TO LSB OF SECOND REAL MDLOAD CMDW FADD ;ADD STKSTORE ; ; RSUB: ; SUBTRACT NOS FROM TOS AND RETURN RESULT TO 8080 STACK ; LXI H,5 DAD SP ;HL POINTS TO LSB OF FIRST NUMBER MDLOAD LXI D,7 DAD D ;HL POINTS TO LSB OF SECOND NUMBER MDLOAD CMDW XCHF ;EXCHANGE TOS AND NOS FOR SUB OR DIV CMDW FSUB STKSTORE ; ; RDIV: ; DIVIDE NOS BY TOS AND RETURN RESULT TO 8080 STACK. ; LXI H,5 DAD SP ;HL POINTS TO LSB OF FIRST NUMBER MDLOAD LXI D,7 DAD D ;HL POINTS TO LSB OF SECOND NUMBER MDLOAD CMDW XCHF ;EXCHANGE TOS AND NOS FOR SUB OR DIV CMDW FDIV STKSTORE ENDIF PAGE ; ; RNEG: ; NEGATE TOP OF 8080 STACK. RESULT IS RETURNED TO 8080 STACK LXI H,2 DAD SP ;HL POINTS TO MSB (SIGN IN MOST SIG BIT) MOV A,M ;SIGN BYTE INTO A XRI 80H ;NEGATE MOV M,A ;STORE BACK INTO NUMBER RET ; RABS: ; RETURN ABSOLUTE VALUE OF REAL ON TOS POP H ;GET RET ADDRESS POP D MOV A,E ANI 7FH MOV E,A PUSH D PCHL ; TRUNC: ; ;PARAMETERS : REAL NUMBER ON TOS ; IF HARDWARE LXI H,5 DAD SP ;HL POINTS TO LSB MDLOAD CMDW FIXS INX H INX H INX H ;HL POINTS TO STORAGE LOC. IN ADATA MOV M,A DCX H IN ADATA MOV M,A ;STORE INTEGER ON STACK POP D ;GET RET ADDRESS SPHL ;SP = HL XCHG ;HL = RETURN ADDRESS PCHL ELSE LXI H,2 DAD SP CALL FIX POP B ;GET RET ADDR POP H POP H ;FLUSH REAL PUSH D ;PUT INTEGER ON PUSH B RET ENDIF ; ; ROUND: ; ROUND REAL ON TOS TO INTEGER POP B ;GET RET ADDRESS MOV L,C MOV H,B SHLD RNDRET ;SAVE RETURN ADDR POP D PUSH D MOV A,E ANI 80H JNZ SUBHALF ADDHALF: CALL TO9511 IF BFLOAT AND HARDWARE CMDW FADD ENDIF IF BFLOAT AND (NOT HARDWARE) CALL SWRADD ENDIF JMP AFTERSUB SUBHALF: CALL TO9511 IF BFLOAT AND HARDWARE CMDW FSUB ENDIF IF BFLOAT AND (NOT HARDWARE) CALL SWRSUB ENDIF AFTERSUB: IF BFLOAT AND HARDWARE CMDW FIXS LXI H,3 DAD SP IN ADATA MOV M,A DCX H IN ADATA MOV M,A SPHL ENDIF IF BFLOAT AND (NOT HARDWARE) LXI H,0 DAD SP CALL FIX POP B ;FLUSH REAL FROM STACK POP B PUSH D ;AND PUT INTEGER ON STACK ENDIF LHLD RNDRET PCHL ;AND EXIT BACK TO CALLER ; ; SUBROUTINE TO PUSH VALUE THEN .5 ; TO9511: ; PUSH THE CONSTANT .5 AFTER THE REAL ON 8080 STK ONTO ; THE 9511 STACK. IF BFLOAT AND HARDWARE LXI H,5 ;POINT AT LOW BYTE OF REAL UNDER RET ADDR DAD SP MDLOAD LXI H,HALF+3 MDLOAD RET ENDIF IF BFLOAT AND (NOT HARDWARE) POP B ;GET RETURN ADDRESS LXI H,-4 DAD SP SPHL ;EXTEND THE STACK PUSH B ;PUT RET ADDR BACK ON STACK LXI D,HALF LXI B,4 CALL BLKMOVE ;PUT THE .5 ON THE TOP OF STACK RET ENDIF ; RSQRT: IF BFLOAT AND HARDWARE POP B CALL RABS PUSH B ;MAKE POSITIVE FIRST LXI H,5 DAD SP MDLOAD CMDW SQRT DSTORE RET ENDIF IF BFLOAT AND (NOT HARDWARE) CALL RSQRT ENDIF IF BFLOAT AND HARDWARE ;***** EQUATES *********************************** ; CR: EQU 0DH ;ASCII CARRIAGE RETURN LF: EQU 0AH ;ASCII LINE FEED BS: EQU 08H ;ASCII BACKSPACE RUBOUT: EQU 7FH ;ASCII RUB OUT ESC: EQU 1BH ;ASCII ESCAPE CHARACTER SSTAT: EQU 01000000B ;APU SIGN BIT ZSTAT: EQU 00100000B ;APU ZERO BIT ECFIELD: EQU 00011110B ;ER CODE FIELD OF STAT ; ; APU COMMAND CODES: ; DADD: EQU 2CH DSUB: EQU 2DH DMUL: EQU 2EH FADD: EQU 10H FDIV: EQU 13H FLTS: EQU 1DH FLTD: EQU 1CH FMUL: EQU 12H FSUB: EQU 11H PTOF: EQU 17H SADD: EQU 6CH ;SDIV: EQU 6FH ;COMMENTED OUT BECAUSE OF SDIV MACRO IN ;MATH.LIB XCHF: EQU 19H SQRT: EQU 01H FIXS: EQU 1FH PUPI: EQU 1AH CHSF: EQU 15H ; ; EQUATES FOR 9511 INTERFACE*** ; ; ; ADDQS: INX D ;MOVE TO LSD INX D INX D MVI B,3 ;LOOP COUNT MOV A,M ;+ OR -? ORA A LDAX D JM AQS20 ;2ND OPRND NEG. ADD M STAX D AQS10: DCX D LDAX D ACI 0 STAX D DCR B JNZ AQS10 ;REPEAT LOOP RET ; AQS20: ADD M STAX D ; AQS30: DCX D LDAX D ACI 0FFH ;PROPAGATE CARRY STAX D DCR B JNZ AQS30 RET ; ; IF INPUT CHAR = + OR -S, SET M(HL) = CHAR ; AND READ NEXT CHAR. ; INPUT: C = CHAR ; HL = DEST. OF CHAR ; OUTPUT: M(HL) ALTERED ; C = NEXT CHAR ; FETCH A CHARACTER INTO C ; NXCHR: CALL FETCM ;FETCH FROM COMMAND BUFFER MOV C,A RET ; FETCM: PUSH H ;SAVE HL LHLD CMPTR MOV A,M ;FETCH BYTE INX H SHLD CMPTR ;UPDATE POINTER POP H RET ; ; ; CKSIGN: MOV A,C CPI '+' JZ CSG10 CPI '-' RNZ ;NO SIGN CSG10: MOV M,C ;SAVE SIGN JMP NXCHR ; ; CLEAR B BYTES STARTING AT M(HL) ; ALTERS A,B, & HL ; CLEAR: MVI M,0 INX H DCR B JNZ CLEAR ;REPEAT LOOP RET ; ; COPY 4 BYTES FROM M(HL) TO M(DE) ; SAVE HL, DE. ALTERS B ; COPY4: MVI B,4 COPY: PUSH D PUSH H CPY10: MOV A,M STAX D INX H INX D DCR B JNZ CPY10 ;REPEAT LOOP POP H POP D RET ; ; SET M(DE) = -M(DE) (4-BYTE INTEGER) ; SAVE DE, HL. ALTERS A,B ; DCOMPL: XCHG INX H ;MOVE TO LSB INX H INX H MVI B,4 ;LOOP COUNT XRA A DCL10: MVI A,0 SBB M MOV M,A DCX H DCR B JNZ DCL10 INX H XCHG ;RESTORE RET ; ; 4-BYTE FIXED POINT COMPARISON ; TEST M(DE) - M(HL). A = APU STATUS ; SAVE DE, HL. ALTERS A,B ; DPCMP: CALL PSH8 ;PUSH M(DE), M(HL) MVI A,DSUB CALL APUCS JMP RDSTAT ; ; CONVERTS 4-BYTE INTEGER AT M(DE) TO FLTG PT ; SAVE DE. ALTERS A,B ; DFLOAT: CALL PSHD ;PUSH M(DE) INTO APU MVI A,FLTD CALL APUCS JMP POPSTAT ;POP APU DATA & STATUS ; ; ; NON-DESTRUCTIVE SUBTRACT M(DE)-M(HL)(FLT. PT.) ; RETURN APU STAT IN A ; SAVE DE, HL. ALTERS B ; POPSTAT: PUSH D MVI B,4 ;LOOP COUNT PPS10: CALL APURS STAX D INX D DCR B JNZ PPS10 POP D JMP RDSTAT ; ; PUSH M(DE) INTO APU. SAVE DE, ; ALTERS B ; ; PSHD: INX D ;MOVE TO LSB INX D INX D MVI B,4 PSD10: LDAX D CALL APUWS DCX D DCR B JNZ PSD10 INX D RET ; ; SET CARRY IF A IS AN ALPHA CHAR. ; ALPHA: CPI 'Z'+1 RNC CPI 'A' CMC RET ; ; SET CARRY IF A IS A VALID ASCII DIGIT. ; VALDIG: CPI '9'+1 RNC CPI '0' CMC RET ; ; ; ; M(DE) = M(DE) / M(HL) (FLT. PT.) ; RETURN APU STATUS IN A ; SAVE DE, HL. ALTERS B ; FPDIV: MVI A,FDIV JMP FLARITH ; ; M(DE) = M(DE) * M(HL) (FLT. PT.) ; A = APU STAT ; SAVE DE. ALTERS B,HL ; FPMUL: MVI A,FMUL JMP FLARITH ; ; M(DE) = M(DE) * 10 (FIXED PT, 4-BYTES) ; SAVE DE. ALTERS HL,B ; MPY10: LXI H,ITEN MVI A,DMUL JMP FLARITH ; ; SET HL = HL + 4*A ; TINDEX: RLC RLC ADD L MOV L,A RNC INR H ;PROPAGATE CARRY RET ; ; POP SPU FSYS INYO M(DE) THEN READ ; APU STATUS INTO A. ; SAVE DE. ALTERS B ; ; ; PUSH M(DE) & M(HL) INTO APU ; SAVE DE, HL. ALTERS B ; PSH8: CALL PSHD XCHG CALL PSHD XCHG RET ; ; PUSH M(DE) INTO APU. ; SAVE DE. ALTERS B ; ; WAIT FOR APU NOT BUSY ; RDSTAT: IN ACTRL ORA A JM RDSTAT RET ; ; WAIT FOR APU NOT BUSY ; APULOOP: PUSH PSW APUX2A: IN ACTRL ;READ STATUS ORA A ;SET CPU FLAGS JM APUX2A ;LOOP IF BUSY POP PSW RET ; ; OUTPUT APU COMMAND SUBROUTINE ; ; INPUT REQUIRED: ; THE 'A' REGISTER MUST CONTAIN THE APU COMMAND ; APUCS: CALL APULOOP ;WAIT UNTIL NOT BUSY OUT ACTRL ;WRITE COMMAND TO APU RET ; ; READ APU DATA ; APURS: CALL APULOOP IN ADATA ;READ APU DATA PORT RET ; ; WRITE APU DATA ; APUWS: CALL APULOOP OUT ADATA ;WRITE TO APU DATA PORT RET ; FLOATING POINT ADD ; M(DE) = M(DE) + M(HL) ; A = APU STAT ; SAVE DE & HL. ALTERS B ; FPADD: MVI A,FADD ; FLARITH: PUSH PSW ;SAVE CMD CALL PSH8 ;PUSH M(DE),M(HL) POP PSW CALL APUCS JMP POPSTAT ;POP DATA & STATUS ; NON-DESTRUCTIVE SUBTRACT M(DE)-M(HL)(FLT. PT.) ; RETURN APU STAT IN A ; SAVE DE, HL. ALTERS B ; FLCMP: CALL PSH8 ;PUSH M(DE), M(HL) MVI A,FSUB CALL APUCS JMP RDSTAT ; ; LEFT SHIFT THE 4-BYTE # AT M(DE) C TIMES ; C MUST BE < 127 ; ALTERS B,C ; LSHQ: DCR C ;TEST LOOP COUNT RM ;EXIT LOOP CALL LSHQ1 ;SHIFT ONCE JMP LSHQ ;REPEAT LOOP ; ; LEFT SHIFT M(DE) ONCE ; LSHQ1: MVI B,4 ;LOOP COUNT INX D INX D INX D XRA A ;CLEAR CARRY ; LSQ10: LDAX D RAL STAX D DCX D DCR B JNZ LSQ10 INX D RET ; ; TEST M(DE) = 0. SET Z IF = 0 ; SAVE DE ; TEQ0: PUSH D ;SAVE D XCHG MOV A,M INX H ORA M INX H ORA M INX H ORA M XCHG POP D RET ; ; OUTPUT SIGN CHAR THEN SET X=ABS(X) ; INPUT: A = SIGN ; DE = ADR(X) ; ALTERS C ; OUTSGN: MVI C,' ' ;SET UP SIGN LDAX D ;A = SGN & EXP ORA A ;TEST SIGN BIT JP OSG10 ;POSITIVE MVI C,'-' ;NEGATIVE ; OSG10: ANI 07FH ;CLEAR SIGN OF MANT. STAX D JMP OUTCHR ;OUTPUT SIGN ; ; POP SPU FSYS INYO M(DE) THEN READ ; APU STATUS INTO A. ; SAVE DE. ALTERS B ; ; ; PUSH M(DE) & M(HL) INTO APU ; SAVE DE, HL. ALTERS B ; ; ---------------------------------------- ; ; OUTCHR - BUILDS BUFFER DATA FROM AMD OUTPUT ; ; ---------------------------------------- OUTCHR: PUSH PSW PUSH B PUSH D PUSH H LHLD OUTPTR MOV M,C ;STUFF CHAR IN MEMORY INX H SHLD OUTPTR POP H POP D POP B POP PSW RET ; --------------------------------------- ; ; TABLE OF POWERS OF 10 AND OTHER CONSTANTS ; ; ----------------------------------------- ; NAME APUTBL ; ; TENTH: DB 7DH,0CCH,0CCH,0CDH ;0.1 ; PWR10: DB 01H,80H,00H,00H ;1. DB 04H,0A0H,00H,00H ;10. DB 07H,0C8H,00H,00H ;100. DB 0AH,0FAH,00H,00H ;1000. DB 0EH,9CH,40H,00H ;10000. DB 11H,0C3H,50H,00H ;1.E5 DB 14H,0F4H,24H,00H ;1.E6 DB 18H,98H,96H,80H ;1.E7 DB 1BH,0BEH,0BCH,20H ;1.E8 DB 1EH,0EEH,6BH,28H ;1.E9 DB 22H,95H,02H,0F9H ;1.E10 DB 25H,0BAH,43H,0B7H ;1.E11 DB 28H,0E8H,0D4H,0A5H ;1.E12 DB 2CH,91H,84H,0E7H ;1.E13 DB 2FH,0B5H,0E6H,20H ;1.E14 DB 32H,0E3H,5FH,0A9H ;1.E15 DB 36H,8EH,1BH,0C9H ;1.E16 DB 39H,0B1H,0A2H,0BCH ;1.E17 DB 3CH,0DEH,0BH,6BH ;1.E18 ; FLMAX: DB 3FH,0FFH,0FFH,0FFH ;MAXIMUM FLT. PT NUMBER ZERO: DB 00H,00H,00H,00H ;FLT. PT ZERO HALF: DB 00H,80H,00H,00H ;.5 M18: DB 0FFH,0FFH,0FFH,0EEH ;FIXED PT -18 P18: DB 00H,00H,00H,12H ;FIXED PT +18 ITEN: DB 00H,00H,00H,0AH ;FIXED PT +10 ENDIF ;HARDWARE ; ; ; EXTENDED LOAD / STORE LOGIC FOR 4-BYTE FLOATING POINT REALS ; BINOP: ; HL = TBL1[A] ; POP B LDAX B MOV E,A MVI D,0 LXI H,TBL1 DAD D MOV E,M INX H MOV D,M XCHG PCHL ; TBL1: DW LDIRECT ;00 LOAD REAL DIRECT DW LINDIRECT ;02 LOAD REAL INDIRECT DW LINDTOS ;04 LOAD INDIRECT TO TOS DW DUPTOS ;06 DUPLICATE NUMBER ON TOS DW FLOAT ;08 FLOAT TOS DW UNDERFLOAT ;0A FLOAT INTEGER UNDER REAL ON TOS DW STDIRECT ;0C STORRE REAL DIRECT DW STINDIRECT ;0E STORE REAL INDIRECT DW STUNDER ;10 STORE REAL INDIRECT, ADDR UNDER REAL DW LDRCONST ;12 LOAD REAL CONSTANT DW EXR ;14 EXCHANGE REAL AND RET ADDR ON TOS ; ; LDIRECT: ; BC@ BYTE FOLLOWING RST6 ; MOV L,C MOV H,B INX H ;HL@ ADDRESS OF REAL MOV E,M INX H MOV D,M ;DE = ADDRESS OF REAL INX H ;HL= RETURN ADDRESS MOV C,L MOV B,H XCHG ;HL = ADDRESS OF REAL INX H ;LOAD REAL ONTO STACK INX H MOV E,M INX H MOV D,M PUSH D DCX H DCX H MOV D,M DCX H MOV E,M PUSH D PUSH B RET ; LINDIRECT: ; ADDRESS OF ADDRESS OF REAL FOLLOWS RST INST. ; MOV L,C MOV H,B INX H MOV E,M INX H MOV D,M ;DE= @ ADDRESS OF REAL INX H MOV B,H MOV C,L XCHG ;BC= RETURN ADDRESS MOV E,M INX H MOV D,M XCHG ;HL = ADDRESS OF REAL INX H ;LOAD REAL ONTO STACK INX H MOV E,M INX H MOV D,M PUSH D DCX H DCX H MOV D,M DCX H MOV E,M PUSH D PUSH B RET ; LINDTOS: ; ADDRESS OF REAL TO BE LOADED IS ON TOS. ; POP H ;GET ADDRESS INTO HL INX H ;LOAD REAL ONTO STACK INX H MOV E,M INX H MOV D,M PUSH D DCX H DCX H MOV D,M DCX H MOV E,M PUSH D INX B ;BC = RETURN ADDRESS PUSH B RET ; DUPTOS: POP H POP D PUSH D PUSH H PUSH D PUSH H INX B PUSH B RET ; FLOAT: IF HARDWARE POP H ;HL CONTAINS INTEGER TO BE FLOATED MOV A,L OUT ADATA MOV A,H OUT ADATA CMDW FLTS LXI H,-4 DAD SP ;HL@ PLACE FOR EXP ON STACK SPHL DSTORE INX B PUSH B RET ELSE MOV L,C MOV H,B SHLD RNDRET ;SAVE RETURN ADDRESS POP D ;GET INTEGER LXI H,-4 DAD SP SPHL ;OPEN UP SPACE ON STACK CALL FLOAT2 LHLD RNDRET PCHL ;AND EXIT ENDIF ; UNDERFLOAT: IF BFLOAT AND HARDWARE LXI H,3 DAD SP MDLOAD ;MOVE REAL TO 9511 FOR HOLDING POP H POP H ;THROW AWAY THIS COPY OF REAL POP H ;HL CONTAINS INTEGER TO BE FLOATED MOV A,L OUT ADATA MOV A,H OUT ADATA CMDW FLTS LXI H,-4 DAD SP ;HL@ PLACE FOR EXP ON STACK SPHL DSTORE LXI H,-4 DAD SP SPHL DSTORE ;GET STORED REAL BACK FROM 9511 INX B PUSH B RET ELSE POP H SHLD REALX1 POP H SHLD REALX2 ;SAVE REAL FROM TOS MOV L,C MOV H,B SHLD RNDRET ;SAVE RETURN ADDRESS POP D LXI H,-4 DAD SP SPHL ;OPEN UP SPACE FOR RESULT CALL FLOAT2 LHLD REALX2 PUSH H LHLD REALX1 PUSH H LHLD RNDRET PCHL ;AND EXIT ENDIF STDIRECT:; ; ; STORE REAL # ON TOS AT ADDRESS FOLLOWING CALL/RST INST. ; MOV L,C MOV H,B INX H ;HL@ ADDRESS OF REAL MOV E,M INX H MOV D,M ;DE = ADDRESS OF REAL INX H ;HL= RETURN ADDRESS MOV C,L MOV B,H XCHG ;HL = ADDRESS OF REAL POP D MOV M,E INX H MOV M,D INX H POP D MOV M,E INX H MOV M,D PUSH B RET ; STINDIRECT: ; ADDRESS OF STORAGE LOC IS POINTED TO BY ADDRESS FOLLOWING ; RST INST. MOV L,C MOV H,B INX H ;HL@ ADDRESS OF REAL MOV E,M INX H MOV D,M ;DE = ADDRESS OF REAL INX H ;HL= RETURN ADDRESS MOV C,L MOV B,H XCHG ;HL = POINTER TO ADDRESS OF REAL MOV E,M INX H MOV D,M XCHG ;HL = ADDRESS OF REAL POP D ;DE = EXP AND FIRST BYTE MOV M,E INX H MOV M,D INX H POP D ;DE = MID AND LAST BYTE MOV M,E INX H MOV M,D PUSH B RET ; STUNDER: ; STORE REAL INDIRECT TO ADDR UNDER REAL ON TOS ; INX B MOV E,C MOV D,B ;MOVE RET ADDR TO BC POP B ;GET HIGH OF REAL INTO C,B POP H ;GET LOW OF REAL INTO L,H XCHG ;MOVE LOW TO E,D XTHL ;PUT RET ADDR ON STACK AND GET ;DESTINATION ADDR INTO HL MOV M,C INX H MOV M,B INX H MOV M,E INX H MOV M,D ;STORE RESULT AWAY RET ;AND EXIT ; ; LDRCONST: ; LOAD REAL CONSTANT ON STACK ; INX B INX B INX B INX B MOV H,B MOV L,C ;HL POINTS TO B4 MOV D,M DCX H MOV E,M PUSH D DCX H MOV D,M DCX H MOV E,M PUSH D INX B PUSH B RET ; ; EXR - EXCHANGE REAL AND RET ADDR ; EXR: POP D POP H XTHL PUSH D PUSH H PUSH B RET POP8: POP H POP H POP H POP H RET POP4: POP H POP H RET ENDIF ;IF bfloat PAGE NEXTPROG SET $ ;----------------------------------------------------------; ; DATA STORAGE FOR RUN-TIME ROUTINES ; ; ; ; ALL NON-DEBUGGER RAM IS LOCATED HERE ; ; FOR RAM IN DEBUGGER NEXTPROG/NEXTDATA ARE USED ; ; O SWITCH RELOCATION BASES ; ;----------------------------------------------------------; ; IF UNDERCPM ORG $ ELSE ORG RAMADDR ENDIF IF AUTOENGR CONFLAG DB 1 ;PUT AT BEGINING OF DATA AREA ENDIF IF BFLOAT DTAREA EQU $ OUTPTR: DS 2 ;USED TO INDEX INTO BUFF BY OUTCHR ERCODE: DS 1 SIGN: DS 1 ;SIGN OF MANTISSA SEXP: DS 1 ;SIGN OF EXPONENT EXP1: DS 1 CNT1: DS 1 CNT2: DS 1 EXP: DS 4 ;EXPONENT OLDINT: DS 4 DIGT: DS 1 PWR: DS 1 PROD: DS 4 ;TEMP STORAGE FOR X*10**P LOCLX: DS 4 ;LOCAL STORAGE FOR X DTALEN EQU $-DTAREA RNDRET DS 2 ;RETURN USED IF NOT HARDWARE REALX1: DS 2 REALX2: DS 2 ;SAVE AREA FOR UNDERFLOAT CMPTR DS 2 ;BUFFER POINTER RDATA DS 4 ; ;***************DATA FOR INPUT ROUTINE***************** ; CHAR: DS 1 LEN: DS 1 BUFF: DS 32 MSG1: DB ' ' ;'INVALID ' MSG2: DB ' ' ;'OVERFLOW' MSG3 DB ' ' ;'UNDRFLOW' SW9511DATA ;BRING IN DATA AREAS ENDIF ;{BFLOAT} RTERMCH DS 1 TEMP DS 2 IF BCD FPSIGN: DS 1 ;SAVED SIGN FROM EDIT ROUTINE XLENGTH DS 1 ;"LENGTH" USED IN ADD AND SUBTRACT FLIPRET: DS 4 TEMP10 DS 10 ; ; STORAGE ; DS 8 ;SPACER SO NOBODY CLOBBERS FPMUL FPWRK1: DS FPLEN+3 DB 0 ;SIGN FOR DIVIDE ROUTINE DS 1 ;SPACER FPWRK2: DS FPLEN+3 DB 0 ;SIGN FOR DIVIDE ROUTINE DS 1 ;SPACER FOR SHIFTING FPWRK3: DS FPLEN+3 DB 0 DS 1 FPWRK4 DS FPLEN+3 DB 0 ;SIGN FOR DIVIDE ROUTINE ; FPMULS: DS 1 ;SHIFT COUNTER FPDIVS DS 1 ;SHIFT COUNTER FOR DIVIDING ; ; SAVED FILL CHARACTER ; FPFILL: DS 1 FLTRET DW 0 FLTINT: DW 0 ;INTEGER TO FLOAT TEMP10B DS 10 ;FOR SAVING NUMBER IN FLTUR TNCRET: DS 2 WIDTH DB 0 DECPLACES DB 0 SCRATCH: DS MASKLEN RCOMPRET: DW 0 RSIGN: DB 0 ;IF <> 0 THEN RESULT OF SUBTRACT < 0 RZERO DB 0 ;IF <> 0 THEN RESULT OF SUBTRACT <> 0 COMPRET DW 0 ;SAVE RETURN ADDRESS RBUF: DS 32 ;INPUT BUFFER REALPTR DS 2 ;SAVED ADDR OF REAL NUMBER RRTERM: DS 1 ;TERMINATION CHARACTER ENDIF ;{BCD} PRINTFLAG DB 0 ;SET TO <> 0 FOR PWREAL IOADDR DS 2 ;I/O ROUTINE ADDRESS ;PASSED IN DE REG TO I/O ROUTINES NEXTDATA SET $ RAMLAST EQU $ IF UNDERCPM ORG $ ELSE ORG NEXTPROG ENDIF RTPSIZE EQU $ ;LAST RTP-ONLY LOCATION PAGE $+PRINT ;-------------------------------------------------------; ; ; ; ; ; NON-DEBUG CODE ENDS AT THIS POINT, REMAINDER ; ; OF THIS CODE IS FOR THE DEBUGGER ; ; ; ; ; ;-------------------------------------------------------; PAGE ; CHKBPT: JMP BPTCHK ;GO TO ROUTINE INTERNAL TO THE DEBUGGER ; ; PRINT BPT ROUTINE ; PRINTBPT: XTHL ;GET POINTER INTO HL AND SAVE HL ON STACK PUSH D PUSH B ;SAVE REGS ON STACK MOV E,M INX H MOV D,M INX H PUSH H ;SAVE POINTER PUSH D LXI H,BPTSTRING PUSH H LXI H,BPTLENGTH CALL WCHR ;WRITE THE MESSAGE CALL WINT ;WRITE THE INTEGER POP H ;GET POINTER BACK POP B POP D XTHL RET ;BACK TO USER BPTSTRING: DB 13,10 DB 'Stopped at Line #' BPTLENGTH EQU $-BPTSTRING ; ; PROCENT : GOTO ROUTINE INTERNAL TO DEBUGGER ; PROCENT: JMP ENTPROC ; ; PRINTENT : PRINT OUT PROC ENTRY MESSAGE ; PRINTENT: XTHL ;GET POINTER TO STRING IN HL AND SAVE HL ON STACK PUSH D PUSH B ;SAVE REGS PUSH H ;SAVE IT BACK AGAIN LXI D,PROCMSG LXI B,8 XCHG CALL BLKMOVE ;MOVE INTO MSG LXI H,PROCENTMSG PUSH H LXI H,PROCLENGTH CALL WCHR POP H LXI D,8 DAD D POP B POP D XTHL RET ;AND EXIT NEXTPROG SET $ IF UNDERCPM ORG $ ELSE ORG NEXTDATA ENDIF PROCENTMSG: DB 13,10 DB 'Entering: ' PROCMSG DB '********' PROCLENGTH EQU $-PROCENTMSG NEXTDATA SET $ IF UNDERCPM ORG $ ELSE ORG NEXTPROG ENDIF PAGE $-PRINT IF PRINTDEBUG $+PRINT ENDIF ;-------------------------------------------------------; ; ; ; D E B U G G E R ; ; ; ; PASCAL/MT PASCAL INTERACTIVE DEBUGGER ; ; ; ; VERSION 1.0 JULY 29, 1979 ; ; VERSION 2.0X SEPTEMBER 5, 1979 ; ; VERSION 2.5 OCTOBER 12, 1979 ; ; Version 2.6 November 18, 1979 ; ; Version 3.0 February 15, 1980 ; ; ; ;-------------------------------------------------------; IF UNDERCPM ORG $ ELSE ORG NEXTDATA ENDIF ; ; DATA AREA ; TFLAG DB 0 ;<> 0 IF TRACING TCOUNT DB 0 ;NUMBER OF LINES TO TRACE LFLAG DB 0 ;<> 0 IF LISTING SOURCE AS WE TRACE EFLAG DB 0 ;<> 0 IF LISTING PROC ENTRIES AS WE TRACE NEGFLG DB 0 ;<> 0 IF COMMAND WAS PRECEEDED BY A - BFLAG DB 0 ;<> 0 IF GO COMMAND WAS ISSUED WITH A BPT BPTLINE DW 0 ;LINE BREAKPOINT IS SET FOR (IF ANY) ELSE = 0 PFLAG DB 0 ;<> 0 MEANS PLINE IS VALID PLINE DW 0 ;LINE BREAKPOINT DISPLAY/STOP IF <> 0 PNFLAG DB 0 ;<> 0 MEANS STOP BASED UPON PROC NAME PBMSG EQU $ DB 13,10 DB 'Symbolic stop at: ' PBNAME DS 8 ;PROC NAME TO STOP ON DB '$' SLOWDOWN DB 0 ;<> 0 MEANS DELAY FOR DLY SECONDS DLY DS 2 ;SET BY S COMMAND SYMTAB DS 2 ;PTR TO SYMBOL TABLE FILLED IN BY MOVESYMTAB PTRFLG DS 1 ;FOR DISPLAY ENDIDPTR DS 2 ;USED BY GETENTRY FIRSTDBUG DB 0 ;IF <> 0 THEN NOT THE FIRST TIME INBUF DB 40 ;LENGTH OF INPUT BUFFER (MAX) INLEN DB 0 ;LENGTH RETURNED BY BDOS BUFFER DS 40 ;REAL INPUT AREA ; ; SYMBOL TABLE AREA ; ID DS 8 TYP DS 1 ADDR DS 2 PTF DS 1 PNUM DW 0 LEVEL DS 1 NUMDIM DS 1 LB DS 2 UB1 DS 2 LB2 DS 2 UB2 DS 2 LB3 DS 2 UB3 DS 2 ELTSIZE DS 2 SUBPTR DS 2 PARMS EQU SUBPTR NXTPTR DS 2 ENTSIZE EQU $-ID NEXTDATA SET $ IF UNDERCPM ORG $ ELSE ORG NEXTPROG ENDIF ; ; TYPE EQUATES ; PROCNAME EQU 1 INTFUNC EQU 2 CHRFUNC EQU 3 BOOLFUNC EQU 4 REALFUNC EQU 5 INT EQU 6 CHR EQU 7 BOOL EQU 8 REAL EQU 9 INTARR EQU 10 CHRARR EQU 11 BOOLARR EQU 12 REALARR EQU 13 FILETYPE EQU 14 INTCON EQU 15 CHRCON EQU 16 BOOLCON EQU 17 REALCON EQU 18 ; MESSAGES ; HELLOMSG: DB 13,10,10 DB 'Pascal/MT',13,10 DB 'Debugger R3.0b',13,10 DB 10,'(? for help)',13,10 DB 10,'$' PROMPT: DB 13,10,'>$' UNKNOWN: DB 13,10,'What?$' GOMSG: DB 13,10,'Resuming execution',13,10,'$' BPTMSG: DB 13,10,'Bpt Reached$' PASSMSG: DB 13,10,'Perm Bpt is:$' NONEGMSG: DB 13,10,'- not allowed $' INVMSG: DB 13,10,'Bad number$' HELPMSG: IF AUTOENGR DB 13,10,'NO HELP AVAILABLE' ELSE DB 13,10,10 DB 13,10,'Commands available:' DB 13,10,10 DB 'G{,} - Go ' DB 13,10 DB 'R - Restart from begining' DB 13,10 DB 'T{} - Trace ' DB 13,10 DB 'P - Set Permanent bpt' DB 13,10 DB '-P - Turn off Perm bpt' DB 13,10 DB 'B - Display Perm bpt' DB 13,10 DB '{-}E - Turn on/off entry display' DB 13,10 DB 'D - Display variable' DB 13,10 DB '+/- - Adjust addr by then Display' DB 13,10 DB '* - Display same again' DB 13,10 DB '{-}S - Set/clear slow exec mode' DB 13,10 DB ' = integer or name' ENDIF db 13,10,'$' WRONGTYPEMSG: DB 13,10,'Bad Qualifier$' BADTYPEMSG: DB 13,10,'Cannot display this type$' UNDEFMSG: DB 13,10,'Undefined$' SUBMSG: DB 13,10,'Subscript ? $' CSUBMSG EQU SUBMSG OFFMSG: DB 13,10,'Offset (decimal)? $' TYPMSG: DB 13,10,'Type: I)nteger, C)har, B)oolean, R)eal? $' INVTYP: DB 13,10,'Invalid type, must be I,C,B or R$' SPEEDMSG: DB 13,10,'F(ast),M(edium) or S(low)? $' PAGE ;-------------------------------------------------------; ; ; ; DEBUGGER MAINLINE BEGINS HERE ; ; ; ;-------------------------------------------------------; DEBUGGER: ; ; START BY SETTING UP A PRIVATE STACK ; LXI SP,DBUGSTK ;ONLY USED UNTIL USER PGM ENTERED JMP PASTSTACK NEXTPROG SET $ IF UNDERCPM ORG $ ELSE ORG NEXTDATA ENDIF DS 32 DBUGSTK: NEXTDATA SET $ IF UNDERCPM ORG $ ELSE ORG NEXTPROG ENDIF PASTSTACK: LXI H,0FFFFH CALL SETIOADDR ;CONSOLE I/O LXI H,USERPROGRAM ;DUMMY RETURN ADDR FOR FIRST G PUSH H PUSH PSW PUSH B PUSH D PUSH H ;DUMMY REGS LDA FIRSTDBUG ORA A CZ MOVESYMTAB ;LEAVE ROOM FOR USER'S VARS MVI A,1 STA FIRSTDBUG LXI D,HELLOMSG MVI C,9 CALL BDOS ;DISPLAY VERS. MSG GETCMD: LXI D,PROMPT MVI C,9 CALL BDOS ;PRINT PROMPT MSG LXI D,INBUF XRA A STA INLEN STA NEGFLG STA BFLAG STA TFLAG MVI C,10 CALL BDOS ;GET A BUFFER FROM CONSOLE LDA INLEN ORA A JZ GETCMD ;BRANCH IF NULL COMMAND MOV E,A MVI D,0 LXI H,BUFFER DAD D MVI M,0DH ;MOVE CR INTO LAST POS OF BUFFER ; ; NOW DISPATCH BASED UPON FIRST BYTE OF BUFFER ; LDA BUFFER CPI '-' JNZ GETC1 ;BRANCH IF NOT PRECEEDED BY NEG ; ; CHECK TO SEE IF COMMAND OR -n ; LDA BUFFER+1 CPI 'A' JC GETC1 ;BR IF NOT COMMAND MVI A,0FFH STA NEGFLG ;SET FLAG LDA BUFFER+1 GETC1: CALL UPCASE CPI 'G' JZ GOCMD CPI 'T' JZ TRACECMD CPI 'P' JZ PASSCMD CPI 'B' JZ BPTCMD CPI 'D' JZ DISPCMD CPI '*' JZ DISPCMD CPI '+' JZ DISPPLUS CPI '-' JZ DISPMINUS CPI 'E' JZ ENTRYCMD CPI 'S' JZ SPEEDSETCMD CPI 'R' IF TRS80 JZ 4300H ELSE JZ 100H ENDIF CPI '?' JNZ UNKN ; ; IF '?' THEN PRINT HELPMSG ; LXI D,HELPMSG MVI C,9 CALL BDOS JMP GETCMD ; ; ELSE COMMAND WAS NOT INTELLIGIBLE ; UNKN: LXI D,UNKNOWN JMP ERRPRINT INVALID LXI D,INVMSG ERRPRINT: MVI C,9 CALL BDOS JMP GETCMD PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: GOCMD ; ; FUNCTION: CONTINUE EXECUTION AND HANDLE ; ; OPTIONAL BREAKPOINT SETTING ; ; ; ;-------------------------------------------------------; GOCMD: CALL NONEG ;MUST NOT BE PRECEEDED BY A - CALL CRLF LDA BUFFER+1 CPI ',' ;BREAK POINT SETTING? JZ GO1 ;BRANCH IF YES XRA A STA BFLAG GOX: LXI H,0 SHLD BPTLINE ;ELSE MAKE SURE WE DONT STOP GO0: LXI D,GOMSG MVI C,9 CALL BDOS ;DISPLAY GO MSG POP PSW POP B POP D POP H ;GET USER'S REGS RET ;AND BACK TO THE USER GO1: LXI H,BUFFER+2 MOV A,M ;SEE IF PROCNAME OR INTEGER CPI '9'+1 JNC GO2 ;BRANCH IF NOT NUMBER CALL CONVERT ;GET USERS LINE NUMBER MOV A,H ORA L JZ INVALID SHLD BPTLINE MVI A,1 STA BFLAG JMP GO0 GO2: CALL SETSYMBPT ;GO DO THE SETUP MVI A,1 STA BFLAG JMP GOX PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: SETSYMBPT ; ; FUNCTION: GATHER ID, MAKE SURE ITS A PROC ; ; OR FUNC AND THEN SET PNFLAG AND ; ; PNAME FOR SYMBOLIC BREAKPOINT ; ; ; ;-------------------------------------------------------; SETSYMBPT: XCHG ;GET POINTER TO DE CALL GETID CALL SEARCH JNZ UNDEF ;BRANCH IF ERROR MVI A,1 STA PNFLAG LDA TYP CPI PROCNAME JZ SSB1 CPI INTFUNC JZ SSB1 CPI CHRFUNC JZ SSB1 CPI BOOLFUNC JZ SSB1 CPI REALFUNC JNZ WRONGTYPE SSB1: LXI H,PBNAME LXI D,ID LXI B,8 CALL BLKMOVE RET PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: TRACECMD ; ; FUNCTION: TRACE 1 TO N LINES ; ; SET TFLAG AND TCOUNT ; ; THEN RESTORE REGS AND GO ; ; ; ;-------------------------------------------------------; TRACECMD: CALL NONEG ;- NOT ALLOWED CALL CRLF MVI A,1 STA TFLAG ;WE ARE TRACING LDA BUFFER+1 CPI 0DH ;ONLY 1 LINE? JNZ TR1 ;BRANCH IF NO LXI H,1 SHLD TCOUNT TR0: POP PSW POP B POP D POP H RET ;RESTORE REGS AND GOTO USER PROGRAM TR1: LXI H,BUFFER+1 CALL CONVERT MOV A,H ORA L JZ INVALID SHLD TCOUNT JMP TR0 PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: PASSCMD ; ; FUNCTION: SET PASSLINE TO A VALUE ; ; WHICH WILL CAUSE THE DEBUGGER ; ; TO STOP EVERY TIME THIS LINE ; ; NUMBER IS FOUND ; ; IF NEGFLG IS SET THEN CLEAR ; ; THE PASS ; ; ; ;-------------------------------------------------------; PASSCMD: LDA NEGFLG ORA A JZ PASS1 ;BRANCH IF NOT TURNING PASS OFF XRA A STA PFLAG STA PNFLAG ;TURN THIS ONE OFF TOO PASS3: LXI H,0 SHLD PLINE JMP GETCMD PASS1: LXI H,BUFFER+1 MOV A,M CPI '9'+1 JNC PASS2 CALL CONVERT MOV A,H ORA L JZ INVALID SHLD PLINE MVI A,1 STA PFLAG JMP GETCMD PASS2: CALL SETSYMBPT MVI A,1 STA PFLAG JMP PASS3 PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: BPTCMD ; ; FUNCTION: DISPLAY PASS VALUE ; ; ; ;-------------------------------------------------------; BPTCMD: LXI D,PASSMSG MVI C,9 CALL BDOS ;DISPLAY MSG LHLD PLINE PUSH H CALL WINT ;WRITE AN INTEGER OUT ; ; AND ALSO DISPLAY SYMBOLIC STOPPING POINT ; LDA PNFLAG ORA A JZ GETCMD LXI D,PBMSG JMP ERRPRINT PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: DISPCMD ; ; FUNCTION: DISPLAY USER VARS AT RUN-TIME ; ; ; ;-------------------------------------------------------; ; ; DISPPLUS - ADD TO ADDR AND ; CONTINUE ; DISPPLUS: LXI H,BUFFER+1 CALL CONVERT XCHG LHLD ADDR DAD D SHLD ADDR DISPPLUS1: MVI A,'*' STA BUFFER JMP DISPCMD DISPMINUS: LXI H,BUFFER+1 CALL CONVERT XCHG LHLD ADDR MOV A,L SUB E MOV L,A MOV A,H SBB D MOV H,A SHLD ADDR JMP DISPPLUS1 DISPCMD: CPI '*' JZ DISPSAME CALL GETENTRY ;GO FIND THE VAR IN THE TABLE ; ; NOW DECIDE WHAT TYPE IT IS AND DISPLAY ACCORDINGLY ; DISPSAME: LDA TYP CPI INT JZ DINT CPI CHR JZ DCHR CPI BOOL JZ DBOOL CPI REAL JZ DREAL CPI INTFUNC JZ DINTF CPI CHRFUNC JZ DCHRF CPI BOOLFUNC JZ DBOOLF CPI REALFUNC JZ DREALF CPI INTCON JZ DINTC CPI CHRCON JZ DCHRC CPI BOOLCON JZ DBOOLC CPI INTARR JZ DINTA CPI CHRARR JZ DCHRA CPI BOOLARR JZ DBOOLA CPI REALARR JZ DREALA CPI 20H JNC DRECORD ;HANDLE RECORD DISPLAY ; ; ELSE A BAD TYPE TO DISPLAY (MOST LIKELY A PROC NAME) ; LXI D,BADTYPEMSG JMP ERRPRINT ; ; DISPLAY SIMPLE INTEGER ; DINT CALL GVAHL ;GET VAR ADDR TO HL MOV E,M INX H MOV D,M PUSH D CALL CRLF CALL WINT JMP GETCMD ; ; DISPLAY SIMPLE CHAR ; DCHR CALL GVAHL MOV A,M ANI 7FH ;DISPLAY ONLY 0..127 ASCII CPI 20H JC CTRLC ;BRANCH IF CTRL CHAR MOV L,A PUSH H CALL CRLF CALL CHRW JMP GETCMD CTRLC: ADI 40H ;MAKE NON CTRL STA CTRLCHR ;SAVE IN MSG LXI H,CTRLMSG PUSH H CALL CRLF LXI H,2 CALL WCHR JMP GETCMD NEXTPROG SET $ IF UNDERCPM ORG $ ELSE ORG NEXTDATA ENDIF CTRLMSG: DB '^' CTRLCHR:DS 1 NEXTDATA SET $ IF UNDERCPM ORG $ ELSE ORG NEXTPROG ENDIF ; ; DISPLAY SIMPLE BOOLEAN ; DBOOL: CALL GVAHL MOV A,M ANI 1 JZ PRINT$FALSE ; PRINT$TRUE: LXI H,TRUEMSG PUSH H LXI H,6 CALL WCHR JMP GETCMD PRINT$FALSE: LXI H,FALSEMSG PUSH H LXI H,7 CALL WCHR JMP GETCMD TRUEMSG: DB 13,10,'TRUE' FALSEMSG: DB 13,10,'FALSE' ; ; HANDLE DISPLAY OF REAL VARIABLE ; DREAL: CALL GVAHL SHLD ADDR CALL CRLF if bfloat call binop else CALL FXPOP endif DB 02H ;LOAD REAL INDIRECT OP DW ADDR ;ADDR OF ADDRESS OF REAL LXI B,0FFFFH ;USE DEFAULT FORMATTING CALL WREAL ;GO WRITE IT OUT JMP GETCMD ; ; HANDLE INTEGER CONSTANT ; DINTC LHLD ADDR CALL CFIX SHLD TEMP LXI H,TEMP SHLD ADDR JMP DINT ; ; HANDLE CHAR CONST ; DCHRC LHLD ADDR CALL CFIX SHLD TEMP LXI H,TEMP SHLD ADDR JMP DCHR ; ; HANDLE BOOL CONSTANT ; DBOOLC: LHLD ADDR CALL CFIX SHLD TEMP LXI H,TEMP SHLD ADDR JMP DBOOL ; ; CFIX : INTERNAL ROUTINE TO SUBTRACT DATA$BASE FROM ; ADDR FOR CONSTANT DISPLAY ; CFIX: XCHG LHLD USERPROGRAM+7 MOV A,L ! CMA ! MOV L,A MOV A,H ! CMA ! MOV H,A ! INX H DAD D RET ; ; HANDLE INTEGER FUNCTION ; DINTF LHLD PARMS XCHG LHLD USERPROGRAM+7 DAD D SHLD ADDR JMP DINT ; ; HANDLE CHAR FUNCTION ; DCHRF LHLD PARMS XCHG LHLD USERPROGRAM+7 DAD D SHLD ADDR JMP DCHR ; ; HANDLE BOOL FUNCTION ; DBOOLF: LHLD PARMS XCHG LHLD USERPROGRAM+7 DAD D SHLD ADDR JMP DBOOL ; ; HANDLE REAL FUNCTION ; DREALF: LHLD PARMS XCHG LHLD USERPROGRAM+7 DAD D SHLD ADDR JMP DREAL ; ; GVAHL : LOAD ADDR INTO HL AND IF PTR&1 THEN ; DO AN INDIRECTION ; GVAHL: LHLD ADDR LDA PTF ANI 1 RZ PUSH D MOV E,M INX H MOV D,M XCHG POP D RET ; ; HANDLE INTEGER/BOOL/REAL ARRAY ; DREALA: DBOOLA: DINTA: LXI D,SUBMSG MVI C,9 CALL BDOS ;DISPLAY SUBSCRIPT MESSAGE LXI D,INBUF MVI C,10 CALL BDOS ;GO READ BUFFER LDA INLEN MOV E,A MVI D,0 LXI H,BUFFER DAD D MVI M,0DH ;PUT CR AT END LDA BUFFER CPI 0DH JZ GETCMD ;IF CR THEN IGNORE IT LXI H,BUFFER CALL CONVERT ;CONVERT INTEGER XCHG LHLD LB MOV A,L ! CMA ! MOV L,A MOV A,H ! CMA ! MOV H,A INX H DAD D DAD H ;BECAUSE INTEGERS ARE 2 BYTES LONG ; ; NOW ALSO CHECK FOR REALS ; LDA TYP CPI REALARR if bfloat dad h ;if binary then double again else CZ HLTIMES5 ;IF REAL THEN REALLY 10 BYTES LONG endif XCHG CALL GVAHL DAD D ;GET ABS ADDR SHLD ADDR LDA TYP CPI BOOLARR JZ DBOOL ;BRANCH IF BOOL CPI REALARR JZ DREAL JMP DINT ;AND USE SOME OTHER CODE ; ; HANDLE CHAR ARRAY ; DCHRA: LXI D,CSUBMSG MVI C,9 CALL BDOS LXI D,INBUF MVI C,10 CALL BDOS ;GO READ BUFFER LDA INLEN MOV E,A MVI D,0 LXI H,BUFFER DAD D MVI M,0DH ;PUT CR AT END OF BUFFER LDA BUFFER CPI 0DH JZ GETCMD ; ; ; ; ELSE JUST A SINGLE CHAR ; LXI H,BUFFER CALL CONVERT XCHG CALL GVAHL DAD D XCHG LHLD LB MOV A,L ! CMA ! MOV L,A MOV A,H ! CMA ! MOV H,A INX H ;SUBTRACT LB DAD D ;CALC ABS ADDR SHLD ADDR JMP DCHR ;AND HANDLE AS SIMPLE CHAR ; ; HANDLE DISPLAY OF RECORDS ; DRECORD: LXI D,OFFMSG MVI C,9 CALL BDOS ;DISPLAY 'OFFSET? ' LXI D,INBUF MVI C,10 CALL BDOS ;GO GET RESPONSE LDA INLEN MOV E,A MVI D,0 LXI H,BUFFER DAD D MVI M,0DH ;PUT CR AT END LDA BUFFER CPI 0DH ;CR ONLY? JZ GETCMD ;IF SO THEN EXIT LXI H,BUFFER CALL CONVERT XCHG CALL GVAHL DAD D SHLD ADDR XRA A STA PTF ; ; NOW ASK USER THE TYPE: I)NTEGER, C)HAR, B)OOL, R)EAL ; LXI D,TYPMSG MVI C,9 CALL BDOS LXI D,INBUF MVI C,10 CALL BDOS LDA INLEN MOV E,A MVI D,0 LXI H,BUFFER DAD D MVI M,0DH ;PUT CR AT END LDA BUFFER CPI 0DH JZ GETCMD ;IGNORE NULL RESPONSE CPI 'I' JZ DINT CPI 'C' JZ DCHR CPI 'B' JZ DBOOL CPI 'R' JZ DREAL LXI D,INVTYP MVI C,9 CALL BDOS JMP GETCMD PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: SPEEDSETCMD ; ; FUNCTION: SET/CLEAR SLOWDOWN FLAG ; ; FOR SLOW EXEC MODE IN ENTPROC ; ; ; ;-------------------------------------------------------; SPEEDSETCMD: LDA NEGFLG ORA A JNZ SETOFF LXI D,SPEEDMSG MVI C,9 CALL BDOS ;DISPLAY MESSAGE LXI D,INBUF MVI C,10 CALL BDOS ;READ BUFFER LDA INLEN MOV E,A MVI D,0 LXI H,BUFFER DAD D MVI M,0DH LDA BUFFER CALL UPCASE CPI 0DH JZ GETCMD LXI H,1 CPI 'F' JZ SETIT INX H CPI 'M' JZ SETIT INX H INX H CPI 'S' JNZ GETCMD SETIT: MVI A,1 STA SLOWDOWN SHLD DLY JMP GETCMD SETOFF: XRA A STA SLOWDOWN JMP GETCMD PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: ENTRYCMD ; ; FUNCTION: TOGGLE STATE OF EFLAG ; ; ; ;-------------------------------------------------------; ENTRYCMD: LDA NEGFLG CMA STA EFLAG JMP GETCMD PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: CONVERT ; ; FUNCTION: CONVERT CHAR TO BINARY ; ; ASSUME DECIMAL NUMBER ; ; HL = ADDR OF INPUT CHARS ; ; TERM = NON-NUMERIC ; ; OUTPUT: HL = VALUE ; ; ; ;-------------------------------------------------------; CONVERT: MOV B,H MOV C,L ;MOVE POINTER TO BC LXI H,0 ;INITIAL VALUE XRA A STA NEGFLG LDAX B CPI '-' JNZ CNV1 STA NEGFLG CNV1: LDAX B CPI '0' JC CNVXIT ;RETURN IF < '0' CPI '9'+1 JNC CNVXIT ;RETURN IF > '9' MOV E,L MOV D,H ; ; NOW MULTIPLY HL BY 10 ; DAD H DAD H DAD H ;* 8 DAD D DAD D ;* 2 = * 10 ANI 0FH ;MAKE INTEGER MOV E,A MVI D,0 DAD D ;ADD NEW DIGIT INTO NUMBER INX B JMP CNV1 ;AND BACK FOR MORE CNVXIT: LDA NEGFLG ORA A RZ MOV A,L ! CMA ! MOV L,A MOV A,H ! CMA ! MOV H,A ! INX H RET PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: BPTCHK ; ; FUNCTION: THIS ROUTINE IS ENTERED WHEN ; ; A CHKBPT CALL IS EXECUTED BY ; ; THE PROGRAM UNDER TEST ; ; IF DFLAG IS <> 0 (MEANING WE ; ; ARE EXECUTING THE DEBUGGER) ; ; THEN WE CHECK TFLAG,PFLAG AND ; ; BPTLINE TO SEE IF WE SHOULD ; ; STOP ; ; ; ; IF WE STOP WE PUSH REGS ON ; ; THE STACK H,D,B,PSW ; ; ; ;-------------------------------------------------------; BPTCHK: PUSH H PUSH D PUSH B PUSH PSW ;SAVE USER'S REGS ; ; GET LINE NUMBER ; LXI H,8 DAD SP MOV E,M INX H MOV D,M ;GET RET ADDR FROM STACK INX D INX D MOV M,D ;PUT BACK REAL RETURN ADDR DCX H MOV M,E XCHG DCX H DCX H MOV E,M INX H MOV D,M ;GET LINE NUMBER XCHG SHLD LNUM ; ; CHECK TO SEE IF USER HAS HIT KEY ; IF SO THEN FAKE BFLAG SET ; MVI L,6 BIOSCALL ORA A JNZ BPTX ;BRANCH IF HE HAS HIT KEY LDA BFLAG MOV B,A LDA TFLAG ORA B MOV B,A LDA PFLAG ORA B ; ; NOW SEE IF ANY WERE NON-ZERO ; JZ NOBPT ; ; OK, IF ANY WERE NON ZERO PRINT EXECUTING LINE# MSG ; DOBPT: LDA BFLAG ORA A JZ BPT1 ;CHECK PASS/TRACE FIRST JMP BPT2 BPT0: CALL PRINTBPT LNUM: DS 2 ;FILLED IN BY CODE ABOVE LXI H,0FFFFH CALL SETIOADDR JMP GETCMD BPT2: ; ; OK, IF BREAKPOINT THEN STOP ONLY IF LNUM MATCHES BPTLINE ; LHLD BPTLINE BPT2A: XCHG LHLD LNUM CALL CMPHD JNZ BPT5 ;BRANCH IF NOT THE ONE WE WANT TO STOP AT BPTX: LHLD LNUM SHLD LNUM2 LXI D,BPTMSG MVI C,9 CALL BDOS CALL PRINTBPT LNUM2: DS 2 XRA A STA BFLAG LDA PFLAG STA PNFLAG LXI H,0FFFFH CALL SETIOADDR JMP GETCMD ; BPT1: LDA PFLAG ORA A JNZ BPT4 BPT5: LDA TFLAG ORA A JZ NOBPT ; ; IF NOT BFLAG OR PFLAG THEN IT MUST BE TFLAG ; LHLD TCOUNT DCX H SHLD TCOUNT MOV A,L ORA H JNZ NOBPT ;IF NOT DONE THEN EXIT STA TFLAG STA BFLAG ;TURN FLAGS OFF JMP BPT0 ;ELSE WRITE MSG AND EXIT ; ; IF PFLAG <> 0 THEN CHECK PLINE AGAINST LNUM ; BPT4: LHLD PLINE JMP BPT2A NOBPT: POP PSW POP B POP D POP H ;RESTORE REGS RET PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: ENTPROC ; ; FUNCTION: SEE IF EFLAG IS <> 0 IF SO ; ; THEN CALL PRINTENT ; ; ; ;-------------------------------------------------------; ENTPROC: PUSH PSW PUSH B PUSH D PUSH H LXI H,8 DAD SP MOV E,M INX H MOV D,M XCHG LXI B,8 DAD B XCHG MOV M,D DCX H MOV M,E ;ADVANCE SAVE RET ADDR BEYOND PROC NAME XCHG LXI B,-8 DAD B LXI B,8 XCHG LXI H,PNAME CALL BLKMOVE ;MOVE NAME TO WHERE WE WANT IT LDA EFLAG ORA A JZ ENTXX ;IF NOT ON GO CHECK PNFLAG CALL PRINTENT PNAME DS 8 ; ; NOW SEE IF SLOWDOWN MODE IS ON ; LDA SLOWDOWN ORA A JZ ENTXX ;IF NOT THEN SEE IF STOPPING POINT ; ; ELSE DELAY DLY SECONDS ; LHLD DLY DLP: LXI D,0 DLP1: DCX D MOV A,D ORA E JNZ DLP1 DCX H MOV A,L ORA H JNZ DLP ; ; CHECK PNFLAG ; IF ON THEN COMPARE PBNAME TO PNAME ; IF EQUAL THEN SET TCOUNT = 1 AND TFLAG = ON ; ENTXX: LDA PNFLAG ORA A JZ NOBPT ;BRANCH IF DONE ; ; STOP ONLY IF PFLAG OR BFLAG IS ON ; LDA PFLAG MOV B,A LDA BFLAG ORA B JZ NOBPT ;IF NOT THEN EXIT ; ; ELSE COMPARE THEM ; LXI H,PBNAME LXI D,PNAME MVI B,8 CALL CHRCOMPARE JNZ NOBPT ;IF NOT MATCH THEN EXIT LXI H,1 SHLD TCOUNT MVI A,1 STA TFLAG LXI D,PBMSG MVI C,9 CALL BDOS ;DISPLAY MESSAGE JMP NOBPT ;NEXT LINE WILL STOP IT PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: NONEG ; ; FUNCTION: CHECK NEGFLG, IF <> 0 THEN ; ; PRINT AN ERROR MSG AND JMP ; ; TO GETCMD ; ; ; ;-------------------------------------------------------; NONEG: LDA NEGFLG ORA A RZ ;RETURN IF OK POP H LXI D,NONEGMSG JMP ERRPRINT PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: UPCASE ; ; FUNCTION: MAKE THE CHAR IN A UPPER CASE ; ; ; ;-------------------------------------------------------; UPCASE: CPI 'a' RC ;RETURN IF < 'a' CPI 'z'+1 RNC ;RETURN IF >= 'Z' XRI 20H ;ELSE TURN OFF LOWER CASE BIT RET PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: CMPHD ; ; FUNCTION: COMPARE HL:DE AND RETURN ZFLAG ; ; ; ;-------------------------------------------------------; CMPHD: MOV A,H CMP D RNZ MOV A,L CMP E RET ;-------------------------------------------------------; ; ; ; Routine: MOVESYMTAB ; ; FUNCTION: MOVE SYMBOL TABLE UP TO LEAVE ; ; ROOM FOR USER'S VARS ; ; ; ;-------------------------------------------------------; MOVESYMTAB: ; ; FIRST FIND END OF TABLE AND CALC LENGTH ; LXI B,ENTSIZE LXI D,0 LHLD USERPROGRAM+3 ;GET ADDR OF SYMTAB BEGINING MS1: MOV A,M ORA A JZ MS2 DAD B XCHG DAD B XCHG JMP MS1 ; ; NOW ADJUST FOR LAST ENTRY ; MS2: DAD B XCHG DAD B ; ; NOW HL = SIZE (IN BYTES) AND DE = ^TO END OF SYMTAB ; MOV C,L MOV B,H LHLD USERPROGRAM+5 ;GET SIZE OF DATA AREA DAD D ;CALC WHERE TO MOVE SYMTAB TO PUSH D XCHG LHLD USERPROGRAM+9 ;GET STACK SIZE XCHG DAD D POP D MS3: LDAX D MOV M,A DCX H DCX D DCX B MOV A,B ORA C JNZ MS3 ; ; STORE SYMTAB AWAY ; LDAX D MOV M,A ;MOVE LAST CHAR SHLD SYMTAB ;PTR TO BEGINING OF SYMBOL TABLE RET PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: GETID ; ; FUNCTION: GIVEN POINTER IN DE GATHER ID ; ; AND PUT IN 'ID' ; ; ; ;-------------------------------------------------------; GETID: LXI H,ID ;BLANK IT FIRST MVI B,8 G1: MVI M,' ' INX H DCR B JNZ G1 ; ; NOW GATHER ; LXI H,ID G2: LDAX D CALL UPCASE cpi '_' ;allow and ignore _ jz g2a CPI 'A' JC G3 ;GO CHECK FOR DIGITS CPI 'Z'+1 RNC ;RETURN IF NOT 'A'..'Z' MOV M,A INX H g2a: INX D JMP G2 ;AND BACKAGAIN G3: CPI '0' RC CPI '9'+1 RNC ;IF NOT 0..9 THEN RETURN MOV M,A INX H INX D JMP G2 ;AND BACK FOR MORE PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: GETENTRY ; ; FUNCTION: GATHER ID(S) AND LOOK UP VAR ; ; IN SYMBOL TABLE ; ; POSSIBLE EXITS ARE FOR UNDEFINED AND WRONGTYPE ; ; IDENTIFIERS/QUALIFIERS ; ; ; ;-------------------------------------------------------; GETENTRY: XRA A STA PTRFLG ;SET TO 1 IF ^ FOLLOWS AN INTEGER LXI D,BUFFER+1 LDA BUFFER+1 CPI 'A' JNC GE0 ;BRANCH IF ID STARTS AT BUFFER+1 INX D ;ELSE ALLOW COMMA,SPACE, ETC FIRST GE0: CALL GETID XCHG SHLD ENDIDPTR ;SAVE FOR LOOKUP LATER CPI ':' ;QUALIFIED NAME? JZ TWOSTAGE ;BRANCH IF YES ; ; ELSE SET PNUM TO 0 AND LOOK FOR A GLOBAL ; XRA A STA PNUM ; ; NOW SEARCH FOR QUALIFIED OR UNQUALIFIED NAME ; GE1: CALL SEARCH JNZ UNDEF ;BRANCH IF NOT FOUND LHLD ADDR XCHG LHLD USERPROGRAM+7 ;CALC ABS ADDR DAD D SHLD ADDR CALL PTRCHK ;GO HANDLE PTF FIELD LDA TYP CPI INT RNZ ;RETURN IF NOT INTEGER TYPE ; ; ELSE SEE IF TERMINATED BY ^ ; LHLD ENDIDPTR MOV A,M CPI '^' RNZ ;RETURN IF NO ; ; ELSE DO A LEVEL OF INDIRECTION ; MVI A,1 ;SET FLAG STA PTRFLG LHLD ADDR MOV E,M INX H MOV D,M XCHG SHLD ADDR ;DO THE INDIRECTION AND STORE THE RESULT RET ;AND WE ARE DONE ; ; HANDLE QUALIFIER ; TWOSTAGE: CALL SEARCH JNZ UNDEF ;BRANCH IF QUALIFIER IS UNDEFINED LDA TYP ;MAKE SURE IT IS PROC/FUNC CPI PROCNAME JZ TS1 CPI INTFUNC JZ TS1 CPI CHRFUNC JZ TS1 CPI BOOLFUNC JZ TS1 CPI REALFUNC JZ TS1 JNZ WRONGTYPE ;BRANCH IF NOT PROC/FUNC TS1: LHLD ENDIDPTR INX H ;SKIP : XCHG CALL GETID ;GET SECOND NAME XCHG SHLD ENDIDPTR JMP GE1 ;AND GO HANDLE THAT PART UNDEF: POP H ;FLUSH RETURN ADDRESS LXI D,UNDEFMSG JMP ERRPRINT WRONGTYPE: POP H ;FLUSH RETURN ADDR LXI D,WRONGTYPEMSG JMP ERRPRINT ; ; A LOCAL ROUTINE TO CHECK PTF AND HANDLE ACCORDINGLY ; PTRCHK: LDA PTF CPI 'Y' RNZ ;RETURN IF NOT LHLD ADDR ;IF YES DO A LEVEL OF INDIRECTION MOV E,M INX H MOV D,M XCHG SHLD ADDR RET ;AND EXIT PAGE ;-------------------------------------------------------; ; ; ; ROUTINE: SEARCH ; ; FUNCTION: SEARCH THE SYMBOL TABLE FOR ; ; THE ID IN 'ID' WITH THE PROC ; ; NUM IN PNUM ; ; ; ;-------------------------------------------------------; SEARCH: LHLD SYMTAB ;GET BASE OF TABLE ADDR S1: MOV A,M ORA A JZ XNOTFOUND ;BR IF AT END OF TABLE LXI D,ID MVI B,8 CALL CHRCOMPARE ;SEE IF A MATCH JZ MAYBE ;BRANCH IF ID MATCHES AGAIN: LXI D,ENTSIZE DAD D JMP S1 ;BACK TO TRY AGAIN ; ; OK, ID MATCHES SEE IF PNUM MATCHES ; MAYBE PUSH H ;SAVE PTR TO ENTRY LXI D,TYP-ID DAD D MOV A,M CPI INT JC XFOUND ;IF PROC/FUNC THEN FOUND IT POP H PUSH H LXI D,PNUM-ID DAD D MOV B,M LDA PNUM CMP B JZ XFOUND ;BRANCH IF OK POP H ;ELSE RESTORE POINER JMP AGAIN ;AND CONTINUE XNOTFOUND: XRA A INR A ;SET NON-ZERO RET XFOUND: POP D ;GET PTR TO SYM BACK AGAIN LXI H,ID LXI B,ENTSIZE CALL BLKMOVE ;MOVE IT XRA A RET ;SET ZERO FLAG ; ; LOCAL ROUTINE TO COMPARE CHAR STRING ; CHRCOMPARE: PUSH H ;SAVE THIS REG CHR1: LDAX D CMP M ;MATCH? JNZ CHR2 ;BRANCH IF NO INX H INX D DCR B JNZ CHR1 POP H RET ;OK END OF LOOP CHR2: POP H ;GET PTR BACK RET NEXTPROG SET $ LASTPROG EQU NEXTPROG LASTDATA EQU NEXTDATA IF bfloat and HARDWARE if trs80 userprogram equ 6400H else USERPROGRAM EQU 2100H endif ENDIF IF BFLOAT AND (NOT HARDWARE) IF TRS80 USERPROGRAM EQU 2700H+4200H ELSE USERPROGRAM EQU 2700H ENDIF ENDIF if bcd if trs80 userprogram equ 1E00H+4200H else userprogram equ 1E00h endif endif