FORMAT (? ARCTAN SRCABSSQR SRCADDSUB SRC BYTOT SRC( BYTIN SRCFILNAM SRCFILEXT SRCFPRLOP SRCFPERR SRCFPDIVD SRCFMULT SRC !FADDSB SRC"#$FLTIN SRC%&'FPSQR SRC(FXDCVT SRCD)*+,-./01FPMAC SRC'23456REWRIT SRCUVWMPNORM SRC XYMAIN SRCEZ[\z{|}~MULT SRCINPT SRCINPT SRC INDIR SRCLOOK SRCLAST SRCOPFILE SRC NATLOG SRCPSTAT SRCTEXT SRC; INTRINSIC FUNCTION FOR CALCULATING ARCTANGENT ; NAME ARCTAN ENTRY ARCTAN,L131 INCLUDE DEFLT.SRC INCLUDE FCTMAC.SRC ; F SET 0 ; ; function arctan( x: real ): real; ; const ; a1 = 3.7092563; ; a2 = -7.10676; ; a3 = -0.26476862; ; b0 = 0.17465544; ; b1 = 6.762139; ; b2 = 3.3163354; ; b3 = 1.44863154; ; var i,k: real; ; signchg, adjust: boolean; ; begin arctan: L131: L150 ENTR D,2,10 ; adjust := false; MOV -8(IX),A ; signchg := false; MOV -9(IX),A ; POP H LXI B,8 DADD B LXI B,4 LDIR LXI H,320 MOV D,A MOV E,A PUSH H PUSH D GRET D,-4 ; begin JNC L228 ; adjust := true; MVI -8(IX),1 ; x := 1.0 / x LXI H,320 MOV D,A MOV E,A PUSH H PUSH D ; end; LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR FDVD D,-4 LXI H,3 DADD S XCHG PUSH IX POP H LXI B,11 DADD B XCHG LXI B,4 LDDR POP H POP H L228 ; i := x * x; LXI H,-4 DADD S SPHL XCHG P,-4 DADD S SPHL XCHG PUSH IX POP H DCX H DCX H DCX H LXI B,4 LDIR DADD D,-4 LXI H,1009 LXI D,-19127 PUSH H PUSH D ; (b2 + i + a3 / LXI H,618 LXI D,8043 PUSH H PUSH D LXI H,-4 DADD S SPHL XCHG PUSH IX POP H DCX H DCX H DCX H LXI B,4 LDIR DADD D,-4 LXI H,-61 LXI D,-14368 PUSH H PUSH D ; (b3 + i) ) ) ); LXI H,348 LXI D,-18848 PUSH H PUSH D LXI H,-4 DADD S SPHL XCHG PUSH IX POP H DCX H DCX H DCX H LXI B,FPINIT SRC7FOUT SRC289:;<=>FPTEN SRC?FCTMAC SRC9@ABCDEFGRESET SRC HIROTATE SRCJROUND SRC KLSETCON SRC#]^_`aSAVREG SRCbSRELOP SRCcdefSINCOS SRC!ghijkSETFTN SRC&lmnopSTRFCT SRCqrsSTRLOP SRCtuvSQRT SRCwxyRBLOCK SRC 1.0 then LXI H,-4 DADD S SPHL XCHG PUSH IXUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR MULT D,-4 LXI H,3 DADD S XCHG PUSH IX POP H XCHG LXI B,4 LDDR POP H POP H ; k := x * (b0 + a1 / LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR LXI H,-423 LXI D,27760 PUSH H PUSH D LXI H,630 LXI D,-19911 PUSH H PUSH D ; (b1 + i + a2 / LXI H,876 LXI D,12728 PUSH H PUSH D LXI H4 LDIR DADD D,-4 FDVD D,-4 DADD D,-4 FDVD D,-4 DADD D,-4 FDVD D,-4 DADD D,-4 MULT D,-4 LXI H,3 DADD S XCHG PUSH IX POP H LXI B,-4 DADD B XCHG LXI B,4 LDDR POP H POP H ; if adjust then k := halfpi - k; CMP -8(IX) JNC L284 LXI H,356 LXI D,-30739 PUSH H PUSH D LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-7 DADD B LXI B,4 LDIR DSUB D,-4 LXI H,3 DADD S XCHG PUSH IX POP H LXI B,-4 DADD B XCHG LXI B,4 LDDR POP H POP H L284 ; if signchg then k := - k; CMP -9(IX) JNC L297 LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-7 DADD B LXI B,4 LDIR NEGT E LXI H,3 DADD S XCHG PUSH IX POP H LXI B,-4 DADD B XCHG LXI B,4 LDDR POP H POP H L297 ; arctan := k ; end; LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-7 DADD B LXI B,4 LDIR LXI H,3 DADD S XCHG PUSH IX POP H LXI B,15 DADD B XCHG LXI B,4 LDDR POP H POP H EXIT D,4 ; ;INTEGER ABSOLUTE VALUE AND SQUARE ROUTINES AND F.P. ABSOLUTE VAL. ; NAME ABSSQR ENTRY ABS,FPABS,SQR,L115,L116,L117 EXT IMULT ; ;ABSOLUTE VALUE RETURNS THE ABSOLUTE VALUE OF THE SIXTEEN BIT ;NUMBER IT IS PASSED IN HL. L115: ABS: BIT 7,H RZ ;POSITIVE NUMBER XCHG ;COMPLEMENT NUMBER MOV H,A MOV L,A XRA A DSBC D RET ; ; RETURN THE ABSOLUTE VALUE OF A FLOATING POINT NUMBER ; L116: FPABS: POP H ;GET RETURN ADDRESS POP D ;GET LOW WORD OF NUMBER POP B ;GET HIGH WORD RES SIGN,; Decimal byte add/subtract procedures for fixed point package ; function addbyte( var carry: carrtyp; a, b: byte ): byte; external; entry addbyte addbyte pop h ; hl := return address pop b ; b := first operand, c := second operand inx s ; Skip over length byte. pop d ; de := address of the carry flag ldax d ; a := carry flag cpi 1 cmc ; carry := not carry mov a,b adc c ; a := a + c + carry daa mov b,a mvi a,0 jrnc NoCarry ; Branch if carry = 0 mvi a,1 NoCarry schl  ; a := carry flag cpi 1 cmc ; carry := not carry mov a,b sbb c ; a := a - c - carry daa mov b,a mvi a,0 jrnc NoCar ; Branch if carry = 0 mvi a,1 NoCar stax d ; Set passed carry flag to correct value. xra a mov d,a mov e,b p;PUTS BYTE IN FILE DESCRIPTOR ; NAME BYTOT ENTRY BYTOT,BLKOT,NAMERR,DERR EXT SELDSK,POPHDB,PERROR,PUSHBD INCLUDE DEFLT.SRC ; ; ;BYTE OUT PUTS THE BYTE PASSED IN A IN THE FILE DESCRIPTOR ;POINTED TO BY HL. REGISTER F IS DESTOYED. BYTOT CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A MOV A,C ; BYTE TO WRITE ===> A LXI D,BYTPT DAD D ;BYTE COUNTER INR M JNZ NTFULL ; FALL THROUGH IF BUFFER IS FULL. ;BLKOT WRITES A 256 BYTE BLOCK WHOSE FILE DESCRIPTOR IS POINTED ;TO BY HL - BYTPT. IT DE 7 DADD B LXI B,4 LDIR NEGT E LXI H,3 DADD S XCHG PUSH IX POP H LXI B,-4 DADD B XCHG LXI B,4 LDDR POP H POP H L297 ; arctan := k ; end; LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-7 DADD B LXI B,4 LDIR LXI H,3 DADD S XCHG PUSH IX POP H LXI B,15 DADD B XCHG LXI B,4 LDDR POP H POP H EXIT D,4 ; C ;CLEAR SIGN BIT PUSH B ;RESTORE NUMBER PUSH D ;....AND.... PCHL ;RETURN ; ; SQUARE AN INTEGER ; L117: SQR: MOV D,H ;SET DE = HL MOV E,L JMP IMULT ;MULTIPLY HL BY HL ; SIGN: EQU 7 ;POSITION OF MANTISSA SIGN BIT ;POSITIVE NUMBER XCHG ;COMPLEMENT NUMBER MOV H,A MOV L,A XRA A DSBC D RET ; ; RETURN THE ABSOLUTE VALUE OF A FLOATING POINT NUMBER ; L116: FPABS: POP H ;GET RETURN ADDRESS POP D ;GET LOW WORD OF NUMBER POP B ;GET HIGH WORD RES SIGN,tax d ; Set passed carry flag to correct value. xra a mov d,a mov e,b pchl entry subbyte subbyte pop h pop b ; b := first operand, c := second operand inx s ; Skip over length byte. pop d ; de := address of the carry flag ldax d ; a := carry flag cpi 1 cmc ; carry := not carry mov a,b sbb c ; a := a - c - carry daa mov b,a mvi a,0 jrnc NoCar ; Branch if carry = 0 mvi a,1 NoCar stax d ; Set passed carry flag to correct value. xra a mov d,a mov e,b pSTROYS DE, BC, F. ;IF LSBYT IS FF THE BLOCK IS NOT WRITTEN. IN ANY EVENT, LSBYT IS SET TO ;ZERO. LSBYT SERVES AS A FLAG FOR THE VERY FIRST BYTOT DONE TO A FILE. BLKOT: PUSH PSW PUSH H ;BYTE COUNTER LXI D,-BYTPT-3 DAD D ;'FLAGS' BYTE BIT 4,M ;'RANDOMLY ACCESSED' BIT JZ BLKOT1 ;FILE NOT RANDOMLY ACCESSED IF NOT COMPILER ;COMPILER DOESN'T USE DIRECT ACCESS ;FILE HAS BEEN RANDOMLY ACCESSED. BUFFER IS REFILLED WHEN FULL BY ;RANDOMLY WRITING THE TWO 128 BYTE BLOCKS TO THE FILE AND RANDOMLY ;READING THE NEXT TWO BLOCKS INTO THE BUFFER. ; WRITE SECOND BUFFER FIRST INX H INX H INX H PUSH H ;FCB CALL SELDSK LXI D,DATAB+128 DAD D ;FIRST BYTE FOR OUTPUT XCHG MVI C,26 ;CODE TO SET DMA CALL CPM POP D PUSH D ;SAVE FCB ADDRESS MVI C,SETRAN-2 ;WRITE RANDOM,128 BYTES FROM BUFFER CALL CPM POP H ;FILE CONTROL BLOCK PUSH H ;WRITE FIRST 128-BYTE BLOCK FROM BUFFER LXI D,RANREC DAD D ;LOW BYTE OF BLOCK NUMBER DCR M ;SUBTRACT ONE FOR PREVIOUS BLOCK MOV A,M INR AT BYTE FOR INPUT XCHG MVI C,26 ;CODE TO SET DMA CALL CPM POP H ;FCB PUSH H DCX H ;SECOND 'FLAGS' BYTE BIT 0,M ;WRITING FIRST RECORD? RES 0,M ;RESET FLAG LXI D,RANREC+1 DAD D ;LOW BYTE OF BLOCK NUMBER JRZ W2SETC ;NOT WRITING FIRST RECORD MOV M,A ;READ BLOCKS ZERO AND ONE INX H XRA A MOV M,A INX H MOV M,A JR R2SETA W2SETC: INR M ;ADD TWO FOR NEXT BLOCK TO READ INR M MOV A,M CPI 2 JRNC R2SETA ;NO CARRY INX H ;HIGH BYTE INR M JRNZ R2SETA ;NO CARRY INX H ;OVE POP D PUSH D LXI H,DATAB+128 ;FIRST FREE BYTE DAD D XCHG MVI C,26 ;SET DMA FOR SECOND BLOCK CALL CPM POP D ;FCB PUSH D MVI C,SETRAN-3 ;RANDOM READ CALL CPM ;SET BYTE POINTER POP H ;FCB LXI D,BYTPT ;BUFFER BYTE POINTER/COUNTER DAD D MVI M,0 ;SET BYTE COUNT TO ZERO LXI D,-BYTPT+RANREC-1 DAD D ;CURRENT RECORD BYTE MVI M,0 ;SET CURRENT RECORD TO ZERO POP H POP PSW JMP NTFULL ENDIF ; ;WRITE BLOCK FOR NON-RANDOMLY ACCESSED FILES BLKOT1: LXI D,LSBYT+3 DAD D ; LSBY,128+DATAB DAD D ; HL NOW POINTS TO SECOND HALF OF DATA BUFFER. XCHG MVI C,26 ; CP/M CODE TO SET DMA ADDRESS. CALL CPM POP H XCHG MVI C,21 ; CP/M CODE TO WRITE A SECTOR. CALL CPM ORA A JRNZ DERR FIRSTC POP H POP PSW NTFULL MOV E,M MVI D,0 DAD D INX H INX H ; HL NOW POINTS TO LOCATION FOR NEW BYTE. MOV M,A ; STORE BYTE IN FILE DESCRIPTOR. JMP POPHDB ;THIS DIAGONOSES THE TYPE OF DISK WRITE ERROR. DERR LXI H,UNKERR ;DEFAULT ERROR MESSAGE. CPI 1 ;TEST FOR ERROR ;RETURNS BYTE FROM FILE ONE BYTE AT A TIME ; NAME BYTIN ENTRY BYTIN EXT SELDSK,POPHDB,PUSHBD INCLUDE DEFLT.SRC ; ; BYTIN CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A LXI D,BYTPT DAD D MOV A,M INX H CMP M CMC ; MAKE CARRY 0 UNLESS END OF BLOCK. JNZ NTEMPT ; BRANCH AROUND BLOCK READ IF NOT EMPTY. ;THIS READS A 256 BYTE BLOCK INTO THE DATA AREA OF THE FILE DESCRIPTOR ;POINTED TO HL - LSBYT. IT MODIFIES BYTPT, LSBYT, ALL REGISTERS EXCEPT HL AND A. PUSH PSW PUSH H LXI D,-LSBYT ;CHECK FOR A BORROW JRNZ W2SETB ;NO BORROW INX H ;HIGH BYTE DCR M MOV A,M INR A ;CHECK FOR A BORROW JRNZ W2SETB ;NO BORROW INX H ;OVERFLOW BYTE DCR M W2SETB: POP H PUSH H ;SAVE FCB LXI D,DATAB ;FIRST FREE BYTE DAD D XCHG MVI C,26 ;SET DMA FOR FIRST BLOCK CALL CPM POP D ;FCB PUSH D MVI C,SETRAN-2 ;RANDOM WRITE CALL CPM ;READ FIRST BLOCK FROM FILE INTO BUFFER POP D PUSH D ;FCB LXI H,RANREC-1 DAD D ;SET CURRENT RECORD TO ZERO MVI M,0 LXI H,DATAB DAD D ;FIRSRFLOW BYTE INR M R2SETA: POP D ;FILE CONTROL BLOCK PUSH D MVI C,SETRAN-3 ;READ RANDOM,128 BYTES INTO BUFFER CALL CPM POP H ;FILE CONTROL BLOCK PUSH H ;READ SECOND 128-BYTE BLOCK INTO BUFFER LXI D,RANREC DAD D ;LOW BYTE OF BLOCK NUMBER INR M ;ADD TWO FOR NEXT BLOCK TO READ JRNZ R2SETB ;NO CARRY INX H ;HIGH BYTE INR M JRNZ R2SETB ;NO CARRY INX H ;OVERFLOW BYTE INR M R2SETB: POP D ;FILE CONTROL BLOCK PUSH D LXI H,RANREC-1 DAD D MVI M,0 ;SET CURRENT RECORD TO ZERO T BYTE MOV A,M MVI M,0 ; SET LSBYT TO ZERO. INR A ; TEST LSBYT FOR FF JRZ FIRSTC ; BRANCH IF THIS IS FROM THE FIRST CALL OF BYTOT. LXI D,FCB-LSBYT DAD D ; HL NOW POINTS TO FCB. CALL SELDSK ; SELECT PROPER DRIVE. PUSH H LXI D,DATAB DAD D ; HL NOW POINTS TO START OF DATA BUFFER. XCHG MVI C,26 ; CP/M CODE TO SET DMA ADDRESS. CALL CPM POP H PUSH H XCHG MVI C,21 ; CP/M CODE TO WRITE A SECTOR. CALL CPM ORA A ; TEST FOR ERROR CODE. JRNZ DERR POP H PUSH H LXI DIN EXTENDING FILE. JRNZ NTEXTR LXI H,EXTERR NTEXTR CPI 2 ; TEST FOR DISK FULL JRNZ NTDFUL LXI H,FULERR NTDFUL CPI 255 ; TEST FOR DIRECTORY FULL JRNZ NTDIRF LXI H,DIRERR NTDIRF JMP PERROR UNKERR DB 'Disk erro','r'+80H ; FOR UNDEFINED ERROR CODES. EXTERR DB 'Error in extending fil','e'+80H FULERR DB 'Disk ful','l'+80H DIRERR DB 'Directory ful','l'+80H NAMERR IF NOT COMPILER ;compiler doesn't need this DB 'Bad filename',CR,LF+80H ENDIF ; -3 DAD D ;FLAGS BYTE BIT 4,M ;'RANDOMLY ACCESSED' BIT JZ BYTIN1 ;NOT RANDOMLY ACCESSED IF NOT COMPILER ;COMPILER DOESN'T USE DIRECT ACCESS ;RANDOMLY ACCESSED. FILL BUFFER USING RANDOM READ FUNCTION INX H INX H INX H ;FCB CALL SELDSK ;SELECT PROPER DRIVE POP D PUSH D INX D ;START OF DATA BUFFER MVI C,26 ;CP/M CODE FOR SETTING DMA ADDRESS CALL CPM POP H PUSH H LXI D,-LSBYT+RANREC ;LOW BYTE OF RANDOM RECORD NUMBER DAD D INR M ;INCREMENT COUNT MOV A,M CPI 1 JRNC RRDSET INX H ;CARRY TO HIGH BYTE INR M JRNZ RRDSET INX H ;CARRY TO OVERFLOW BYTE INR M RRDSET POP H PUSH H LXI D,-LSBYT ;FBA DAD D XCHG MVI C,33 ;RANDOM READ CALL CPM ;READ SECOND SECTOR POP H PUSH H LXI D,128+DATAB-LSBYT DAD D ;SECOND HALF OF DATA BUFFER XCHG MVI C,26 ; SET DMA ADDRESS CALL CPM POP H PUSH H LXI D,-LSBYT+RANREC DAD D INR M ;INCREMENT RANDOM RECORD COUNT MOV A,M CPI 1 JRNC RRESET INX H ;CARRY TO HIGH BYTE OF RECORD COUNT NTS TO START OF DATA BUFFER. MVI C,26 ; CP/M CODE FOR SETTING DMA ADDRESS. CALL CPM POP H PUSH H LXI D,FCB-LSBYT DAD D XCHG MVI C,20 ; CP/M CODE FOR READ SECTOR. CALL CPM ORA A JRNZ EOF99 ;READ SECOND SECTOR TO FILL 256 BYTE BLOCK. POP H PUSH H LXI D,128+DATAB-LSBYT DAD D ; HL NOW POINTS TO SECOND HALF OF DATA BUFFER. XCHG MVI C,26 ; CP/M CODE FOR SETTING S_DMA ADDRESS. CALL CPM POP H PUSH H LXI D,FCB-LSBYT DAD D ; HL NOW POINTS TO FCB. XCHG MVI C,20 BYTE OF OFFSET INTO DATA BLOCK ZERO. INX H INX H DAD D ; HL NOW POINTS TO DATA BYTE. POP PSW ; RESTORE CARRY. MOV A,M JMP POPHDB ;  CODE FOR HALF FULL BUFFER. POP PSW ORA A ; NOT EOF QUITE YET. NTEMPT PUSH PSW ; SAVE CARRY (CARRY = 1 ===> EOF). INR A ; INCREMENT BYTE POINTER/COUNTER. DCX H MOV M,A ; STORE UPDATED BYTE POINTER.COUNTER. MOV E,A MVI D,0 ; MAKE HIGH ;DECODES A STRING FROM THE TEXT BUFFER AS A FILE SPECIFICATION ; NAME FILNAM ENTRY FILNAM EXT TIN,NAMERR,TXTYP,POPHDB,PUSHBD INCLUDE DEFLT.SRC ; ; ;IT STORES THE CORRESPONDING CP/M FILE CONTROL BLOCK (FCB) IN A 34 BYTE ;BLOCK STARTING AT HL. THE 34TH BYTE IS THE DRIVE NUMBER AND IS NOT ;LOOKED AT BY CP/M (IT IS LOOKED AT BY SELDSK). FILNAM CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A PUSH PSW MVI M,0 ; MAKE FIRST BYTE OF FCB ZERO. DCX H DCX H DCX H ; FILE BUFFER ADDRESS MVI M,0 ;ers in buffer. ; CHECK FOR LST: OR CON: PUSH PSW ; SAVE CHAR. PUSH H LHLD 6 ; HL POINTS TO TOP OF MEMORY LXI D,-GETP DAD D ; TEXT-IN POINTER MVI A,3 ADD M MOV E,A MVI D,0 DAD D ; FOURTH CHAR OF FILE NAME MOV A,M CPI ':' ; IS IT A ':' POP H JRZ LSTCON ; YES, CHECK FOR LST: OR CON: ; CHECK FOR SPECIFIED DRIVE POP PSW ; GET CHAR. SUI 'A' ; A..P ===> 0..15 MOV B,A PUSH H ; SAVE 34th BYTE LHLD 6 LXI D,-GETP DAD D ; TEXT_IN_POINTER MVI A,1 ADD M MOV E,A INR M JRNZ RRESET INX H ;CARRY TO OVERFLOW BYTE OF RECORD COUNT INR M RRESET: POP H PUSH H LXI D,-LSBYT DAD D ;FCB XCHG MVI C,33 ;RANDOM READ CALL CPM POP H POP PSW ORA A ;CLEAR CARRY FOR NOT EOF JMP NTEMPT ENDIF ;DOING SEQUENTIAL READS BYTIN1: POP H PUSH H MOV A,M ADI 1 ; TEST LSBYT FOR FFH JNC BEOF ; END OF FILE HAS BEEN REACHED. LXI D,FCB-LSBYT DAD D ; HL NOW POINTS TO FCB. CALL SELDSK ; SELECT PROPER DRIVE. POP D PUSH D INX D ; DE NOW POI; CP/M CODE FOR READ SECTOR. CALL CPM ORA A JRNZ EOF360 POP H POP PSW ORA A ; CLEAR CARRY FOR NOT EOF INDICATION. JMPR NTEMPT EOF99 BEOF POP H POP PSW STC ; SET CARRY FOR EOF INDICATION. JMPR NTEMPT EOF360 POP H MVI M,7FH ; CODE FOR HALF FULL BUFFER. POP PSW ORA A ; NOT EOF QUITE YET. NTEMPT PUSH PSW ; SAVE CARRY (CARRY = 1 ===> EOF). INR A ; INCREMENT BYTE POINTER/COUNTER. DCX H MOV M,A ; STORE UPDATED BYTE POINTER.COUNTER. MOV E,A MVI D,0 ; MAKE HIGH SET ALL FLAGS TO ZERO LXI B,4 DAD B PUSH H ; HL POINTS TO START OF FCB NAME FIELD. ;FILL THE NAME FIELD WITH SPACES (THE DEFAULT CHARACTER). MVI B,11 ; 8 CHARACTERS FOR FILE NAME + 3 FOR FILE TYPE. DEFSP MVI M,' ' ; STUFF A SPACE. INX H DJNZ DEFSP ;MAKE THE REST OF THE FCB ZERO. MVI B,DEVNUM-11-1 ;NUMBER OF BYTES TO ZERO. ZEROLP MVI M,0 INX H DJNZ ZEROLP SKIPSP CALL FTIN ; GET A CHARACTER FROM THE TEXT BUFFER. JRZ SKIPSP ; IGNORE SPACES. JRC FILNER ; Error if no charact MVI D,0 DAD D ; LOOK AT NEXT CHARACTER MOV A,M CPI CR ; IS IT A CARRIAGE RETURN? JRNZ DLET ; NO MVI A,' ' ; FILENAME IS 1 CHAR, ADD A SPACE DLET: POP H ; 34th BYTE OF FCB CPI ':' ; IS A DRIVE SPECIFIED? JRZ DRVSP PUSH H LHLD 6 ; HL POINTS TO TOP OF MEMORY. LXI D,-GETP DAD D ; HL POINTS TO TEXT IN POINTER. DCR M ; PUSH IT BACK 1 CHARACTER. LHLD 6 DCX H ; HL POINTS TO DEFAULT DRIVE #. MOV A,M POP H JR DRVNSP ; Drive not specified ;CHARACTER IN A SHOULD BE THE DRIVE LETTER. DRVSP: CALL FTIN ; read past the : MOV A,B ; DRIVE LETTER ===> A DRVNSP: CPI MAXDRV ; IS IT A VALID DRIVE NUMBER? JRC DRVOK ;RETURN AN ERROR CODE. FILNER POP H ; CLEAN UP THE STACK. NAMER LXI H,NAMERR CALL TXTYP ; 'Bad filename' POP PSW STC JMP POPHDB LSTCON: POP PSW ; GET CHAR. CPI 'L' ; CHECKING FOR LST: JRZ LST1 CPI 'C' ; CHECKING FOR CON: JRNZ NAMER ; NEITHER, BAD FILE NAME CALL FTIN CPI 'O' ; SECOND LETTER OF CON: JRNZ NAMER ; NO, BAD FILEME FIELD MVI B,9 ; LIMIT + 1 TO # OF CHARS IN FILE NAME. SKSP CALL FTIN JRC NOMORE ; Branch if the text in buffer is empty. JRZ SKSP ; Skip spaces. CPI '.' JRZ NXTPT ; Branch if we have reached the type field. MOV M,A ; STORE THE CHARACTER IN THE FCB. INX H ; INCREMENT THE FCB POINTER. DJNZ SKSP JMPR NAMER ;TOO MANY CHARACTERS IN A FIELD. NXTPT MOV C,B MVI B,4 ; LIMIT +1 OF # OF CHARS IN FILE TYPE. NOIMAG DCR C JRZ SKSP INX H JMPR NOIMAG ; ; FTIN -- FILE TIN, CONVE;ROUTINES SUPPORT RESETTING AN INPUT FILE AND REWRITING AN OUTPUT FILE ; NAME FILEXT ENTRY SCAN,MOVNAM EXT TIN,TOUT,FILNAM,MXOUT1 INCLUDE DEFLT.SRC ;SCAN CHECKS THE OUTPUT FILE LIST FOR THE CONTENTS ;OF HL. Y POINTS TO THE START OF THE LIST ;SCAN SETS THE CARRY AND RETURNS THE ELEMENTS ADDRESS IN BC SCAN: INX Y MOV A,L LXI B,MXOUT1 ;NUMBER OF BYTES OF OUTPUT FILE ADDRS. CONTLK: CMP 0(Y) JRZ FNDLOW ;LOW BYTE MATCH INX Y INX Y ;NEXT OUTPUT FILE ADDRESS DCR B DJNZ CONTLK XRA A RN THESE REGISTERS UNCHANGED ;AND THE FILENAME REMOVED FROM THE STACK ;THE LENGTH OF THE STRING TO BE MOVED IS IN C STAKSP EQU 3 MOVNAM: CALL TIN ;EXHAUST TI BUFFER JRNC MOVNAM PUSH H ;FILE CONTROL BLOCK LXI H,STAKSP;GET DISPLACEMENT DAD S XRA A MOV B,A DAD B ;ADD LENGTH PUSH H ;NEW STACK POINTER ;MOVE FILENAME TO THE TI BUFFER MOV B,C TOTI: MOV C,M CALL TOUT DCX H DJNZ TOTI ;MOVE A CARRIAGE RETURN INTO TI BUFFER MVI C,CR CALL TOUT ;PARSE FILENAME AND MOVE IT INTO BUFLOW BYTE PUSH B ;SECOND RETURN ADDRESS MVI A,0 ;CLEAR ACC WITHOUT DISTURBING CARRY RET EXAF PUSH B ;NEW SP XTHL ;HL <- NEW SP POP B ;GET FILE CONTROL BLOCK MOV M,D ;HIGH BYTE OF FIRST RETURN ADDRESS DCX H ;DECR. NEW SP MOV A,E ;LOW BYTE OF FIRST RETURN ADDRESS MOV D,B ;FILE CONTROL BLOCK INTO DE MOV E,C POP B ;SECOND RETURN ADDRESS SPHL ;REMOVE FILENAME FROM STACK XCHG ;FILE CONTROL BLOCK POP D ;HIGH BYTE OF FIRST RETURN ADDRESS MOV E,A ; NAME CALL FTIN CPI 'N' ; THIRD LETTER OF CON: JRNZ NAMER POP H ; CON:! LXI B,-4 DAD B ; FBA BSET 7,M ; SET FLAG FOR CONSOLE FILE JR LST2 LST1: CALL FTIN CPI 'S' ; SECOND LETTER OF LST: JRNZ NAMER CALL FTIN CPI 'T' ; THIRD LETTER JRNZ NAMER POP H LXI B,-4 DAD B ; FBA BSET 6,M ; SET FLAG FOR LISTING DEVICE LST2: CALL FTIN ; READ THE ':' NOMORE: POP PSW ORA A JMP POPHDB DRVOK MOV M,A ; STORE DRIVE NUMBER IN 34TH BYTE OF FCB POP H ; START OF FCB NARTS ALL LETTERS TO UPPER CASE FTIN: CALL TIN CPI 'a' ; is it >= 'a' JRC FTIN1 ; YES, CPI 'z'+1 ; IS IT <= 'z' JRNC FTIN1 ; YES, ANI 5FH ; THEN CONVERT TO UPPER CASE FTIN1: CPI ' ' ; COMPARE TO A SPACE RET ; AND RETURN ; R IN THE FCB. INX H ; INCREMENT THE FCB POINTER. DJNZ SKSP JMPR NAMER ;TOO MANY CHARACTERS IN A FIELD. NXTPT MOV C,B MVI B,4 ; LIMIT +1 OF # OF CHARS IN FILE TYPE. NOIMAG DCR C JRZ SKSP INX H JMPR NOIMAG ; ; FTIN -- FILE TIN, CONVE;ELEMENT NOT FOUND RET ;FOUND LOW BYTE ;CHECK HIGH BYTE FNDLOW: MOV A,H INX Y DCR B CMP 0(Y) JRZ FNDIT ;HIGH BYTE MATCH MOV A,L INX Y DJNZ CONTLK XRA A ;ELEMENT NOT FOUND RET ;FOUND ELEMENT IN LIST FNDIT: PUSH Y POP B XRA A STC RET ;MOVNAM MOVES THE FILENAME FROM TI BUFFER ;STACK INTO THE FILE BUFFER AREA ;MOVNAM IS CALLED WITH A ZERO. ;DE CONTAINING THE FIRST RETURN ADDRESS ;HL CONTAINING THE FILE CONTROL BLOCK ;AND THE FILENAME ON THE STACK ;MOVNAM MUST RETUFER AREA POP B ;NEW STACK POINTER POP H ;FILE CONTROL BLOCK CALL FILNAM EXAF EMPBUF: CALL TIN CPI CR JRNZ EMPBUF EXAF PUSH B ;NEW SP XTHL ;HL <- NEW SP POP B ;GET FILE CONTROL BLOCK MOV M,D ;HIGH BYTE OF FIRST RETURN ADDRESS DCX H ;DECR. NEW SP MOV A,E ;LOW BYTE OF FIRST RETURN ADDRESS MOV D,B ;FILE CONTROL BLOCK INTO DE MOV E,C POP B ;SECOND RETURN ADDRESS SPHL ;REMOVE FILENAME FROM STACK XCHG ;FILE CONTROL BLOCK POP D ;HIGH BYTE OF FIRST RETURN ADDRESS MOV E,A ;; floating point relational operators ; NAME FPRLOP ENTRY FPEQ,FPNEQ,FPLTE,FPLT,FPGTE,FPGT INCLUDE FPINIT.SRC ; frelop: macro flags ;;do a relop and check the correct flags call cmpops ;;compare the operands ani flags ;;check the return flags jr relfin ;;...and finish the relop endmac fpgt: frelop gtbit ;check the greater than bit fpgte: frelop gtbit+eqbit ;check the greater than and equal to bits fplt: frelop ltbit ;check the less than bit fplte: frelop ltbit+eqbit ;check the leseck for like signs jm dfsgns ;no, different signs mov a,5(x) ;check for op1 = 0 ora 4(x) ora c jrnz cmp2 ;no, it's non-zero mvi 7(x),080h ;yes, set exponent to -128 cmp2: mov a,1(x) ;check for op2 = 0 ora 0(x) ora e jrnz cmp3 ;no, it's non-zero mvi 3(x),080h ;yes, set exponent to -128 cmp3: mov a,7(x) ;yes, get exponents and toggle xri 80h ;the high order bit in order to mov b,a ;check the relative magnitudes mov a,3(x) ;now do op2 xri 80h cmp b ;check against op1.e jrz fpdf1 ;both numbers +ive cmc ;both numbers negative, reverse test fpdf1: jrc obig ;if carry then op1 > op2 mvi a,ltbit ;op1 < op2 jr cmpdon obig: mvi a,gtbit ;op1 > op2 cmpdon: pop x ;restore ix pop d ;get return address pop h ;get second return address pop b ;kill op2 pop b pop b ;kill op1 xthl ;restore second return address xchg ;hl <- return address pchl ;return ; ; ; STATUS BITS EQBIT: EQU 1 ;HL = DE LTBIT: EQU 2 ;HL < DE GTBIT: EQU 4 ;HL > DE ; fperr - return a zero and set the carry bit ; NAME FPERR ENTRY FPERR EXT FLTERR INCLUDE FPINIT.SRC ; fperr: xra a ;clear acc spix ;set stack pointer pop d ;de <- return address pop y ;restore iy.... cmp intflg(x) ;test for internal operations jc flterr ;record a floating point error pop x ;...and ix lxi h,nbytes+7 ;remove op2, 2 scratch bytes and op1 dad s sphl ;fix stack pointer lxi h,0 ;save zero (op1) on the stack push h push h xchg ;return addr -> hl ; floating point divide routine ; NAME FPDIVD ENTRY FDIVD,FDIVD1 EXT FPERR,MPSUB,DONE2 INCLUDE FPINIT.SRC INCLUDE FPMAC.SRC ; fdivd: setupf ;setup for 2 operands fdivd1: zchk 2 ;check for division by zero jz fperr mov a,op1+msb(x) ;get sign of op1 xra op2+msb(x) ;x-or with sign of op2 mov scr1(x),a ;save sign of result mov a,op1(x) ;get exponent of op1 inr a ;compensate for algorithm sub op2(x) ;subtract exponent of op2 jv fperr ;floating point error mov op1(x),a ;save s than and equal to bits fpeq: frelop eqbit ;check equal to bit fpneq: frelop ltbit+gtbit ;check less than and greater than bits relfin: mvi a,0 ;clear accumulator rz ;return false if status bit wasn't set stc ;otherwize set the carry bit ret ;and return ; ; compare two floating point operands ; cmpops: push x ;save ix lxi x,6 ;make ix point to bottom of op2 xra a ;clear the carry and... dadx s mov c,6(x) ;get sign of op1 mov e,2(x) ;get sign of op2 mov a,c xra e ;chxponent jrnz fpdiff ;they're different mov a,e ;get high byte of op2's mantissa cmp c ;check against op1's jrnz fpdiff ;they're diferent mov a,1(x) ;get middle byte of op2's mantissa cmp 5(x) ;compare against op1's jrnz fpdiff mov a,0(x) ;get low byte of op2's mantissa cmp 4(x) ;check against op1's jrnz fpdiff mvi a,eqbit ;op1 = op2 jr cmpdon ;done comparing dfsgns: slar e ;get sign bit of op2 into carry jr fpdf1 ;don't check signs fpdiff: bit sign,c ;check sign bit xra a ;clear accumulator stc ;set carry to indicate error pchl ;return ; ;clear acc spix ;set stack pointer pop d ;de <- return address pop y ;restore iy.... cmp intflg(x) ;test for internal operations jc flterr ;record a floating point error pop x ;...and ix lxi h,nbytes+7 ;remove op2, 2 scratch bytes and op1 dad s sphl ;fix stack pointer lxi h,0 ;save zero (op1) on the stack push h push h xchg ;return addr -> hl exponent of result res sign,op1+msb(x) ;clear sign bits in op1... res sign,op2+msb(x) ;...and op2 lxi h,-nbytes ;add extra variable to stack dad s ;for use in intermediate sphl ;calculations push h ;save addr of lsb xra a ;zero temporary variable mvi b,nbytes ;zero correct number of bytes zerlp: mov m,a ;zero this byte inx h ;bump pointer djnz zerlp ;and continue dcx h ;correct pointer push h ;make y point to this pop y ;temporary variable mvi b,fracln*8-1 ;process all bits in mantissa divlp: push d ;save base reg push b ;save counter lxi h,op1 ;get addresses of two operands dad d xchg ;de <- hl = addr( op1 ) lxi b,op2 dad b ;hl = addr( op2 ) mvi b,fracln ;process at most all bytes divd1: dcx h ;bump pointers dcx d ldax d ;get byte from op1 cmp m ;compare with byte from op2 jrc divd2 ;too big don't subtract jrnz divd1a ;continue if zero djnz divd1 ;stop when done inr b ;make the next loop do nothing divd1a: dcx h dcx d py to op1 coplp: ldax d ;get byte from temp mov m,a ;store in op1 inx h ;bump pointers inx d djnz coplp ; fix stack lxi h,nbytes ;size of temp variable dad s ;+ stack pointer sphl ;is original value of sp bit sign,scr1(x) ;fix sign of result jz done2 bset sign,op1+msb(x) jmp done2 ; ivlp ;...and continue lxi h,op1+lsb ;calculate addr of op1 dad d pop d ;get addr of temp variable mvi b,fracln ;and co; floating point multiply routine ; NAME FMULT ENTRY FMULT EXT FPERR,MPADD,DONE2 INCLUDE FPINIT.SRC INCLUDE FPMAC.SRC ; fmult: setupf ;setup for 2 operands fmult1: mov a,op1+msb(x) ;get sign of op1 xra op2+msb(x) ;x-or with sign of op2 mov scr1(x),a ;save sign of result res sign,op1+msb(x) ;clear both sign bits res sign,op2+msb(x) mov a,op1(x) ;get exponent of op1 add op2(x) ;add exponent of op2 jv fperr ;floating point error mov op1(x),a ;save exponent of result lxi h,loop: rotate 1,right ;rotate multiplier right 1 bit jrnc mult1 ;carry out of lsb? pop d ;yes... pop h push h push d push b ;save counter call mpadd ;add multiplicand to result pop b ;restore counter push ix pop d ;restore d mult1: rotate y,right ;shift result right one bit djnz muloop ;...and continue pop d ;get addr of temp variable pop h ;get addr of op2 lxi b,op1-op2 ;calculate addr of op1 dad b mvi b,fracln ;and copy to op1 coplop: ldax d ;get byte from temp;FLOATING POINT ADD AND SUBTRACT ROUTINES ; NAME FADDSB ENTRY FSUB,FADD,FADD1 EXT MPADD,DONE2,FPERR INCLUDE FPINIT.SRC INCLUDE FPMAC.SRC ; ; fsub -- floating point subtraction routine ; must be followed by addition routine ; fsub: setupf ;setup for 2 operands mvi a,80h ;complement sign bit xra op2+msb(x) ;of the second operand mov op2+msb(x),a ;and add since a + (-b) = a - b jr fadd1 ;jump into add routine ; ; floating point addition routine ; fadd: setupf ;setup for 2 djnz divd1a inx h inx d divd1b: call mpsub ;subtract divisor from dividend ora a ;clear carry divd2: pop b ;restore counter pop d ;restore base reg push psw ;save carry rotate y,left ;shift result right one bit pop psw ;get carry jrc divd3 ;don't set a bit bset 0,lsb(y) ;set least significant bit divd3: rotate 1,left ;shift dividend left 1 bit djnz divlp ;...and continue lxi h,op1+lsb ;calculate addr of op1 dad d pop d ;get addr of temp variable mvi b,fracln ;and co-nbytes ;add extra variable to stack dad s ;for use in intermediate sphl ;calculations push x ;save x-reg lxi b,op2+lsb ;make x-reg point to lsb of op2 dadx b xtix push h ;save addr of lsb xra a ;zero temporary variable mvi b,nbytes ;zero correct number of bytes zerlop: mov m,a ;zero this byte inx h ;bump pointer djnz zerlop ;and continue dcx h ;correct pointer push h ;make y point to this pop y ;temporary variable mvi b,fracln*8-1 ;process all bits in mantissa mu mov m,a ;store in op1 inx h ;bump pointers inx d djnz coplop ; fix stack lxi h,nbytes ;size of temp variable dad s ;+ stack pointer sphl ;is original value of sp bit sign,scr1(x) ;fix sign of result jz done2 bset sign,op1+msb(x) jmp done2 ; ;  addr of op2 lxi b,op1-op2 ;calculate addr of op1 dad b mvi b,fracln ;and copy to op1 coplop: ldax d ;get byte from tempoerands fadd1: zchk 1 ;check for a zero operand jrz copdon ;yes..copy and done zchk 2 ;check for a zero facc jz done2 ;yes...addition finished ;check range of exponents mov a,op1(x) ;get exponent of 1st op sub op2(x) ; " " " 2nd " ; ;are they equal? jrz oppos ;yes...prepare to add them mov c,a ;copy difference into c-reg jp posrlt ;otherwise make sure xra a ;that the result is +ve sub c posrlt: cpi fracln-1*8 ;is difference is too small jrc oppos ;yes..go align operands bit sign,c ;test sign of difference jz done2 ;if +ve then addition is done copdon: lxi h,op1 ;copy op1 <- op2 dad d ;point to top of op1 xchg lxi b,op2 ;point to top of op2 dad b lxi b,4 ;copy 4 bytes lddr ;op1 <- op2 jmp done2 ;and done oppos: bit sign,op1+msb(x) ;make sure args >= 0 jrz op1pos res sign,op1+msb(x) ;clear sign bit push psw ;save difference in exponents push b ;save sign of difference cmplmt 1 ;<0 , negate mantissa pop b pop psw op1pos: op2 right djnz shop2 shadd: shift 1,r ;shift both operands right shift 2,r ;one bit lxi h,op1+lsb ;get addr of bottom of op1 dad d xchg push h ;save base reg lxi b,op2+lsb ;get addr of bottom of op2 dad b call mpadd ;add aligned fractions pop d ;restore base reg bit sign,a ;high byte of answer is in a jz done2 cmplmt 1 ;complement fraction bset sign,op1+msb(x) ;set sign bit jmp done2 ;and done ; ; floating point input routine ; NAME FLTIN ENTRY FLTIN EXT INPUT,LOOK,CVTSFP,ERRTYP INCLUDE FPINIT.SRC ; fpp: equ 0 ;for status byte fps: equ 1 ;for status byte fppb: equ 1 ;for status byte, corresponds to bit 0 fpsb: equ 2 ;for status byte, corresponds to bit 1 fltin: push d ;save parm counter push h ;save file pointer lxi d,-2 ;point to string we're going to create xchg dad s ;..and save pointer in de xchg mvi b,0 ;b indicate sign of result fp1: call input ;get 1st;not a digit, error cpi 10+'0' jnc errtyp ;not a digit, error jr fpch1 ;don't do another input fpchrs: call input ;get the character we just looked at... fpch1: push psw ;..and save it on the stack inx s ;only save one character call look ;look at next character cpi '.' ;check for a decimal point jrz fpoint ;yes, do special processing cpi 'e' ;check for a scale factor jrz fpscal ;yes, process it cpi 'E' ;check for a scale factor jrz fpscal ;yes cpi '0' ;if not a digit,inter to input variable mov l,-1(x) mov m,d ;save floating point number dcx h mov m,e dcx h mov m,b dcx h mov m,c ;all saved!!!! pop h ;get pointer to string sphl ;..and use it to restore the stack pop h ;throw away two now useless bytes pop h ;get file pointer pop d ;get parm counter mvi b,0 ;clear b ret fpoint: bit fpp,b ;see if it's too late for a decimal point jrnz fpdn ;yes, we're done with this # mvi b,fppb ;set appropriate bit jr fpchrs ;and process mbit sign,op2+msb(x) jrz align res sign,op2+msb(x) ;clear sign bit push psw ;save difference in exponents push b ;save sign of difference cmplmt 2 pop b pop psw align: ana a ;are exponents equal? jrz shadd ;yes bit sign,c ;check sign of difference mov b,a ;save magnitude of difference jrz shop2 ;op1 > op2, shift op2 right ; ;op1 < op2, shift op1 right shop1: shift 1,r ;shift op1 right djnz shop1 ;until two operands line up jr shadd ;add them shop2: shift 2,r ;shift char from input routine cpi ' ' jrz fp1 ;skip leading spaces cpi '-' ;check for a leading sign jrz ngflt ;yes...negate floating point result cpi '+' cz input ;skip over + sign inr b ;inr, dcr -> 0 ngflt: dcr b ;set b according to sign of number push b ;save sign indicator cnz input ;skip over a minus sign inx s ;only save one byte mvi b,0 ;indicator for # parsing status jr ckdg1 ;don't read another digit ckdg: call input ckdg1: cpi '0' ;check for a digit jc errtyp then we're done jrc fpdn ;yes...done! cpi 10+'0' jrc fpchrs ;not done! fpdn: mvi a,' ' ;end the string with a space push psw xchg ;hl -> string on the stack push h ;save string pointer call cvtsfp ;convert the string to a floating point # mov b,h ;copy lsbytes to bc mov c,l pop h ;get string pointer push h ;and save it inx h ;bump to sign indicator inr m ;see if we should negate jrnz fppos ;no, number is +ive bset sign,e ;set sign bit fppos: mov h,0(x) ;get poore characters fpscal: bit fps,b ;see if it's too late for a scale factor jrnz fpdn ;yes, we're done with this # mvi b,fpsb+fppb call input ;save scale factor on string push psw inx s call look ;look for a leading sign on the exponent cpi '-' jrz scalsn ;yes, do a scale sign cpi '+' jrnz ckdg ;no, go get some digits scalsn: call input ;save scale sign push psw inx s jr ckdg ;make sure that the next one's a digit ; ; SQUARE A FLOATING POINT NUMBER ; NAME FPSQR ENTRY FPSQR,L118 EXT FMULT ; L118: FPSQR: POP H ;GET RETURN ADDRESS POP D ;GET FLOATING POINT NUMBER POP B PUSH B ;RESTORE FLOATING POINT NUMBER PUSH D PUSH B ;MAKE A COPY OF IT PUSH D PUSH H ;RESTORE RETURN ADDRESS JMP FMULT ;AND MULTIPLY ; FLTIN SRC%&'FPSQR $$$;ROUTINE TO CONVERT A FLOATING POINT NUMBER TO FIXED POINT FORMAT ; NAME FXDCVT ENTRY FXDCVT EXT ABS INCLUDE DEFLT.SRC ; ; THIS IS MOD FXDCVT, SO.... $FXDCVT SET 0FFFFH INCLUDE FCTMAC.SRC FXDCVT: ; const exp = 13; ; maxlen = 12; ; type sstring = array[1..14] of char; ; procedure format( var x: sstring ); ; var tpowr: integer; (* power of ten *) ; fracln : 0..255; (* fraction length specified *) ; i, j: 0..255; ; y: array[1..22] of char; ; sign: char; ILOD H,1,-12 LXI D,10 MULT D,0 PUSH H LXI H,9 ILOD H,1,-13 POP D DADD D,0 PUSH H LXI H,48 LXI D,11 MULT D,0 POP D XCHG DSUB D,0 MOV 0(IX),H MOV -1(IX),L ; if x[ exp-1 ] = '-' then tpowr := -tpowr; LXI H,9 ILOD H,1,-11 MOV A,L CMPI D,45 MOV A,H JNZ L281 MOV L,-1(IX) MOV H,0(IX) NEGT H MOV 0(IX),H MOV -1(IX),L L281 ; for i := 1 to 22 do y[ i ] := '0'; MVI -3(IX),1 PUSH IX POP H DCX H DCX H DCX H PUSH H LXI H,22 XTHL L309 MOV -7(IX),L ; if tpowr > 6 then begin MOV L,-1(IX) MOV H,0(IX) LXI D,6 GRET D,0 JNC L377 ; for i := 5 to 10 do y[ i-3 ] := x[ i ]; MVI -3(IX),5 PUSH IX POP H DCX H DCX H DCX H PUSH H LXI H,10 XTHL L394 MOV D,A MOV E,M XTHL PUSH H GE D,0 JNC L395 MOV H,A MOV L,-3(IX) DCX H DCX H DCX H XCHG LXI H,-6 ADDR IX MOV D,A MOV E,-3(IX) PUSH H MOV H,9(IX) MOV L,8(IX) DSUB INX H MOV D,A MOV E,M POP H MOV M,E POP H XTHL INR M X H DCX H DCX H PUSH H MOV L,-1(IX) MOV H,0(IX) INX H XTHL L465 MOV D,A MOV E,M XTHL PUSH H GE D,0 JNC L466 MOV H,A MOV L,-3(IX) XCHG LXI H,-6 ADDR IX MOV D,A MOV E,-3(IX) INX D INX D INX D PUSH H MOV H,9(IX) MOV L,8(IX) DSUB INX H MOV D,A MOV E,M POP H MOV M,E POP H XTHL INR M JNZ L465 L466 POP D L493 POP D ; for i := 3+tpowr to 8 do y[ i ] := x[ i+2]; MOV L,-1(IX) MOV H,0(IX) INX H INX H INX H MOV -3(IX),L XCH; fixed: boolean; ; begin L162 ENTR D,2,29 ; fixed := false; (* assume no success *) MOV -6(IX),A ; sign := x[2]; LXI H,9 ILOD H,1,-1 MOV -5(IX),L ; tpowr := -1; MVI 0(IX),255 MVI -1(IX),255 ; (*$R- *) fracln := ord( x[ tpowr ] ); (*$R+ *) R SET 0 MOV L,-1(IX) MOV H,0(IX) XCHG MOV H,9(IX) MOV L,8(IX) DSUB INX H MOV D,A MOV E,M MOV -2(IX),E R SET 1 ; tpowr := ord(x[exp]) * 10 + ord(x[exp+1]) -11*ord('0'); LXI H,9 MOV D,A MOV E,M XTHL PUSH H GE D,0 JNC L310 MOV H,A MOV L,-3(IX) XCHG LXI H,-6 ADDR IX MVI M,48 POP H XTHL INR M JNZ L309 L310 POP D L329 POP D ; if (tpowr >= 0) and (tpowr+2+fracln <=maxlen) then begin MOV L,-1(IX) MOV H,0(IX) MOV D,A MOV E,A GE D,0 JNC L334 MOV L,-1(IX) MOV H,0(IX) INX H INX H MOV D,A MOV E,-2(IX) DADD D,0 LXI D,12 LE D,0 JNC L331 ; fixed := true; MVI -6(IX),1 ; y[ 1 ] := x[ 3 ]; LXI H,9 ILOD H,1,-2 JNZ L394 L395 POP D L421 POP D ; for i := 7 to tpowr do y[i+1] := '0'; MVI -3(IX),7 PUSH IX POP H DCX H DCX H DCX H PUSH H MOV L,-1(IX) MOV H,0(IX) XTHL L430 MOV D,A MOV E,M XTHL PUSH H GE D,0 JNC L431 MOV H,A MOV L,-3(IX) INX H XCHG LXI H,-6 ADDR IX MVI M,48 POP H XTHL INR M JNZ L430 L431 POP D L451 POP D ; end ; else begin JMP L454 L377 ; for i := 2 to tpowr + 1 do y[ i ] := x[ i+3]; MVI -3(IX),2 PUSH IX POP H DCG PUSH IX POP H DCX H DCX H DCX H PUSH H LXI H,8 XTHL L503 MOV D,A MOV E,M XTHL PUSH H GE D,0 JNC L504 MOV H,A MOV L,-3(IX) XCHG LXI H,-6 ADDR IX MOV D,A MOV E,-3(IX) INX D INX D PUSH H MOV H,9(IX) MOV L,8(IX) DSUB INX H MOV D,A MOV E,M POP H MOV M,E POP H XTHL INR M JNZ L503 L504 POP D L530 POP D ; end; L454 ; end; L331 L333 EQU L331 L334 EQU L333 ; if (tpowr < 0) and (fracln+2+tpowr <= maxlen) then begin MOV L,-1(IX) MOV H,0(IX) MOV D,A MOV E,A LESS D,0 JNC L539 MOV H,A MOV L,-2(IX) INX H INX H MOV E,-1(IX) MOV D,0(IX) DADD D,0 MOV A,L CMPI D,13 MOV A,H JNC L536 ; fixed := true; MVI -6(IX),1 ; y[ 2+abs( tpowr ) ] := x[ 3 ]; MOV L,-1(IX) MOV H,0(IX) CALL ABS INX H INX H XCHG LXI H,-6 ADDR IX XCHG LXI H,9 ILOD H,1,-2 XCHG MOV M,E ; for i := 3 to 8 do y[ i+abs( tpowr ) ] := x[ i+2 ]; MVI -3(IX),3 PUSH IX POP H DCX H DCX H DCX H PUSH36 L539 EQU L538 ; if fixed then begin CMP -6(IX) JNC L640 ; y[ tpowr+2 ] := '.'; MOV L,-1(IX) MOV H,0(IX) INX H INX H XCHG LXI H,-6 ADDR IX MVI M,46 ; for i := 1 to 14 do x[ i ] := ' '; MVI -3(IX),1 PUSH IX POP H DCX H DCX H DCX H PUSH H LXI H,14 XTHL L668 MOV D,A MOV E,M XTHL PUSH H GE D,0 JNC L669 MOV H,A MOV L,-3(IX) XCHG MOV H,9(IX) MOV L,8(IX) DSUB INX H MVI M,32 POP H XTHL INR M JNZ L668 L669 POP D L688 POP ,A MOV E,-3(IX) PUSH H LXI H,-6 ADDR IX MOV D,A MOV E,M POP H MOV M,E POP H XTHL INR M JNZ L705 L706 POP D L738 POP D ; (* round if necessary *) ; if (tpowr <= 6) and ( y[ j+1 ] >= '5' ) then begin MOV L,-1(IX) MOV H,0(IX) LXI D,6 LE D,0 JNC L743 MOV H,A MOV L,-4(IX) INX H XCHG LXI H,-6 ADDR IX MOV D,A MOV E,M MVI A,52 CMP E MOV A,D JNC L740 ; x[ maxlen+2 ] := succ(x[ maxlen+2 ] ); LXI H,9 ILOD H,1,-13 INX H XCHG MOV H,9(IX) MOV -3(IX),L ; ; if x[maxlen+2-i ] = '.' then i := i+1; MOV H,A MOV L,-3(IX) LXI D,14 XCHG DSUB D,0 XCHG MOV H,9(IX) MOV L,8(IX) DSUB INX H MOV D,A MOV E,M MOV A,E CMPI D,46 MOV A,D JNZ L845 MOV H,A MOV L,-3(IX) INX H MOV -3(IX),L L845 ; if x[maxlen+2-i] = ' ' then x[maxlen+2-i]:='1' MOV H,A MOV L,-3(IX) LXI D,14 XCHG DSUB D,0 XCHG MOV H,9(IX) MOV L,8(IX) DSUB INX H MOV D,A MOV E,M MOV A,E CMPI D,32 MOV A,D JNZ L868 MO,A MOV L,-3(IX) MOV D,A MOV E,-4(IX) DSB1 D,0 JNZ L929 MOV H,A MOV L,-4(IX) ; end; INX H MOV -4(IX),L L929 L740 L742 EQU L740 L743 EQU L742 ; x[ maxlen-j+2 ] := sign; MOV H,A MOV L,-4(IX) LXI D,12 XCHG DSUB D,0 INX H INX H XCHG MOV H,9(IX) MOV L,8(IX) DSUB INX H MOV D,A MOV E,-5(IX) MOV M,E ; end; L640 ; end; EXIT D,2  H LXI H,8 XTHL L596 MOV D,A MOV E,M XTHL PUSH H GE D,0 JNC L597 MOV H,A MOV L,-3(IX) PUSH H MOV L,-1(IX) MOV H,0(IX) CALL ABS POP D DADD D,0 XCHG LXI H,-6 ADDR IX MOV D,A MOV E,-3(IX) INX D INX D PUSH H MOV H,9(IX) MOV L,8(IX) DSUB INX H MOV D,A MOV E,M POP H MOV M,E POP H XTHL INR M JNZ L596 L597 POP D L630 POP D ; tpowr := 0; (* fudge to allow mutual code later on *) MOV 0(IX),A MOV -1(IX),A ; end; L536 L538 EQU L5D ; j := tpowr+2+fracln; MOV L,-1(IX) MOV H,0(IX) INX H INX H MOV D,A MOV E,-2(IX) DADD D,0 MOV -4(IX),L ; for i := 1 to j do x[ i+(maxlen-j+2) ] := y[ i ]; MVI -3(IX),1 PUSH IX POP H DCX H DCX H DCX H PUSH H MOV H,A MOV L,-4(IX) XTHL L705 MOV D,A MOV E,M XTHL PUSH H GE D,0 JNC L706 MOV H,A MOV L,-3(IX) MOV D,A MOV E,-4(IX) PUSH H LXI H,12 DSUB D,0 INX H INX H POP D DADD D,0 XCHG MOV H,9(IX) MOV L,8(IX) DSUB INX H MOV D MOV L,8(IX) LXI B,-13 DADD B MOV M,E ; i := 0; MOV -3(IX),A ; while x[ maxlen+2-i ] = succ( '9' ) do begin L800 MOV H,A MOV L,-3(IX) LXI D,14 XCHG DSUB D,0 XCHG MOV H,9(IX) MOV L,8(IX) DSUB INX H MOV D,A MOV E,M PUSH D LXI H,57 INX H POP D DSB1 D,0 JNZ L799 ; x[ maxlen+2-i ] := '0'; MOV H,A MOV L,-3(IX) LXI D,14 XCHG DSUB D,0 XCHG MOV H,9(IX) MOV L,8(IX) DSUB INX H MVI M,48 ; i :=i+1; MOV H,A MOV L,-3(IX) INX H V H,A MOV L,-3(IX) LXI D,14 XCHG DSUB D,0 XCHG MOV H,9(IX) MOV L,8(IX) DSUB INX H ; else x[maxlen+2-i]:=succ(x[maxlen+2-i]); MVI M,49 JMP L897 L868 MOV H,A MOV L,-3(IX) LXI D,14 XCHG DSUB D,0 XCHG MOV H,9(IX) MOV L,8(IX) DSUB INX H PUSH H MOV H,A MOV L,-3(IX) LXI D,14 XCHG DSUB D,0 XCHG MOV H,9(IX) MOV L,8(IX) DSUB INX H MOV D,A MOV E,M INX D POP H MOV M,E L897 ; end; JMP L800 L799 ; if i = j then j := j+1 MOV H EXT ROTATLEFT,ROTATRIGHT,ROTLEFT,ROTRIGHT,FPERR,COMPOP,COMP1 EXT ZERCHK,ZERCK1,FXDCVT ; IF NOT $FNORM EXT FNORM ENDIF ; IF NOT $CVTFLT EXT CVTFLT ENDIF ; IF NOT $FOUT EXT FOUT ENDIF ; ; these macros use arg = 1 to refer to the first operand and... ; arg = 2 to refer to the second operand ; arg = y to refer to the present operand ; rotate: macro arg,direction ;;rotate operand one bit if 'arg'-'y' ;;standard arg lxi h,op!arg+msb ;;offset of the argument call rotat jv fperr ;floating point error dcx h mov a,m ;;get msbyte ral ;;shift sign bit into carry call rotright ;;rotate w/o clearing carry else ;;shift left call rotatl ;;do a rotate left mvi a,0 ;;clear w/o disturbing carry rar ;;move carry to msbit xra m ;;xor with msb of fp number mov m,a ;;save result endif endmac cmplmt: macro arg ;;2's complement operand if 'arg'-'y' ;;standard arg lxi h,op!arg+lsb ;;get offset of lsb of operand call compop ;;complement operany' ;;use indicated argument lxi b,op!arg ;;get offset of operand push x ;;get base into y xtiy dady b ;;get addr of operand into y call fnorm ;;normalize pop y ;;and restore y else ;;current operand call fnorm ;;just normalize endmac setupf: macro ;;macro used to set up stack for fp ; ;;processing pop b ;;get return address pop d ;;get first half of op2 pop h ;;get second half of op2 push psw ;;add two bytes to op1 push h ;;restore op2 push d push psw ;;;;save high 16 bits of op1 push b ;;save low 16 bits of op1 endmac ; ; convert an integer to floating point, or fp to ASCII ; cvtf: macro where,value ;;where is the argument and what is it? ;; ;; A -> process immediate argument and push ;; ;; B -> process top of stack ;; ;; C -> process 2nd on stack ;; ;; D -> process # in de ;; ;; H -> process # in hl ;; ;; S -> convert top of stack to a string if 'A'-'where' ;;check for NOT A if 'B'-'where' ;;check for NOT B if 'C'-' fxdcvt ;;try to convert to fixed point else ;;otherwise simply print the string call fout ;;process fp -> ascii string endif else ;;process option H call cvtflt ;;process # in hl endif else ;;process option D xchg ;;put # in hl call cvtflt ;;process # in hl endif else ;;process option C pop b ;;get top of stack in bc, de pop d pop h ;;get integer in hl push d ;;save float # on stack push b call cvtflt ;;convert hl -> float xcfp ;;...and exchange op1 &!direction ;;call rotate routine else ;;use present operand push y ;;move y to hl pop h dcx h ;;point to msb ora a ;;clear carry call rot!direction ;;enter rotate after addr calcs endif endmac ;;done shift: macro arg,direction ;;shift right if 'arg'-'l' ;;do right shift if 'arg'-'y' ;;standard argument lxi h,op!arg+exp ;;offset of the argument dad d ;;hl <- addr of " else ;;use current operand push y pop h ;;get addr of msb hl endif inr m ;;bump exponent d else ;;use present operand push y ;;move y to hl pop h lxi b,lsb ;;point to lsb dad b call comp1 ;;enter compop after addr calcs endif endmac zchk: macro arg ;;check for operand = 0 if 'arg'-'y' ;;if standard argument lxi h,op!arg+msb ;;get offset call zerchk ;;and check for a zero else ;;use current operand push y pop h ;;hl <- y dcx h ;;make (hl) = msb call zerck1 ;;and check for zero endif endmac normfp: macro arg ;;normalizing routine if 'arg'-'add two bytes to op2 push x ;;save ix... push y ;;...and iy push b ;;restore return address lxi h,0 ;;make ix point to end of dad s ;;the stack push h pop ix xchg ;;make de point to stack xra a ;;clear carry mov intflg(x),a ;;clear internal op flag endmac ; ; xcfp: macro ;;exchange top two floating point numbers pop d ;;get op2 in de, hl pop h pop b ;;get low 16 bits of op1 xthl ;;exchange high 16 bits of op1 & op2 push d ;;save low 16 bits of op2 push h where' ;;check for not C if 'D'-'where' ;;check for not D if 'H'-'where' ;;check for not H ;; ;;process option S if value-4 ;;should we attempt to convert to fixed pt mov a,l ;;yes, first save fraction length pop b pop d ;;get fp number pop h ;;get field info mov h,a ;;save fraction length push h ;;restore stack push d push b xra a ;;clear acc call fout ;;convert to form ' sx.xxxxxxesxx' lxi h,13 ;;point to top of string dad s push h ;;save the parameter call op2 endif else ;;process option B pop h ;;get 2's complement value call cvtflt ;;call routine to convert # in hl endif else ;;process option A lxi h,value ;;get 16 bit value call cvtflt ;;convert to float, and done!! endif endmac ; dsb1 macro reg xra a dsbc reg d endmac cmpi macro q,value cpi value endmac t integer in hl push d ;;save float # on stack push b call cvtflt ;;convert hl -> float xcfp ;;...and exchange op1 &$CVTFLT SET 0 $FNORM SET 0 $FOUT SET 0 ; ; All calculations are done with a 31 bit mantissa and ; are then truncated to 24 bits ; nbytes: equ 5 ;number of bytes in floating pt number explen: equ 1 ;number of bytes in exponent fracln: equ nbytes-explen ;number of bytes in mantissa sign: equ 7 ;position of mantissa sign bit ; these positions are relative to ix op1: equ 17 ;position of exponent of first operand op2 equ 11 ;position of exponent of second operand scr1: equ op2-nbytes ;scratch ; floating point output routine ; NAME FOUT ENTRY FOUT EXT FPTTEN,FPDTEN,MPADD,MPSUB INCLUDE FPINIT.SRC ; ;THIS IS MOD FPOUT,SO.. $FOUT SET 0FFFFH ; INCLUDE FPMAC.SRC ; fout: pop b ;get return address pop d ;move floating point number down 2 bytes pop h push psw ;add two bytes above op1 push h ;restore op1 push d push psw ;add two bytes after op1 push h push d ;create op1 push psw ;add two bytes push x push y push b ;save ix, iy, and return address lxi h,a ;zero this byte inx h ;bump pointer djnz zerstr ;and continue mov m,a ;zero exponent in case # is zero push h ;save bcd pointer zchk 1 ;check for fp number = 0 pop h ;restore bcd pointer jz bcdout ;yes, output it mvi m,6 ;initialize decimal exponent declop: push h ;save pointer on stack bit sign,op1(x) ;first check sign of exponent jrnz less1 ;negative, keep multiplying mvi a,23 ;process until 24 > exp > 20 cmp op1(x) ;now check size of exponent jrc gret1 ;if exp > ;no, shift it inr c jr frc1 ;...and try again frc2: lxi h,op1+msb ;get addr of op1 dad d push d ;save base register lxi d,ftable+3 ;point to 1,000,000 mvi b,nbytes-1 ;check all bytes after the exponent frc2a: ldax d ;get byte from constant cmp m ;is byte from number bigger jrc frc2c ;yes, done jrnz frc2b ;multiply by ten dcx h dcx d djnz frc2a jr frc2c ;done frc2b: pop d ;restore base reg call fptten ;op1 := op1 * 10 rotate 1,left ;and compensate for exp = 24 po ;save addr of both operands push h inr c ;count iterations call mpsub ;subtract until result is -ive pop h ;get addrs of both operands pop d jrnc conv1 ;result is still positive push d ;save addr of op1 call mpadd ;make result positive pop y ;save addr of op1 in y pop d ;bcd pointer xthl ;get addr of bcd constant ; ;and save addr of new ; ;floating point constant push b ;save b conv2: dcr c ;see if we're done subtracting jrz conv4 ;yes.. ora a ;clear carrybyte 1 intflg: equ op2+1 ;is operation internal? dc1: equ op1+1 ;for digit counting in cvtsfp dc2: equ op1+2 ; these positions are relative to op1, op2 exp: equ 0 ;position of exponent byte msb: equ exp-explen ;high byte of fraction lsb: equ exp-fracln ;low " " "  17 ;position of exponent of first operand op2 equ 11 ;position of exponent of second operand scr1: equ op2-nbytes ;scratch 0 ;make ix point to end of dad s ;the stack push h pop ix xchg ;make de point to stack xra a ;clear carry mvi c,' ' ;output space unless negative bit sign,op1+msb(x) ;check sign jrz notneg mvi c,'-' ;output a '-' res sign,op1+msb(x) ;clear sign bit notneg: mov intflg(x),c ;set internal op flag lxi h,-5 ;add extra workspace to stack dad s ;for use in ascii string sphl ;construction xra a ;zero temporary variable mvi b,4 ;zero correct number of bytes zerstr: mov m, 23 divide frac by 10 less1: call fptten ;op1 := op1 * 10 pop h ;decrement decimal exponent dcr m ;and save the pointer jr declop ;try again gret1: call fpdten ;op1 := op1 / 10 pop h ;get addr of decimal exponent inr m ;increment decimal exponent push h ;save bcd pointer mov a,op1(x) ;until exponent <= 23 cpi 24 jrnc gret1 ;try again frcout: mov c,a ;save value of exponent frc1: mov a,c ;get exponent cpi 23 ;make sure exponent = 23 jrz frc2 ;yes it is rotate 1,right p h ;get bcd pointer dcr m ;indicate multiplication jr frc3a frc2c: pop d ;restore base register frc3: pop h ;get bcd pointer frc3a: lxi b,-4 ;addr of lsb of bcd mantissa dad b ;in hl push d ;save base register lxi b,bcd ;save addr of first bcd value push b push h ;save bcd pointer lxi h,op1+lsb ;get addr of op1 dad d xchg ;de <- addr of op1 lxi h,ftable ;addr of floating point values mvi b,7 ;7 bcd digits conlop: mvi c,0 ;count number of subtractions conv1: push d mvi b,4 ;four byte bcd number push d ;save operands push h conv3: ldax d ;get present bcd value adc m ;add in value from constant daa ;decimal adjust stax d ;and save inx h ;bump pointers inx d djnz conv3 ;check counter pop h ;get original pointers pop d jr conv2 ;and try again conv4: lxi b,4 ;point to next bcd constant dad b pop b ;restore b xthl ;get addr of fp constant ; ;and save addr of bcd constant push d ;save addr of bcd number push y ;get addr of op1 pop d djnz conlop ;and continue pop d ;addr of bcd number lxi h,4 dad d ;get addr of exponent pop b ;throw away pointer to ftable pop b ;get stack pointer bcdout: push x ;get addr of op1 in y pop y lxi b,op1-2 ;interested in bytes after decimal point xra a ;clear carry... dady b ;...and add mov e,intflg(x) ;get leading space or - mvi 4(y),' ' ;leading space mov 3(y),e ;save in string space mov e,m ;save exponent in e dcx h ;point to msb of fraction mv mov a,b neg ;otherwise make it positive mov b,a posexp: mov -1(y),c ;save sign of exponent xra a ;convert to bcd cmp b ;check for zero exponent jrz conxp1 xra a ;clear carry conexp: inr a daa djnz conexp conxp1: mov m,a ;save so rld will work mvi a,30h ;put 3 in high nybble rld ;get 1st digit mov -2(y),a ;tens digit of exponent ; mvi a,30h ;put 3 in high nybble rld ;get 2nd digit mov -3(y),a ;one digit of exponent lxi h,5 ;throw away bcd number dad s sp01h,00,00 ; one hundred db 10h,00,00,00 ; ten db 01h,00,00,00 ; one ; ; the floating point constant 10, in the five byte internal ; form ; db 0,0,0,50h ; 5/8 tentop: db 4 ; * 16 = 10  1,000 db 0,64h,0,0 ; 100 db 0,0ah,0,0 ; 10 db 0,01,0,0 ; 1 bcd: ; db 00,00,00,10h ; ten million db 00,00,00,01h ; one million db 00,00,10h,00 ; hundred thousand db 00,00,01h,00 ; ten thousand db 00,10h,00,00 ; one thousand db 00,;ROUTINES TO DIVIDE AND MULTIPLY A FLOATING POINT NUMBER BY TEN ; NAME FPTEN ENTRY FPTTEN,FPDTEN EXT FDIVD1,FADD1,FPERR INCLUDE FPINIT.SRC ; ; divide a floating point number by ten ; fpdten: lxi h,op2 ;get pointer to op2 dad d push d ;save base reg xchg ;de <- pointer to op2 lxi h,tentop ;hl <- pointer to 10 lxi b,nbytes lddr ;op2 <- 10 pop d ;restore base reg jmp fdivd1 ; ; multiply a floating point number by ten ; fptten: lxi h,op2 ;get pointer to op2 dad d p EXT ILODV,ILODV1,ILODV2,ILOD1,ILOD11,ILOD12,ILOD2,ILOD21,ILOD22 EXT FSUB,XADDR,YADDR,FADD,ENTRSC,ENTER,EXITF,FPEQ,SEQUL,IEQUL EXT FPNEQ,SNE,INE,FPLTE,SLE,ILE,FPLT,SLT,ILT,FPGTE,SGE,IGE EXT FPGT,SGT,IGT,FDIVD,FMULT,IMULT,QMULT,IMOD,PSTAT,FOUT EXT CVTFLT,FLTERR,DIVERR,MLTERR IF NOT $FXDCVT EXT FXDCVT ENDIF ; ; MLOAD: MACRO WHERE,VALUE ;;DO A MINIMUM LENGTH LOAD FOR ILOD1, ILOD2.... IF VALUE ;;CHECK FOR A NON-ZERO VALUE IF VALUE&0FF00H ;;CHECK FOR A VALUE > 255 LXI B,VALUE ;;LOAD THi a,30h ;ascii '0' add m ;form ascii of high digit mov 2(y),a ;save in output string mvi 1(y),'.' ;now the decimal point mvi b,6 ;process 6 digits outlp: bit 0,b ;decrement hl on even counter jrnz outlp1 dcx h ;bump pointer outlp1: rld ;get next digit mov 0(y),a ;save byte in string dcx y ;bump pointer djnz outlp ;for 3 bytes mov b,e ;get exponent in b mvi 0(y),'E' ;for exponent mvi c,'+' ;assume exponent is +ve bit 7,b jrz posexp ;yes, exp is positive mvi c,'-'hl pop h pop y pop x ;restore all regs xra a ;clear accumulator pchl ;done!! ; ; ftable: ; db 0,80h,96h,98h ; 10,000,000 db 0,40h,42h,0fh ; 1,000,000 db 0,0a0h,86h,1h ; 100,000 db 0,10h,27h,0 ; 10,000 db 0,0e8h,03,0 ; 1,000 db 0,64h,0,0 ; 100 db 0,0ah,0,0 ; 10 db 0,01,0,0 ; 1 bcd: ; db 00,00,00,10h ; ten million db 00,00,00,01h ; one million db 00,00,10h,00 ; hundred thousand db 00,00,01h,00 ; ten thousand db 00,10h,00,00 ; one thousand db 00,ush d ;save base reg xchg ;get pointer to op1 lxi b,op1 dad b lxi b,nbytes ;copy op1 -> op2 lddr pop d ;restore base reg inr exp+op1(x) ;x2 jv fperr ;overflow error inr exp+op1(x) ;x4 jv fperr call fadd1 ;x5 inr exp+op1(x) ;x10 rnv ;return if no error ; ; the floating point constant 10, in the five byte internal ; form ; db 0,0,0,50h ; 5/8 tentop: db 4 ; * 16 = 10 E VALUE CALL WHERE!2 ;;GO TO THE ROUTINE ELSE MVI C,VALUE ;;LOAD ONLY THE LOW BYTE CALL WHERE!1 ;;GO TO THE ROUTINE ENDIF ELSE CALL WHERE ;;GO TO THE ROUTINE AND LOAD A ZERO ENDIF ENDMAC ; ; ILOD: MACRO Q,SIZE,OFST ;;INDIRECT LOAD (FOR CALL BY REF VARS IF SIZE&8000H ;;NEGATIVE SIZE MLOAD ILODV,OFST ;;LOAD AND GO ELSE ;;VARIABLE SIZE IS KNOWN IF SIZE-1 ;;IF VARIABLE SIZE IS NOT 1 MLOAD ILOD2,OFST ;;LOAD AND GO ELSE ;;DO VARS WITH A SIZE OF 1 MLOAD ILOD1,OFST ;;LOAD AND GO ENDIF ENDIF ENDMAC ;;END OF ILOD ; ; ; ADDR: MACRO Q ;;CALCULATE ADDRESS USING SPECIFIED REG TEMP SET 'Q'-'IY' IF 'Q'-'Y'*TEMP ;;DEFAULT IS X-REG CALL XADDR ;;CALL ROUTINE TO DO IT ELSE CALL YADDR ;;OTHERWISE USE Y-REG ENDIF ENDMAC ; ; DSUB: MACRO Q,SIZE IF 0!SIZE&8000H ;;CHECK FOR FLOATING POINT SUBTRACTION CALL FSUB IF F ;;CHECK FOR ERROR IF REQUIRED JC FLTERR ENDIF ELSE ;;SUBTRACT Q OR DE FROM HL XRA A ;;CLEAR CARRY DSBC Q D ;;SUBTRACT IT ENNE WILL FINISH ENDIF ELSE ;;LEVEL 1 LXI H,1-VSIZ ;;SET UP STACK POINTER DAD S SPHL ;; LABEL TO JUMP TO FOR A CHAINED PROGRAM CHAIN$: EXX LXI H,LAST ;;INDICATE TOP OF HEAP EXX LXI H,0 ;;CHECK FOR A STACK OVERFLOW DAD S LXI D,LAST+MARGIN ;;DO STACK CHECKING FOR LEVEL 1 DSUB D ;;SUBTRACT DE FROM HL JC STKERR ;;OVERFLOW!! ENDIF ENDMAC ;;ALL ENTERED ; ; EXIT: MACRO Q,SSIZ ;;EXIT FROM A PROC/FCT LXI H,SSIZ+8 ;;GET NUMBER OF STACK BYTES JMP EXITF ;;FINISH UP IN A SU CALL ILE ;;INTEGER TEST ENDIF ENDMAC ; ; LESS: MACRO Q,SIZE ;;LESS THAN TEST IF SIZE ;;TEST FOR STRUCTURED RELOP IF SIZE&8000H ;;CHECK FOR FP OPERATION CALL FPLT ;;YES, DO FP OP ELSE LXI B,SIZE ;;SAVE VAR SIZE CALL SLT ENDIF ELSE CALL ILT ;;INTEGER TEST ENDIF ENDMAC ; ; GE: MACRO Q,SIZE ;;GREATER THAN OR EQUAL TO TEST IF SIZE ;;TEST FOR STRUCTURED RELOP IF SIZE&8000H ;;CHECK FOR FP OPERATION CALL FPGTE ;;YES, DO FP OP ELSE LXI B,SIZE ;;SAVE VAR SIZE CLSE IF M ;;CHECK FOR OVERFLOW CALL IMULT ELSE ;;USE FAST ROUTINE CALL QMULT ENDIF ENDIF ENDMAC ; ; NEGT: MACRO REG ;;NEGATE SPECIFIED REGISTER PAIR IF 'REG'-'H' ;;DO DE PAIR OR FLOAT IF 'REG'-'D' ;;DO FLOAT NUMBER POP H ;;GET LOW WORD POP D ;;GET HIGH WORD MVI A,80H ;;SET HIGH BIT XRA E ;;TOGGLE HIGH BIT OF E MOV E,A ;;REPLACE HIGH WORD OF MANTISSA PUSH D ;;RESTORE HIGH WORD PUSH H ;;RESTORE LOW WORD ELSE ;;DO DE PAIR MOV A,E CMA ;;COMPLEMENT LOW BYTEhere is the argument and what is it? ;; ;; A -> process immediate argument and push ;; ;; B -> process top of stack ;; ;; C -> process 2nd on stack ;; ;; D -> process # in de ;; ;; H -> process # in hl ;; ;; S -> convert top of stack to a string if 'A'-'where' ;;check for NOT A if 'B'-'where' ;;check for NOT B if 'C'-'where' ;;check for not C if 'D'-'where' ;;check for not D if 'H'-'where' ;;check for not H ;; ;;process option S if value-4 ;;should we attempt to convDIF ENDMAC ;;DONE ; ; DADD MACRO Q,SIZE IF 0!SIZE&8000H ;;CHECK FOR FLOATING POINT ADD CALL FADD IF F ;;CHECK FOR ERROR IF REQUIRED JC FLTERR ENDIF ELSE DAD Q D ;;ADD Q OR DE TO HL ENDIF ENDMAC ; ; ; ; ENTR: MACRO Q,LVL,VSIZ ;;ENTER A PROC/FCT ON LVL WITH VSIZ VARS IF LVL-1 ;;CHECK FOR INNER LEVELS MVI B,LVL ;;SAVE LEVEL NUMBER LXI D,1-VSIZ ;;SAVE VSIZ BYTES OF STACK IF S ;;DO STACK CHECKING CALL ENTRSC ;;ENTER WITH STACK CHEKING ELSE CALL ENTER ;;A SUBROUTBROUTINE ENDMAC ; ; ; EQUL: MACRO Q,SIZE ;;EQUALITY TEST IF SIZE ;;TEST FOR STRUCTURED RELOP IF SIZE&8000H ;;CHECK FOR FP OPERATION CALL FPEQ ;;YES, DO FP OP ELSE LXI B,SIZE ;;SAVE VAR SIZE CALL SEQUL ENDIF ELSE CALL IEQUL ;;INTEGER TEST ENDIF ENDMAC ; ; ; LE: MACRO Q,SIZE ;;LESS THAN OR EQUAL TEST IF SIZE ;;TEST FOR STRUCTURED RELOP IF SIZE&8000H ;;CHECK FOR FP OPERATION CALL FPLTE ;;YES, DO FP OP ELSE LXI B,SIZE ;;SAVE VAR SIZE CALL SLE ENDIF ELSE ALL SGE ENDIF ELSE CALL IGE ;;INTEGER TEST ENDIF ENDMAC ; ; GRET: MACRO Q,SIZE ;;GREATER THAN TEST IF SIZE ;;TEST FOR STRUCTURED RELOP IF SIZE&8000H ;;CHECK FOR FP OPERATION CALL FPGT ;;YES, DO FP OP ELSE LXI B,SIZE ;;SAVE VAR SIZE CALL SGT ENDIF ELSE CALL IGT ;;INTEGER TEST ENDIF ENDMAC ; ; MULT: MACRO Q,SIZE ;;CALL MULTIPLY ROUTINE IF 0!SIZE&8000H ;;CHECK FOR FLOATING POINT OPERATION CALL FMULT IF F ;;CHECK FOR ERROR IF REQUIRED JC MLTERR ENDIF E MOV E,A MOV A,REG CMA ;;COMPLEMENT HIGH BYTE MOV REG,A INX REG ;;AND INCREMENT ENDIF ELSE MOV A,L CMA ;;COMPLEMENT LOW BYTE MOV L,A MOV A,REG CMA ;;COMPLEMENT HIGH BYTE MOV REG,A INX REG ;;AND INCREMENT ENDIF XRA A ;;CLEAR ACCUMULATOR ENDMAC ; ; FDVD: MACRO Q,SIZE ;;FLOATING POINT DIVISION CALL FDIVD IF F ;;CHECK FOR ERROR IF REQUIRED JC DIVERR ENDIF ENDMAC ; ; ; convert an integer to floating point, or fp to ASCII ; cvtf: macro where,value ;;wert to fixed pt mov a,l ;;yes, first save fraction length pop b pop d ;;get fp number pop h ;;get field info mov h,a ;;save fraction length push h ;;restore stack push d push b xra a ;;clear acc call fout ;;convert to form ' sx.xxxxxxesxx' lxi h,13 ;;point to top of string dad s push h ;;save the parameter call fxdcvt ;;try to convert to fixed point else ;;otherwise simply print the string call fout ;;process fp -> ascii string endif else ;;process option H call cvtflt ;;process # in hl endif else ;;process option D xchg ;;put # in hl call cvtflt ;;process # in hl endif else ;;process option C pop b ;;get top of stack in bc, de pop d pop h ;;get integer in hl push d ;;save float # on stack push b call cvtflt ;;convert hl -> float xcfp ;;...and exchange op1 & op2 endif else ;;process option B pop h ;;get 2's complement value call cvtflt ;;call routine to convert # in hl endif else ;;process option A dmac cmpi macro q,value cpi value endmac  ROUTINE CALL IMOD IF M ;;CHECK FOR OVERFLOW JC DIVERR ENDIF ENDMAC ; NEQL: MACRO Q,SIZE ;;NON-EQUALITY TEST IF SIZE ;;TEST FOR STRUCTURED RELOP IF SIZE&8000H ;;CHECK FOR FP OPERATION CALL FPNEQ ;;YES, DO FP OP ELSE LXI B,SIZE ;;SAVE VAR SIZE CALL SNE ENDIF ELSE CALL INE ;;INTEGER TEST ENDIF ENDMAC ; dsb1 macro reg xra a dsbc reg d en;ROUTINE TO RESET AN INPUT FILE ; NAME RESET ENTRY RESET,L122 EXT CLSOT,OPNIN,BYTIN,SCAN,MOVNAM include deflt.src ; ;SYSTEM FILE BUFFER STRUCTURE ;FIRST BYTE IS FILES FLAG.BITS 0-EOLN,1-EOF,2-WRITTEN,3-PREVIOUS ;OPERATION A WRITE,4-RANDOMLY ACCESSED FILE. ;SECOND IS THE READ AHEAD BYTE FOR INPUT FILES ;RESET REOPENS AN INPUT FILE, SO A USER CAN ;READ IT FROM THE BEGINNING ;GET BUFFER ADDRESS FROM STACK L122: RESET: PUSH B ;SAVE LENGTH PUSH Y CALL SCAN JRNC SKIP PUSH H DCX H MOV M,C ;STORE READ BYTE DCX H XRA A XCHG PCHL ;SET END OF FILE FLAG YEOF: DCX H DCX H DCX H BSET 1,M ;SET EOF FLAG JMPR YCONT ;SET EOLN INDICATER YEOLN: XRA A DCX H DCX H DCX H RES 1,M ;SET EOF FLAG YCONT: BSET 0,M ;SET EOLN FLAG INX H MOV M,C ;STORE READ BYTE INX H XCHG XRA A ;CLEAR ACCUMULATOR PCHL  ;READ FIRST BYTE AND SET EOF AND EOLN FLAGS CALL BYTIN MOV C,A JRC YEOF CPI CR JRZ YEOLN CPI LF JRZ YEOLN DCX H; rotate the floating point mantissa one bit ; NAME ROTATE ENTRY ROTATRIGHT,ROTATLEFT,ROTRIGHT,ROTLEFT INCLUDE FPINIT.SRC ; rotatright: ;rotate a number right one bit dad d ;calculate addr of number ora a ;clear carry rotright: ;rotate w/o clearing carry push b ;save bc regs mvi b,fracln ;process whole mantissa rotr: mov a,m ;get next byte rar ;...rotate... mov m,a ;and replace it dcx h ;bump pointer djnz rotr ;check count pop b ;restore bc ret ;done! rotatl lxi h,value ;;get 16 bit value call cvtflt ;;convert to float, and done!! endif endmac ; ; MMOD: MACRO ;;CALL MOD ROUTINE CALL IMOD IF M ;;CHECK FOR OVERFLOW JC DIVERR ENDIF ENDMAC ; NEQL: MACRO Q,SIZE ;;NON-EQUALITY TEST IF SIZE ;;TEST FOR STRUCTURED RELOP IF SIZE&8000H ;;CHECK FOR FP OPERATION CALL FPNEQ ;;YES, DO FP OP ELSE LXI B,SIZE ;;SAVE VAR SIZE CALL SNE ENDIF ELSE CALL INE ;;INTEGER TEST ENDIF ENDMAC ; dsb1 macro reg xra a dsbc reg d en INX H ;ADJUST POINTER TO K2 BUFFER INX H INX H CALL CLSOT XRA A ;REMOVE IT FROM OUTPUT LIST STAX B DCX B STAX B POP H SKIP: MVI M,0 ;RESET ALL FLAGS POP Y POP B ;GET LENGTH POP D ;RETURN ADDRESS INX H INX H INX H CALL MOVNAM JRC YEOF ;SET END OF FILE, BAD FILENAME CALL OPNIN ;REOPEN FILE JRC YEOF ;SET END OF FILE, NO SUCH FILE EXISTS ;READ FIRST BYTE AND SET EOF AND EOLN FLAGS CALL BYTIN MOV C,A JRC YEOF CPI CR JRZ YEOLN CPI LF JRZ YEOLN DCX H L,0 RET ;CARRIAGE RETURN ENCOUNTERED CHECK FOR END OF INPUT ITEM LSTCR: CPI 'C'&3FH ;CHECK FOR CTRL-C JZ ERROR DCR L ;CHECK FOR FIRST BYTE OF ITEM CZ TXTIN ;GET MORE IF THIS IS THE FIRST CALL CALL TIN ;GET FIRST CHARACTER AND RETURN TO CALLER CPI 'C'&3FH ;CHECK FOR CTRL-C JZ ERROR CPI LF RNZ MVI A,CR RET ;DON'T RETURN A LINE FEED, USE A CR INSTEAD ;NON-ZERO ADDRESS IN HL MEANS DISK FILE INPUT NCONS: PUSH B PUSH D XRA A BIT 1,M ;CHECK FOR READ BEYOND END OF FILE JNZ RBEOeft: ;rotate a number left one bit dad d ;calculate addr of fpacc ora a ;clear carry rotleft: ;rotate w/o clearing carry rar ;save carry push b ;save bc lxi b,lsb-msb-1 ;least significant byte-1 dad b ral ;restore carry mvi b,fracln ;do whole mantissa rotl: inx h ;bump pointer mov a,m ;get next byte ral ;...rotate... mov m,a ;and replace it djnz rotl ;check counter pop b ;restore bc ret ; ; truncate and round functions (used to convert float -> integer) ; NAME ROUND ENTRY ROUND,TRUNC,L129,L130 EXT FADD,RNGERR INCLUDE FPINIT.SRC ; L130: round: pop h ;get return address pop d ;get low word xthl ;get high word push h ;save high word push d ;save low word mov d,a ;set op2 = .5 mov e,a mov h,a mvi a,80h ;make sign of op2 = sign of op1 ana l ori 40h ;set bit to the right of the binary pt mov l,a ;save as high byte of mantissa push h ;save op2 push drz dones ;done shifting mov b,a ;install counter shft: srlr d ;shift high byte rrar e ;rotate low byte djnz shft ;continue until done dones: xra a ;clear acc, carry bit sign,l ;check sign bit rz ;sign is +ive, return now! lxi h,0 ;negate de dsbc d ;by subtracting dntngt: xchg ;return integer in de ret zeroi: lxi d,0 ;return a value of zero xra a ;clear acc ret ;FILL AND FLUSH BUFFER FOR RANDOM ACCESS OPERATIONS ; NAME RBLOCK ENTRY RBLOCK EXT BYTIN,BYTOT,POPHDB,SELDSK,PUSHBD,DERR INCLUDE DEFLT.SRC ; ;RECORD NUMBER IN DE, RECORD SIZE IN HL. MULTIPLY NUMBERS AND DIVIDE ;BY 128 TO GET BLOCK NUMBER AND OFFSET. RETURNS BLOCK NUMBER ;IN REGISTERS D(HIGH BYTE),E, AND C(LOW BYTE), AND OFFSET IN B. ;FILLS AND FLUSHES FILE BUFFER DEPENDING ON PRESENT AND PREVIOUS ;I/O OPERATIONS. ; RBLOCK: CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A ;SEE IF BUFFER SHOULD BE SEQUENTIALLY BEFORE DOING ANY DIRECT ACCESS. INX H INX H INX H ;FCB PUSH H LXI D,DATAB DAD D ;HL NOW POINTS TO START OF DATA BUFFER. XCHG MVI C,26 ;CP/M CODE TO SET DMA ADDRESS. CALL CPM POP H ;FCB PUSH H XCHG MVI C,21 ;CP/M CODE TO WRITE A SECTOR CALL CPM ORA A ;TEST FOR ERROR CODE JNZ DERR POP H PUSH H LXI D,128+DATAB DAD D ;HL NOW POINTS TO SECOND HALF OF DATA BUFFER XCHG MVI C,26 ;CP/M CODE TO SET DMA ADDRESS CALL CPM POP H PUSH H XCHG MVI C,21 ;CHG MVI C,26 ;CODE TO SET DMA CALL CPM POP D ;FILE BUFFER ADDRESS INX D INX D INX D PUSH D ;SAVE FCB ADDRESS MVI C,SETRAN-2 ;WRITE RANDOM,128 BYTES FROM BUFFER CALL CPM POP H ;FILE CONTROL BLOCK PUSH H ;WRITE FIRST 128-BYTE BLOCK FROM BUFFER LXI D,RANREC DAD D ;LOW BYTE OF BLOCK NUMBER DCR M ;SUBTRACT ONE FOR PREVIOUS BLOCK MOV A,M INR A ;CHECK FOR A BORROW JRNZ W2SET ;NO BORROW INX H ;HIGH BYTE DCR M JRNZ W2SET ;NO BORROW INX H ;OVERFLOW BYTE DCR M W2SET: P call fadd ;increase the magnitude of op1 by .5 pop d ;get number to truncate pop h jr trunc2 ;...and go truncate L129: trunc: pop h ;get return address pop d ;get low word of # xthl ;get high word trunc2: mov e,d ;throw away low 8 bits mov d,l bit sign,h ;check for negative exponent jrnz zeroi ;return zero integer mvi a,15 ;# of shifts assuming zero exponent sub h ;get actual # of shifts jc rngerr ;number too big return error message res sign,d ;clear sign bit jENTIAL READ RRPREP: BSET 4,M ;RANDOMLY ACCESSED MOV D,4(X) ;RECORD NUMBER HIGH BYTE MOV H,2(X) ;RECORD SIZE HIGH BYTE MOV L,1(X) ;RECORD SIZE LOW BYTE POP B ;FILE BUFFER ADDRESS PUSH B XRA A ;ZERO IN A REG TO RBLOCK INDICATES READ CALL RBLOCK ;PERFORM DIRECT READ RRCLN: POP H ;FBA POP D ;PARAMETER COUNT JR FILTST SEQRD: POP H ;FBA PUSH H BIT 3,M ;WAS PREVIOUS OPERATION A WRITE JRNZ RRPREP ;YES, MUST FLUSH BUFFER POP H POP D ;PARAM. COUNT FILTST: XRA A ;NO,SEQUENTIAL READ FLUSHED PUSH PSW ;SAVE PRESENT OP CODE,1-WRITE,0-READ PUSH B ;SAVE FILE BUFFER ADDRESS PUSH H ;RECORD SIZE PUSH D ;RECORD NUMBER MOV H,B ;HL <- FBA MOV L,C PUSH H INX H INX H INX H CALL SELDSK ;SELECT PROPER DRIVE POP H ;FBA BIT 2,M ;HAS FILE BEEN WRITTEN TO? JRZ RNMULT ;NO, DON'T NEED TO FLUSH BUFFER BIT 4,M ;WRITTEN TO. WAS IT DIRECT OR SEQUENTIAL? JRNZ DRCWRT ;FILE HAS BEEN RANDOMLY WRITTEN ; ; ACCESSING A FILE WHICH HAS BEEN SEQUENTIALLY WRITTEN. MUST FLUSH ; BUFFERP/M CODE TO WRITE A SECTOR CALL CPM ORA A JNZ DERR POP H ;FCB DCX H DCX H DCX H ;FBA JRZ RNMULT ;NOW CALCULATE DIRECT RECORD NUMBER DRCWRT: BIT 3,M ;INDICATES WHETHER PREV.I/O WAS READ OR WRITE JRZ RNMULT ;DON'T FLUSH BUFFER,PREVIOUS OP. WAS READ ;PREVIOUS I/O A WRITE. MUST FLUSH BUFFER WHETHER PRESENT I/O IS ;A READ OR WRITE. BUFFER MUST BE FLUSHED USING DIRECT ACCESS. ; ; WRITE SECOND 128-BYTE BUFFER FIRST RFLUSH: PUSH H LXI D,DATAB+3+128 DAD D ;FIRST BYTE FOR OUTPUT XCOP H ;FCB PUSH H ;SAVE FCB LXI D,DATAB ;FIRST FREE BYTE DAD D XCHG MVI C,26 ;SET DMA FOR FIRST BLOCK CALL CPM POP D ;FCB MVI C,SETRAN-2 ;RANDOM WRITE CALL CPM ;IS PRESENT OPERATION SEQ OR RANDOM POP B ;RECORD NUMBER PUSH B MOV A,B ORA C ;IF RECORD NUMBER ZERO, SEQUENTIAL WRITE JZ SEQOP ;SEQ. OP. ;MULTIPLY RECORD SIZE BY RECORD-1 TO GET LOCATION OF RECORD IN BYTES RNMULT: POP D ;RECORD NUMBER POP B ;RECORD SIZE POP H ;FBA DCX D ;DECRE. RECORD NUMBER TO TEST FOR 1ST REC. MOV A,D ;WHICH MUST BE HANDLED SLIGHTLY DIFFERENTLY ORA E INX D ;BACK TO REAL VALUE INX H INX H ;GO TO SECOND 'FLAGS' BYTE JRNZ NOTFST ;NOT FIRST RECORD BSET 0,M ;SET FIRST BIT TO INDICATE FIRST REC. XRA A LXI D,RANREC+1 DAD D ;LOW BYTE OF BLOCK NUMBER MOV M,A ;ZERO BLOCK FOR FIRST RECORD INX H ;HIGH BYTE MOV M,A INX H ;OVERFLOW BYTE MOV M,A LXI D,-RANREC-5 DAD D ;FBA PUSH H XCHG JMP FSTREC NOTFST: RES 0,M ;RESET BIT FOR NOT FIRST RECORD DCX H DCX H PUSH H ;SHIFT MULTIPLIER XCHG RA: JRNC RALOOP ;NEXT SHIFT DAD B ;ADD IN MULTIPLICAND JRNC RALOOP ;NEXT SHIFT INX D ;CARRY TO DE JR RALOOP ;NEXT SHIFT INXDE: DAD H XCHG INX D ;CARRY TO DE JR RA ;FOUR BYTE NUMBER WITH HIGH BYTES IN DE AND LOW BYTES IN HL IS ;DIVIDED BY 128.OFFSET IS LOW SEVEN BITS OF L. H,E,AND D ARE EACH ;SHIFTED LEFT ONE BIT AND CARRY FROM PREVIOUS REGISTER SHIFT IS ADDED. ;BLOCK NUMBER IS RETURNED IN D,E,C. OFFSET IN B. BLKCAL: DCX H ;DECR BYTE COUNT TO CORRECTLY PLACE MOL BLOCK PUSH D ;HIGH BYTES OF BLOCK NUMBER LXI D,RANREC+3 DAD D POP D MOV M,C ;LOW BYTE OF BLOCK NUMBER INX H MOV M,E ;HIGH BYTE OF BLOCK NUMBER INX H MOV M,D ;OVERFLOW BYTE OF BLOCK NUMBER POP D ;FILE BUFFER ADDRESS JR RRFILL SEQOP: POP H ;RECORD NUMBER POP H ;RECORD SIZE POP D ;FBA LXI H,BYTPT+3 DAD D ;BYTE POINTER MOV B,M ;GET OFFSET RRFILL: PUSH B ;SAVE OFFSET PUSH D ;FBA FSTREC: LXI H,RANREC+2 DAD D ;SET CURRENT RECORD TO ZERO MVI M,0 LXI H,DATAB+3 DAD D ;CK PUSH D LXI H,DATAB+128 ;FIRST FREE BYTE DAD D XCHG MVI C,26 ;SET DMA FOR SECOND BLOCK CALL CPM POP D ;FCB PUSH D MVI C,SETRAN-3 ;RANDOM READ CALL CPM ;SET BYTE POINTER POP H ;FCB DCX H ;SECOND 'FLAGS' BYTE BIT 0,M ;RECORD NUMBER 1 ? LXI D,BYTPT+1 ;BUFFER BYTE POINTER/COUNTER DAD D JRZ R2SET1 ;NOT REC. # 1 POP PSW ;PRESENT OPERATION? ORA A JRNZ R2SET2 ;DOING A WRITE MVI M,0 ;SET OFFSET TO ZERO INX H INX H ;FIRST BYTE OF DATA MOV C,M LXI D,-BYTPT-4 DAD D READ AHEAD BYTE MOV M,A DCX H ;'FLAGS' BYTE JR RPREV NOHEAD PUSH PSW ;SAVE OP. INDICATOR LXI D,-BYTPT-3 DAD D ;'FLAGS' BYTE RPREV: POP PSW ;A REG. INDICATES OPERATION ORA A JRZ RR BSET 3,M ;SET 'PREV.WRITTEN' INDICATOR FOR NEXT I/O JMP POPHDB ;RESTORE REGISTERS AND RETURN RR: RES 3,M ;RESET 'PREV.WRITTEN' INDICATOR FOR NEXT I/O RRRET: JMP POPHDB ;RESTORE REGISTERS AND RETURN FBA MOV H,B ;RECORD SIZE INTO HL FOR CALCULATIONS MOV L,C XRA A MVI B,17 ;FAST MULTIPLY--NO ERROR CHECKING DCX D ;RECORD NUMBERS BEGIN AT ONE CMP D ;OPTIMIZATION SECTION JRZ RAOPT ;CHECK FOR A ZERO HIGH BYTE CMP H JRNZ RANOPT ;CAN'T FIND ONE XCHG RAOPT: MVI B,9 ;ONLY DO NINE SHIFTS MOV D,E MOV E,A RANOPT: MOV A,B ;NUMBER OF SHIFTS MOV B,H MOV C,L LXI H,0 ;CLEAR RESULT RALOOP: DCR A JRZ BLKCAL ;CHECK SHIFT COUNTER DAD H ;SHIFT PARTIAL RESULT XCHG JRC INXDE DAD H ;OV A,L ;OFFSET INTO BUFFER FOR READ OR WRITE ANA H ADI 1 JRNZ RBCAL DCX D RBCAL: XRA A MOV B,L RES 7,B ;OFFSET IN B ;BLOCK NUMBER CALCULATION SLAR H PUSH PSW ;SAVE FLAGS BIT 7,L ;TEST HIGH BIT OF L JRZ LMSB INR H ;FROM HIGH BIT OF L LMSB: POP PSW JRNC ESHIFT SLAR E INR E ;FROM HIGH BIT OF H JR DBIT ESHIFT: SLAR E DBIT: JRNC DSHIFT SLAR D INR D ;FROM HIGH BIT OF E JR DMSB DSHIFT: SLAR D DMSB: MOV C,H ;LOW BYTE POP H ;FBA PUSH H ;SET BLOCK NUMBER IN FILE CONTRFIRST BYTE FOR INPUT XCHG MVI C,26 ;CODE TO SET DMA CALL CPM POP D ;FILE BUFFER ADDRESS INX D INX D INX D PUSH D ;FILE CONTROL BLOCK MVI C,SETRAN-3 ;READ RANDOM,128 BYTES INTO BUFFER CALL CPM POP H ;FILE CONTROL BLOCK PUSH H ;READ SECOND 128-BYTE BLOCK INTO BUFFER LXI D,RANREC DAD D ;LOW BYTE OF BLOCK NUMBER INR M ;ADD ONE FOR NEXT BLOCK JRNZ R2SET ;NO CARRY INX H ;HIGH BYTE INR M JRNZ R2SET ;NO CARRY INX H ;OVERFLOW BYTE INR M R2SET: POP D ;FILE CONTROL BLO;READ AHEAD BYTE MOV M,C ;FILL WITH FIRST BYTE DCX H ;FBA PUSH PSW ;SAVE PRESENT OPERATION JR RPREV R2SET2: MVI M,0FFH ;SET OFFSET FOR WRITE JR NOHEAD R2SET1: POP B ;OFFSET IN B MOV M,B ;SAVE POINTER POP PSW ;PRESENT OPERATION ORA A JRNZ NOHEAD ;DOING A WRITE PUSH PSW ;READING LXI D,-BYTPT DAD D ;FCB PUSH H CALL BYTIN ;FILL READ AHEAD BYTE AND ADVANCE OFFSET POP H LXI D,RANREC-1 DAD D ;CURRENT RECORD BYTE MVI M,0 ;SET CURRENT RECORD TO ZERO LXI D,-RANREC-1 DAD D ;ET CHARACTER CPI CR ;CARRIAGE RETURN? JRZ NDSTR CPI LF ;LINE FEED? JRZ NDSTR CPI EOFMRK JRZ NDSTR ;END OF FILE? XTHL INR C ;INCREMENT ACTUAL LENGTH EXAF MOV A,B ;MAXIMUM LENGTH CMP C ;CHECK FOR STRING OVERFLOW JRC STRER ;OVERFLOW EXAF MOV M,A ;STORE CHAR. DCX H JR STRG ;GET NEXT CHAR STRER: POP H ;FBA XRA A CMP H ;CONSOLE FILE? JNZ STRERR ;NO PUSH H ;YES, TYPE ERROR MESSAGE AND TRY AGAIN LXI H,STRMSG ;'string too long' CALL TXTYP ;PRINT MESSAGE MVI C,20H C;ROUTINE TO REWRITE AN OUTPUT FILE ; NAME REWRIT ENTRY REWRITE,L123,ERRTMF EXT CLSOT,DELETE,OPNOT,MOVNAM,SCAN,PERROR INCLUDE DEFLT.SRC ; ;SYSTEM FILE BUFFER STRUCTURE ;FIRST BYTE IS FLAGS BYTE.BIT 0-EOLN,1-EOF,2-WRITTEN,3-PREVIOUS ;OPERATION A WRITE,4-RANDOMLY ACCESSED FILE. ;SECOND IS THE READ AHEAD BYTE FOR INPUT FILES ;REWRITE OPENS A FILE TO BE WRITTEN TO BY ;THE USER UNDER THE NAME X L123: REWRITE:POP D ;RETURN ADDRESS INX H INX H INX H ;MOVE THE NAME INTO THE BUFFER CALLRROR BSET 2,M ;SET WRITTEN FLAG RES 3,M ;RESET PREV WRITTEN FLAG RES 4,M ;RANDOMLY ACCESSED FLAG XRA A XCHG PCHL ;CHKLST EITHER FINDS THE BUFFER ADDRESS IN THE LIST, ;ADDS IT TO THE LIST, OR PRINTS AN ERROR IF MORE THAN ;MAXOUT OUTPUT FILES ARE OPEN SIMULTANEOUSLY. CHKLST: PUSH Y CALL SCAN JRNC NOTFND INX H ;CLOSE FILE IF FOUND INX H INX H CALL CLSOT DCX H DCX H DCX H POP Y ;BUFFER IN LIST RET ;BUFFER ISN'T IN THE LIST, CHECK FOR SPACE NOTFND: POP Y PUSH Y PU;compiler doesn't need this DB 'Bad output file nam','e'+80H ENDIF OV A,H ;PUT BUFFER ADDRESS INTO LIST STAX B DCX B MOV A,L STAX B POP Y RET ;TOO MANY OUTPUT FILES OPEN SIMULTANEOUSLY ERRTMF: LXI H,ERRMES JMP PERROR ERRMES: IF NOT COMPILER ;compiler doesn't need this DB 'Too many open output file','s'+80H ENDIF ;BADWRT BAD FILENAME ON OUTPUT FILE ;FATAL ERROR BADWRT: LXI H,BNAM JMP PERROR BNAM: IF NOT COMPILER ;MULT.PRECISION ADD AND SUB. AND NORMALIZE A FLOATING POINT NUMBER ; NAME MPNORM ENTRY MPADD,MPSUB,FNORM EXT FPERR INCLG ; ; CONSET : A SUBROUTINE THAT SETS THE RELEVANT BIT(S) IN A SET TO INDICATE ; THE PRESENCE OF THAT ELEMENT IN THE SET. (hl) -> (de) ; mpadd: xra a ;clear carry push b ;save b mvi b,fracln ;add all bytes mpadd1: ldax d ;get byte from op1 adc m ;add byte from op2 stax d ;store it inx h ;bump pointers inx d djnz mpadd1 ;any more? pop b ;restore b (y) ;and negate fraction posit: zchk y ;check number = 0 jrnz fpanz ;..fpacc <> 0 mvi exp(y),0 ;set exp = 0 ret fpanz: bit sign-1,msb(y) ;check msb jrnz allrot ;all rotated rotate y,left ;rotate left until msb is a one dcr exp(y) ;adjust exponent jv fperr ;floating point error jr fpanz ;try again allrot: dcr scr1(x) ;check sign indicator rnz ;positive number, return bset sign,msb(y) ;negate number and return ret ;  MOVNAM JRC BADWRT ;BAD FILENAME ;LST: OR CON: FILES ARE NOT COUNTED AGAINST THE MAX. NUMBER OF ;OUTPUT FILES SO SKIP CHKLST, DELETE AND OPNOT CALLS DCX H DCX H DCX H ;FBA BIT 6,M ;LST: FILE? JRNZ SETFLG ;YES BIT 7,M ;CON: FILE? JRNZ SETFLG ;YES ;FIND THE FILE BUFFER IN THE LIST OR ADD IT CALL CHKLST INX H INX H INX H ;FCB CALL DELETE ;DELETE ANY DUPLICATES CALL OPNOT ;REOPEN IT DCX H DCX H DCX H SETFLG: BSET 0,M ;SET EOLN FLAG RES 1,M ;EOF FLAG USED FOR DISC WRITE ESH H MOV H,A MOV L,A CALL SCAN JRNC ERRTMF ;ADDRESS OF FIRST FREE SPACE IN LIST IS IN BC POP H ;GET BUFFER ADDRESS MOV A,H ;PUT BUFFER ADDRESS INTO LIST STAX B DCX B MOV A,L STAX B POP Y RET ;TOO MANY OUTPUT FILES OPEN SIMULTANEOUSLY ERRTMF: LXI H,ERRMES JMP PERROR ERRMES: IF NOT COMPILER ;compiler doesn't need this DB 'Too many open output file','s'+80H ENDIF ;BADWRT BAD FILENAME ON OUTPUT FILE ;FATAL ERROR BADWRT: LXI H,BNAM JMP PERROR BNAM: IF NOT COMPILER TIVE POP B POP D ;RESTORE ARGUMENT COUNT RZ ;RETURN IF RESULT IS +IVE MOV A,B CMA MOV B,A MOV A,C CMA MOV C,A INX B XRA A RET ;SIGN IS FIXED, ALL DONE!! OVFMSG: XRA A ;CHECK FOR CONSOLE FILE CMP H JRNZ ERRTYP ;NO, FATAL ERROR POP B POP D LXI H,REPROM ;YES, GET NEW INPUT CALL TXTYP OVF1 CALL TIN ;CLEAR INPUT BUFFER CPI CR JRNZ OVF1 LXI H,1 ;CONSOLE FILE JR CONV ;GET NEXT NUMBER ; MULTIPLY A NUMBER BY TEN AND ADD IN THE DIGIT ; STORED IN THE ACCUMU ret ;no, return mpsub: xra a ;clear carry push b ;save b mvi b,fracln mpsub1: ldax d ;get byte from op1 sbb m ;subtract byte from op2 stax d ;store it inx h ;bump pointers inx d djnz mpsub1 ;any more? pop b ;restore b ret ;no, return ; ; normalize a floating point number ; fnorm: xra a ;clear acc mov scr1(x),a ;set sign indicator to +ve num bit sign,msb(y) ;test sign of number jrz posit ;it's positive inr scr1(x) ;negative...set sign indicator res sign,msb; Pascal/Z run-time support interface ; COPYRIGHT 1978, 1979, 1980 BY JEFF MOSKOW NAME MAIN ENTRY FLTERR,HPERR,REFERR,STKERR,RNGERR,DIVERR,MLTERR,L98 ENTRY PERROR,STMTMSG,CRLF,CHAIN$,STRERR,MAXOUT,MXOUT,MXOUT1,STRMSG EXT ILODV,ILODV1,ILODV2,ILOD1,ILOD11,ILOD12,ILOD2,ILOD21,ILOD22 EXT ISTOR,ISTOR1,ISTOR2,XADDR,YADDR,FSUB,FADD,ENTRSC,ENTER,EXITF EXT FPEQ,SEQUL,FPNEQ,SNE,FPLTE,SLE,ILE,FPLT,SLT,ILT EXT FPGTE,SGE,IGE,FPGT,SGT,IGT,FMULT,IMULT,QMULT,IDIVD,IMOD EXT ERROR,CSTS,CI,CO,CHKDE, S: SET 0FFFFH D: SET 0FFFFH E: SET 00000H F: SET 0FFFFH T: SET 00000H VALID: SET 00000H MAXOUT EQU 4 MXOUT EQU MAXOUT*256 MXOUT1 EQU MXOUT*2 CR EQU 13 LF EQU 10 EOFMRK EQU 1AH BUFLEN EQU 80 TOPFRM EQU MAXOUT+MAXOUT+BUFLEN+3+1 MARGIN EQU 50 COMPILER EQU 0H MAXDRV EQU 16 CPM EQU 5 START: MVI C,25 CALL CPM LHLD 6 DCX H MOV M,A LXI B,0 LXI H,LAST EXX LHLD 6 LXI D,0-TOPFRM-1 DAD D PUSH H PUSH H POP X POP Y SPHL MVI B,MAXOUT*2+1 XRA A CLRSTK: MOV M,A INX H AD: MACRO WHERE,VALUE IF VALUE IF VALUE&0FF00H LXI B,VALUE CALL WHERE!2 ELSE MVI C,VALUE CALL WHERE!1 ENDIF ELSE CALL WHERE ENDIF ENDMAC ILOD: MACRO Q,SIZE,OFST IF SIZE&8000H MLOAD ILODV,OFST ELSE IF SIZE-1 MLOAD ILOD2,OFST ELSE MLOAD ILOD1,OFST ENDIF ENDIF ENDMAC ISTR: MACRO Q,SIZE,OFST MLOAD ISTOR,OFST IF R JC REFERR ENDIF ENDMAC LPOP: MACRO REG,DISTANCE IF DISTANCE PUSH H LXI H,DISTANCE+2 DAD S MOV E,M INX H MOV D,M PUSH D MOV D,H;SUBROUTINES FOR SET CONSTRUCTION,UNION,MEMBERSHIP,AND INTERSECTION ; NAME SETCON ENTRY CONSET,UNION,INN,INSECT EXT SAVREG ; ; CONSET : A SUBROUTINE THAT SETS THE RELEVANT BIT(S) IN A SET TO INDICATE ; THE PRESENCE OF THAT ELEMENT IN THE SET. ; ; HL = OFFSET OF FIRST BYTE OF THE SET FROM THE TOP OF THE STACK. ; DE = VALUE OF ELEMENT ; C = REPETITION COUNT ( SUBRANGES ) ; ; IF THE REPETITION COUNT IS NEGATIVE, IGNORE IT AND RETURN IMMEDIATELY ; NO BITS ARE SET IN THIS CASE. ; CONSET: B = BIT POSITION SETBIT: SLAR E ;; ROTATE TO THE CORRECT BIT DJNZ SETBIT SINIT: POP B ;; GET RANGE ( 0..255 ), SO IT'S IN THE C REGISTER MOV B,C INR B ;; COUNT LESS BY ONE -- CHANGE REPETITION COUNT TO ; NUMBER OF BITS TO BE SET MOV A,M ;; GET BYTE IN ACC RANGE: ORA E ;; SET BIT SLAR E ;; GO TO THE NEXT BIT JRNC NOOVER ;; MOV M,A ;; IF OVERFLOW, SAVE BYTE AND MVI E,1 ; START AGAIN WITH BIT 0 OF THE NEXT BYTE DCX H ;; MOV A,M NOOVER: DJNZ RANGE MOV M,A ;; SAVE BYTE XRA A CHKHL,PSTAT,CONSET,UNION,INN,LTEQ EXT GTEQ,INSECT,ORGAN,COMP,FUSS,FOUT,FXDCVT,CVTFLT,TOUT,TXTYP EXT FDIVD,STREQL,STRNQL,STRLEQ,STRLSS,STRGEQ,STRGRT,LAST EXT WRITELN,L109,L110,L111,L112,L115,L116,L117,L118,L120 EXT READLN,L121,L122,L123,L124,L125,L126,L127,L128,L129 EXT WRITE,L130,L131,L132,L133,L134,L135,L136,L0 EXT READ,L137,ABS,FPABS,SQR,FPSQR,EOLN,EOF,RESET,REWRITE EXT FTXTIN,CHAIN,NEW,MARK,RELEASE,TRUNC,ROUND,ARCTAN,COS EXT EXPFCT,LN,SQRT,SIN R: SET 0FFFFH C: SET 0FFFFH M: SET 0FFFFH DJNZ CLRSTK INX H MOV M,A LXI H,80H CMP M JRZ NOCOM MOV B,M DCR B INX H INITLP INX H MOV C,M CALL TOUT DJNZ INITLP NOCOM MVI C,CR CALL TOUT JMP L99 FINI: MACRO JMP L0 END START ENDMAC EXTD: MACRO INTN,EXTN EXT EXTN INTN: equ EXTN ENDMAC SPSH: MACRO Q,SIZE IF SIZE IF SIZE&8000H LXI H,SIZE DAD S SPHL ELSE MVI A,SIZE CMP M JC STRERR MOV B,A INR B PSHLP: SET $ MOV D,M PUSH D INX S DCX H DJNZ PSHLP XRA A ENDIF ENDIF ENDMAC MLO MOV E,L DCX H DCX H LXI B,DISTANCE LDDR POP D POP H POP B ELSE POP D ENDIF ENDMAC ADDR: MACRO Q TEMP SET 'Q'-'IY' IF 'Q'-'Y'*TEMP CALL XADDR ELSE CALL YADDR ENDIF ENDMAC MIDL: MACRO REG,LEVEL PUSH X MVI A,LEVEL MIDL1: SET $ MOV C,4(X) MOV B,5(X) PUSH B POP X CMP 1(X) JRNZ MIDL1 XRA A ENDMAC DSUB: MACRO Q,SIZE IF 0!SIZE&8000H CALL FSUB IF F JC FLTERR ENDIF ELSE XRA A DSBC Q D ENDIF ENDMAC DADD MACRO Q,SIZE IF 0!SIZE&8000H ; IS THE REPETITION COUNT NEGATIVE ? INR C DCR C JRZ LEGRNG ; IF NON-ZERO AND CARRY FLAG SET -- YES RC LEGRNG DAD S ; HL -> FIRST BYTE OF THE SET PUSH B PUSH D SRLR E ;; DE = VALUE SRLR E SRLR E ; DE = NUMBER OF BYTES OFFSET FROM START OF SET XRA A DSBC D ;; HL -> BYTE ON STACK POP B ;; BC = VALUE MOV A,C ANI 7 ;; GET LOW THREE BITS -- OFFSET IN BYTE MVI E,1 ; START WITH BIT 0 ; CPI 0 ;; IS IT BIT 0 ? ( ZERO FLAG SET/CLEARED BY ANI ) JRZ SINIT ;; YES -- DONE MOV B,A ; RET ; UNION : A ROUTINE THAT TAKES THE UNION OF TWO SETS ON THE STACK AND ; STORES IT IN THE FIRST SET -- THE ONE AT THE HIGHER LOCATION ON ; THE STACK. ; ; HL = OFFSET IN BYTES OF THE SECOND SET FROM THE TOP OF THE STACK ; DE = OFFSET FROM START OF SECOND SET OF THE EQUIVALENT BYTE IN THE ; FIRST SET. ; UNION: CALL SAVREG ; SAVE THE APPROPRIATE REGISERS AND SET UP POINTERS ; HL -> START OF SECOND SET ; DE -> START OF FIRST SET ; B = SIZE OF SECOND SET ORBIT: MOV A,M ;; GET BYTE FROM 2ND SET XCHG ORA M ;; OR WITH BYTE FROM 1ST SET MOV M,A ;; SAVE IT XCHG DCX H ; GO ON TO NEXT BYTE DCX D DJNZ ORBIT POP H ; HL = OFFSET OF SECOND SET FROM TOP OF STACK + 2 POP D ; DE = RETURN ADDRESS DAD S ;; REMOVE THE 2ND SET FROM THE STACK SPHL XCHG ; HL = RETURN ADDRESS XRA A PCHL ; INN : A ROUTINE TO TEST FOR THE MEMBERSHIP OF AN ELEMENT IN A SET. ; ; HL = OFFSET OF ELEMENT FROM TOP OF STACK ; DE = VALUE OF FIRST ELEMENT IN SET DIV 8 ; INN: DAD S ;; POINT TO VAESET TO POINT TO THE LOCATION OF THE ELEMENT IN THE SET WITH ; AN ORDINAL VALUE OF 0 EVEN IF IT DOES NOT EXIST. ; DAD D SRLR C ;; CALCULATE THE LOCATION IN THE SET ; OF THE ELEMENT SRLR C SRLR C ORA A ;; CLEAR CARRY DSBC B ;; POINT TO RELEVANT BYTE IN SET ANI 7 MOV B,A ;; GET POSITION WITHIN SET MVI A,1 ; START WITH BIT 0 IN THE BYTE JRZ SET2 ;; IF ZERO THEN DONE ( ZERO FLAG SET/CLEARED BY ANI ) SET1: ADD A ;; ROTATE TO CORRECT BIT POSITION DJNZ SET1 SET2: ANA M ;; SEE IF BD SET OF EQUIVALENT BYTE IN FIRST SET ; INSECT: CALL SAVREG ; HL -> SECOND SET ; DE -> EQUIVALENT BYTE IN FIRST SET ; B = SIZE OF SECOND SET ANDBIT: LDAX D ANA M STAX D DCX H DCX D DJNZ ANDBIT POP H ; HL = OFFSET OF SECOND SET POP D ; DE = RETURN ADDRESS DAD S ; REMOVE SECOND SET FROM STACK SPHL XCHG ; HL = RETURN ADDRESS XRA A PCHL  LOGICAL ; AND OF TWO SETS. ; ; HL = OFFSET OF START OF SECOND SET FROM THE TOP OF STACK ; DE = OFFSET FROM START OF SECON;SAVE THE HL REG AND SET UP THE POINTERS TO THE TWO SETS ON THE STACK ; NAME SAVREG ENTRY SAVREG ; ; ; ON ENTRY : ; HL = OFFSET OF SECOND SET FROM TOP OF STACK ; DE = OFFSET FROM HL OF EQUIVALENT BYTE IN FIRST SET ; ; ON EXIT : ; HL -> SECOND SET ; DE -> FIRST SET ; B = SIZE OF SECOND SET ( OFFSET OF SET FROM TOP OF STACK ) ; ; THE RETURN ADDRESS IS PUSHED TWO LOCATIONS LOWER ON THE STACK AND ; THE OFFSET OF THE SECOND SET IS STORED IN ITS OLD LOCATION. ; THE OFFSET IS USED LATER;STRUCTURED RELATIVE OPERATORS ; NAME SRELOP ENTRY SEQUL,SNE,SLE,SLT,SGE,SGT ; ; ;THESE ROUTINES ARE CALLED WITH THE LENGTH OF ;THE PARAMETERS IN BC, AND THE PARAMETERS ;ARE ON THE STACK IMMEDIATELY UNDERNEATH THE ;RETURN ADDRESS. THE BYTE IN THE PARAMETER OCCUPYING ;THE HIGHEST MEMORY LOCATION IS THE MOST SIGNIFICANT. ;EXPRESSIONS ARE EVALUATED AB WHERE A IS ;THE PARAMETER OCCUPYING THE HIGHER MEMORY ADDRESSES. ;THE ROUTINES REMOVE THE PARAMETERS FROM THE STACK ;WHEN THEY RETURN AND SR PUSH H MOV C,M MOV A,C ; A AND C REGS CONTAIN THE VALUE OF THE ELEMENT DCX H ;; HL -> FIRST BYTE OF SET ; ; TO OPTIMIZE FOR STORAGE IN SETS, ONLY THE SPACE THAT ACTUALLY GETS USED ; IS ALLOCATED. FOR EXAMPLE FOR A SET OF CHAR, 16 BYTES OF STORAGE ARE ; ALLOCATED BUT FOR A SET OF 'A'..'Z' ONLY 4 BYTES OF STORAGE ARE ALLOCATED. ; SO FOR A SET OF 'A'..'Z', THE FIRST ELEMENT IN THE SET HAS AN ORDINAL ; VALUE OF 65. BEFORE THE TEST FOR MEMBERSHIP CAN BE MADE, THE POINTER TO THE ; SET HAS TO BE RIT IS SET POP H ;; RESET STACK POINTER POP D SPHL XCHG ; RETURN ADDRESS -> HL INX S ; REMOVE VAR FROM STACK INX S JRZ NOTIN ;; IF ZERO THEN NOT IN SET( SET/CLEARED BY ANA ) STC ;;IS IN THE SET NOTIN: MVI A,0 PCHL ; ; INSECT : A ROUTINE TO TAKE THE INTERSECTION OF TWO SETS ON THE STACK AND ; STORE THE RESULT IN THE FIRST. INTERSECTION IS EQUIVALENT TO THE LOGICAL ; AND OF TWO SETS. ; ; HL = OFFSET OF START OF SECOND SET FROM THE TOP OF STACK ; DE = OFFSET FROM START OF SECON TO CALCULATE HOW MANY BYTES TO ; REMOVE, TO REMOVE THE SECOND SET FROM THE SET. ; SAVREG: POP B ; B = RETURN ADDRESS PUSH H ; OFFSET OF SECOND SET PUSH B MOV B,L ; B = SIZE OF SECOND SET ( 0..255 ) DAD S ; SET HL TO POINT TO START OF SECOND SET INX H ; CORRECT FOR OFFSET AND RETURN ADDRESS ON THE STACK INX H INX H INX H INX H XCHG ; DE -> SECOND SET DAD D ; HL -> FIRST SET XCHG RET ENDIF ET THE CARRY IF THE ;CONDITION IS TRUE. Z0012 EQU 6 ;SYSTEM LOCATIONS ;STRUCTURED EQUALS SEQUL: CALL Z0009 RET ;STRUCTURED NOT EQUALS SNE: CALL Z0009 CMC ;COMPLEMENT THE CARRY RET ;STRUCTURED GREATER THAN SGT: CALL Z0010 RET ;STRUCTURED LESS THAN OR EQUALS SLE: CALL Z0010 CMC ;COMPLEMENT THE CARRY RET ;STRUCTURED LESS THAN SLT: CALL Z0011 RET ;STRUCTURED GREATER THAN OR EQUALS SGE: CALL Z0011 CMC ;COMPLEMENT CARRY RET ;Z0009 EVALUATES THE EQUALS CONDITION AND SETS THE CARRY Z0009: PUSH X LXI X,Z0012 DADX S PUSH X POP H ;HL POINTS TO SECOND OPERAND DADX B ;X POINTS TO FIRST OPERAND ;COMPARE THE TWO OPERANDS BYTE BY BYTE Z0001: MOV A,0(X) INX X CCI JRNZ Z0008 JV Z0001 ;THE TWO OPERANDS ARE IDENTICAL ;CONDITION IS TRUE, CLEAN UP AND SET THE CARRY Z0014: XTIX ;RESTORE IX POP H ;GET NEW SP POP D ;GET FIRST RETURN ADDR POP B ;GET SECOND RETURN ADDR SPHL ;SET NEW STACK POINTER PUSH B ;RESTORE SECOND RETURN ADDR ITION AND SETS THE CARRY Z0010: PUSH X LXI X,Z0012-1 DADX S DADX B PUSH X POP H ;HL POINTS TO SECOND OPERAND DADX B ;X POINTS TO FIRST OPERAND PUSH X ;BEGINNING OF PARAMETER LIST ;COMPARE THE TWO OPERANDS BYTE BY BYTE Z0002: MOV A,M CMP 0(X) DCX X DCX H JRC Z0004 JRNZ Z0006 DCX B XRA A ;CLEAR CARRY AND CHECK FOR THE END OF PARAMETERS CMP B JRNZ Z0002 CMP C JRNZ Z0002 ; OPERANDS ARE ACTUALLY IDENTICAL Z0006: POP X INX X JMPR Z0013 ;THE GREATER THAN CONCMP C JRNZ Z0003 JR Z0006 ORDINGLY Z0011: PUSH X LXI X,Z0012-1 DADX S DADX B PUSH X POP H ;HL POINTS TO SECOND OPERAND DADX B ;X POINTS TO FIRST OPENAND PUSH X ;BEGINNING OF PARAMETER LIST ;COMPARE THE TWO OPERANDS BYTE BY BYTE Z0003: MOV A,M CMP 0(X) DCX X DCX H JRC Z0006 JRNZ Z0004 DCX B XRA A ;CLEAR CARRY AND CHECK FOR THE END OF PARAMETERS CMP B JRNZ Z0003 ; intrinsic functions for sine and cosine ; NAME SINCOS ENTRY SIN,COS,L132,L136 INCLUDE DEFLT.SRC INCLUDE FCTMAC.SRC ; L136: ; ; (* ; * intrinsic function for sine ; *) ; function sin( x: real ):real; ; const a1 = 1.5707949; ; a3 = -0.64592098; ; a5 = 0.07948766; ; a7 = -0.004362476; ; piu2 = 0.6366197724; (* 2 / pi *) ; var x2: real; ; schg: boolean; ; begin FCT375 sin: ENTR D,2,5 ; schg := false; FCC375 MOV -4(IX),A ; 4(IX) JRC FCT431 FCT430 FCT432 EQU FCT430 FCT435 EQU FCT432 INR A FCT431 MOV L,A XRA A MOV H,A MOV -4(IX),L JMP FCT414 FCT413 ; while x <= -halfpi do begin FCT438 LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR LXI H,484 LXI D,-30739 PUSH H PUSH D LE D,-4 JNC FCT437 ; x := x + pi; LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR LXI H,612 LXI D,-30739 PUSH H PUSH D DADD DXCHG ;RETURN ADDR -> HL XRA A ;CLEAR ACCUMULATOR STC ;SET THE CARRY PCHL ;RETURN ;THE TWO OPERANDS ARE NOT EQUAL Z0008: DADX B ;NEW STACK POINTER ;CONDITION IS FALSE, CLEAN UP AND RESET THE CARRY Z0013: XTIX ;RESTORE IX POP H ;GET NEW SP POP D ;GET FIRST RETURN ADDR POP B ;GET SECOND RETURN ADDR SPHL ;SET NEW STACK POINTER PUSH B ;RESTORE SECOND RETURN ADDR XCHG ;RETURN ADDR -> HL XRA A ;CLEAR ACCUMULATOR PCHL ;RETURN ;Z0010 EVALUATES THE GREATER THAN CONDDITION IS TRUE Z0004: POP X INX X JMPR Z0014 ;Z0011 ACTUALLY EVALUATES THE LESS THAN CONDITION AND SETS THE CARRY ; ACCORDINGLY Z0011: PUSH X LXI X,Z0012-1 DADX S DADX B PUSH X POP H ;HL POINTS TO SECOND OPERAND DADX B ;X POINTS TO FIRST OPENAND PUSH X ;BEGINNING OF PARAMETER LIST ;COMPARE THE TWO OPERANDS BYTE BY BYTE Z0003: MOV A,M CMP 0(X) DCX X DCX H JRC Z0006 JRNZ Z0004 DCX B XRA A ;CLEAR CARRY AND CHECK FOR THE END OF PARAMETERS CMP B JRNZ Z0003 while x > halfpi do begin FCT414 LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR LXI H,356 LXI D,-30739 PUSH H PUSH D GRET D,-4 JNC FCT413 ; x := x - pi; LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR LXI H,612 LXI D,-30739 PUSH H PUSH D DSUB D,-4 LXI H,3 DADD S XCHG PUSH IX POP H LXI B,11 DADD B XCHG LXI B,4 LDDR POP H POP H ; schg := not schg ; end; CMP -,-4 LXI H,3 DADD S XCHG PUSH IX POP H LXI B,11 DADD B XCHG LXI B,4 LDDR POP H POP H ; schg := not schg ; end; CMP -4(IX) JRC FCT455 FCT454 FCT456 EQU FCT454 FCT459 EQU FCT456 INR A FCT455 MOV L,A XRA A MOV H,A MOV -4(IX),L JMP FCT438 FCT437 ; x := x * piu2; LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR LXI H,81 LXI D,31937 PUSH H PUSH D MULT D,-4 LXI H,3 DADD S XCHG PUSH IX POP H LXI B,11 DADD B XCHG LXI B,4 LDDR POP H POP H ; x2 := x * x; LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR MULT D,-4 LXI H,3 DADD S XCHG PUSH IX POP H XCHG LXI B,4 LDDR POP H POP H ; x := (((a7*x2 + a5)*x2 + a3)*x2 + a1)*x; LXI H,-1593 LXI D,31116 PUSH H PUSH D LXI H,-4 DADD S SPHL XCHG PUSH IX POP H DCX H DCX H DCX H I H,3 DADD S XCHG PUSH IX POP H LXI B,11 DADD B XCHG LXI B,4 LDDR POP H POP H ; if schg then x := -x; CMP -4(IX) JNC FCT494 LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR NEGT E LXI H,3 DADD S XCHG PUSH IX POP H LXI B,11 DADD B XCHG LXI B,4 LDDR POP H POP H FCT494 ; sin := x; LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR LXI H,3 DADD S XCHG PUSH IX end; JMP FCC375 ; on for cosine ; *) ; function cos( x: real ):real; ; begin FCT513 L132: cos: ENTR D,2,5 ; cos := sin( x + halfpi ) LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR LXI H,356 LXI D,-30739 PUSH H PUSH D DADD D,-4 LXI H,3 DADD S XCHG PUSH IX POP H LXI B,11 DADD B XCHG LXI B,4 LDDR POP H POP H ; ;SET ROUTINES TO TEST LTEQ,GTEQ,DIFFERENCE,EQUALITY,INEQUALITY ; NAME SETFTN ENTRY LTEQ,GTEQ,ORGAN,COMP,FUSS EXT SAVREG ; ; ; LTEQ : A ROUTINE TO COMPARE TWO SETS ON THE STACK AND SEE IF THE FIRST IS ; LESS THAN OR EQUAL TO THE SECOND AS DEFINED IN JENSEN AND WIRTH. ; ; HL = OFFSET (IN BYTES) OF START OF SECOND SET FROM TOP OF STACK ; DE = OFFSET (IN BYTES) FROM START OF SECOND SET OF EQUIVALENT BYTE ; IN FIRST SET. ; FOR EXPLANATION OF WHY THE FIRST SET MAY NOT BE THE THE SAME SIZE AS THEGTEQ: CALL SAVREG ; HL -> START OF SECOND SET ; DE -> EQUIVALENT BYTE IN FIRST SET ; B = SIZE OF SECOND SET. ; ; THE CODE HAS TO FALL THROUGH HERE !!!! ; ; ; LTGTEQ : A COMMON ROUTINE SHARED BY LTEQ AND GTEQ. IT COMPARES THE TWO SETS ; POINTED TO BY THE HL AND DE REGISTERS. IF THE SET POINTED TO BY HL ; IS LESS THAN OR EQUAL TO THE SET POINTED TO BY THE DE PAIR, IT ; RETURNS WITH THE CARRY SET. ( BIT 8 OF THE ACC SET ) ; ; LTEQ CALLS IT WITH HL POINTING TO THE FIRST SET AND DE POINTING TOLXI B,4 LDIR MULT D,-4 LXI H,-687 LXI D,25910 PUSH H PUSH D DADD D,-4 LXI H,-4 DADD S SPHL XCHG PUSH IX POP H DCX H DCX H DCX H LXI B,4 LDIR MULT D,-4 LXI H,210 LXI D,-21111 PUSH H PUSH D DADD D,-4 LXI H,-4 DADD S SPHL XCHG PUSH IX POP H DCX H DCX H DCX H LXI B,4 LDIR MULT D,-4 LXI H,356 LXI D,-30745 PUSH H PUSH D DADD D,-4 LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR MULT D,-4 LX POP H LXI B,15 DADD B XCHG LXI B,4 LDDR POP H POP H ; end; EXIT D,4 ; ; (* ; * intrinsic function for cosine ; *) ; function cos( x: real ):real; ; begin FCT513 L132: cos: ENTR D,2,5 ; cos := sin( x + halfpi ) LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR LXI H,356 LXI D,-30739 PUSH H PUSH D DADD D,-4 LXI H,3 DADD S XCHG PUSH IX POP H LXI B,11 DADD B XCHG LXI B,4 LDDR POP H POP H ; ; SECOND SET SEE COMMENTS IN INN ROUTINE. ; ; ; LTEQ: CALL SAVREG ; HL -> FIRST BYTE OF SECOND SET ; DE -> EQUIVALENT BYTE IN FIRST SET ; B = SIZE OF SECOND SET ( IN BYTES ) XCHG JR LTGTEQ ; ; GTEQ : A ROUTINE TO COMPARE TWO SETS ON THE STACK AND DETERMINE IF THE ; SECOND SET IS GREATER THAN OR EQUAL TO THE FIRST SET AS DEFINED IN ; JENSEN AND WIRTH. ; ; HL = OFFSET OF START OF SECOND SET FROM TOP OF STACK. ; DE = OFFSET FROM START OF SECOND SET OF EQUIVALENT SET IN FIRST SET. ; THE ; SECOND SET. ; GTEQ CALLS IT WITH HL POINTING TO THE SECOND SET AND HL POINTING TO THE ; FIRST SET. ; ; B = NUMBER OF BYTES IN SECOND SET. ; LTGTEQ: MOV A,M ; GET BYTE FROM ONE SET XCHG ORA M ; COMPARE IT WITH THE OTHER SET XRA M JRNZ NO ; IF NZ, THEN NOT =< DCX H ; DECREMENT POINTERS AND REPEAT WITH THE NEXT BYTE DCX D XCHG DJNZ LTGTEQ POP H ; HL = OFFSET OF SECOND SET POP D ; DE = RETURN ADDRESS DAD S ; REMOVE SECOND SET FROM STACK SPHL XCHG ; HL = RETURN ADDRESS MVI A,80H PCHL NO: POP H POP D DAD S SPHL XCHG XRA A PCHL ; ; ORGAN : A ROUTINE TO TAKE THE DIFFERENCE OF TWO SETS ON THE STACK AND ; STORE THE RESULT IN THE FIRST SET. THE DIFFERENCE OF TWO SETS IS ; DEFINED TO BE THE ELEMENTS OF THE FIRST SET THAT ARE NOT PRESENT ; IN THE SECOND SET. ; ; HL = OFFSET OF START OF SECOND SET FROM TOP OF STACK ; DE = OFFSET FROM START OF SECOND SET OF EQUIVALENT BYTE IN FIRST SET ; ORGAN: CALL SAVREG ; HL -> SECOND SET ; DE -> FIRST SET ARE EQUAL ; THIS IS DONE BY TAKING THE EXCLUSIVE OR OF THE TWO SETS. IF THE RESULT ; IS NOT ZERO THEN THEY ARE NOT ZERO. ; ; HL = OFFSET OF FIRST BYTE OF SECOND SET FROM TOP OF STACK ; DE = OFFSET FROM START OF SECOND SET OF EQUIVALENT BYTE IN THE FIRST ; SET ; COMP: CALL SAVREG ; HL -> SECOND SET ; DE -> FIRST SET ; B = SIZE OF SECOND SET MVI C,1 ; INDICATE TEST FOR EQUALITY ; ; QUERY : A ROUTINE TO TEST FOR EQUALITY/NON-EQUALITY OF TWO SETS ON THE ; STACK. IF THE C REGISTER CONTAINS AURN ADDRESS MVI A,80H PCHL NOTEQ: XRA A ; MIGHT AS WELL CLEAR THE ACC CMP C ; TEST FOR NON-EQUALITY? JRZ EQTST ; YES NEQTST: POP H POP D DAD S SPHL XCHG PCHL ; ; FUSS : A ROUTINE TO COMPARE TWO SETS ON THE STACK AND TEST IF THEY ARE ; NOT EQUAL. ( APOLOGIES FROM THE PROGRAMMER FOR A ROUTINE NAME THAT ; HAS ABSOLUTELY NO RELEVANCE TO WHAT IT DOES -- I RAN OUT OF ; IMAGINATION ) ; ; HL = OFFSET OF START OF SECOND SET FROM TOP OF STACK ; DE = OFFSET FROM HL OF EQUIVALENT BYTE IN;ROUTINES FOR STRING APPEND,INDEX,LENGTH AND SET LENGTH ; NAME STRFCT ENTRY L137,INDEX,LENGTH,SETLEN EXT STRERR INCLUDE DEFLT.SRC INCLUDE FCTMAC.SRC ; ;STRING APPEND ; L137: LXI H,2 DAD S MOV C,M ;MAX. LENGTH OF STRING TO APPEND INX H MOV B,M DAD B ;TOP OF STRING MOV A,M ;TEST FOR ZERO ACTUAL LENGTH OF ADD STRING CPI 0 LXI D,4 DAD D ;HIGH BYTE OF ADDR. OF TARGET STRING PUSH H JRZ ZSTR ;ZERO LENGTH, NO APPEND NEEDED MOV D,M ;DE GETS ADDRESS OF TARGET STRING DCX H V A,C ;LENGTH OF STRING TO APPEND MOV C,B ;OLD ACTUAL LENGTH MVI B,0 ORA A ;CLEAR CARRY DSBC B DCX H ;FIRST EMPTY SPACE MOV C,A ;LENGTH OF STRING TO APPEND XCHG LDDR ;TRANSFER AND DECR. ZSTR: POP H ;HIGH BYTE OF ADDR.OF STRING POP D ;RETURN ADDR INX H SPHL ;NEW STACK POINTER XCHG XRA A PCHL ;RETURN ; ;STRING INDEX ROUTINE ; INDEX: LXI H,257 DAD S XCHG ;DE<-TOP OF SECOND STRING LXI H,256 DAD D PUSH H ;HL<-TOP OF FIRST STRING LDAX D MOV C,A ;LENGTH OF SEC; B = SIZE OF SECOND SET SETDIF: MOV A,M XCHG ANA M ; TAKE OUT THE ELEMENTS OF THE SECOND SET ; THAT ARE NOT PRESENT IN THE FIRST SET XRA M ; TAKE OUT THE ELEMENTS OF THE FIRST SET ; THAT ARE ALSO IN THE SECOND SET MOV M,A DCX H DCX D XCHG DJNZ SETDIF POP H ; HL = OFFSET OF SECOND SET POP D ; DE = RETURN ADDRESS DAD S ; REMOVE SECOND SET FROM STACK SPHL XCHG ; HL = RETURN ADDRESS XRA A PCHL ; ; COMP : A ROUTINE TO COMPARE TWO SETS ON THE STACK AND SEE IF THEY ZERO THEN THE TEST IS FOR ; NON-EQUALITY AND FOR EQUALITY OTHERWISE. ON ENTRY THE HL,DE AND C ; REGISTERS SHOULD BE THE SAME AS THEY WERE UPON ENTRY INTO COMP ; AND FUSS. ; QUERY: LDAX D XRA M JRNZ NOTEQ DCX H DCX D DJNZ QUERY ; NOT ZERO -> NOT EQUAL CMP C ; IS THIS A TEST FOR EQUALITY OR NON-EQUALITY ? JRZ NEQTST ; IF ZERO THEN TEST FOR NON-EQUALITY EQTST: POP H ; HL = OFFSET OF SECOND SET POP D ; DE = RETURN ADDRESS DAD S ; REMOVE SECOND SET FROM STACK SPHL XCHG ; HL = RET FIRST BYTE ; FUSS: CALL SAVREG ; HL -> SECOND SET ; DE -> FIRST SET ; B = SIZE OF SECOND SET MOV C,A ; INDICATE THAT THIS IS A TEST FOR <> JR QUERY ; JUMP TO COMMON TEST CODE RE ; NOT EQUAL. ( APOLOGIES FROM THE PROGRAMMER FOR A ROUTINE NAME THAT ; HAS ABSOLUTELY NO RELEVANCE TO WHAT IT DOES -- I RAN OUT OF ; IMAGINATION ) ; ; HL = OFFSET OF START OF SECOND SET FROM TOP OF STACK ; DE = OFFSET FROM HL OF EQUIVALENT BYTE INMOV E,M DCX H DCX H MOV A,M ;A <- MAXIMUM LENGTH OF TARGET STRING DCX H ;POINT TO ACTUAL LENGTH OF ADD STRING DCR C ;C <- MAX LENGTH OF ADD STRING MOV B,C MOV C,M ;C <- ACTUAL LENGTH OF ADD STRING DCX H ;(HL) -> 1ST CHAR OF ADD STRING XCHG ;(HL) -> ACTUAL LENGTH OF TARGET STRING SUB C ;A <- MAXLEN(TARGET) - CURLEN( ADD ) CMP M ;WILL EVERYTHING FIT IN TARGET STRING? JC STRERR ;DOESN'T FIT. ERROR STRFIT: MOV A,C ADD M MOV B,M ;OLD ACTUAL LENGTH MOV M,A ;NEW ACTUAL LENGTH MOOND STRING MOV A,M ;COMPARE LENGTHS SUB C JRC INOFIT ;2ND STRING TOO LONG MOV B,A DCX D ;1ST CHAR OF 2ND STRING ;BEGIN SEARCH INDSCH: MVI A,1 ;A COUNTS POSITION OF 2ND STR. DCX H ;1ST LETTER OF FIRST STRING PUSH H ;SAVE BEGINNINGS OF STRINGS PUSH D INDMAY: EXAF LDAX D CMP M ;COMPARE CHARS. JRNZ INEXT ;NO MATCH EXAF CMP C ;LAST CHAR OF STRING? JRZ IFND ;YES,MATCH FOUND INR A ;NO DCX H DCX D JR INDMAY ;CHECK NEXT CHAR INEXT: XRA A CMP B ;LAST TRY? JRZ INDNON ;YES,NO MATCH DCR B ;NO,PREPARE FOR NEXT ATTEMPT POP D POP H EXAF JR INDSCH IFND: POP D ;BEGINNING OF 2ND STRING POP H ;BEGINNING OF 1ST STRING POP H ;TOP OF 1ST STRING MOV A,M ;CALC INDEX VALUE SUB C ;LENGTH OF SECOND STRING SUB B ;NUMBER OF TRIES LEFT INR A ;INDEX VALUE IN A ICLN: INX H POP D ;RETURN ADDRESS SPHL XCHG MOV E,A MVI D,0 ;DE RETURNS INDEX VALUE XRA A PCHL INDNON: EXAF POP D ;BEGINNING OF 2ND STRING POP H ;BEGINNING OF 1ST STRING INOFIT: XRA A ;RETURN ZERO ;STRING RELATIVE OPERATIONS ; NAME STRLOP ENTRY STREQL,STRNQL,STRGRT,STRGEQ,STRLSS,STRLEQ ; LTIND EQU 1 ;< INDIC. GEIND EQU 2 ;>= INDIC. EQIND EQU 3 ;= INDIC. LEIND EQU 4 ;<= INDIC. GTIND EQU 5 ;> INDIC. STREQL CALL STRCMP ;EQUAL CPI EQIND JRNZ NTTRU JR TRU STRNQL CALL STRCMP ;NOT EQUAL CPI EQIND JRZ NTTRU JR TRU STRGRT CALL STRCMP ;GREATER THAN CPI GTIND JRNZ NTTRU JR TRU STRLSS CALL STRCMP ;LESS THAN CPI LTIND JRNZ NTTRU JR TRU STRGEQ CALL STRCMP ;GREATER THAN ORS, CHECK SECOND STRING LDAX D ;ACTUAL LENGTH OF SECOND STRING CPI 0 ;ZERO LENGTH? JRZ HGRT ;FIRST NOT ZERO, SECOND IS- FIRST GREATER CMP M ;NEITHER IS ZERO LENGTH JRC DCNTR MOV B,M ;B <- SHORTER ACT. LENGTH FOR COUNTING JR CMPR DCNTR: MOV B,A CMPR: DCX H ;CHAR OF FIRST STRING DCX D ;CHAR OF SECOND STRING DCR B ;CHAR. COUNTER LDAX D CMP M ;COMPARE THEM JRC HGRT ;FIRST IS GREATER JRNZ DGRT ;SECOND IS GREATER XRA A ;CHARS. EQUAL - LAST CHAR? CMP B JRNZ CMPR ;NO, TRY NEXT CHARSPOP H JR STREQU L STRINGS JR CLNUP HGRT POP D POP H HLONG MVI A,GTIND ;FIRST IS LONGER JR CLNUP DGRT POP D POP H DLONG MVI A,LTIND ;SECOND IS LONGER CLNUP POP D ;CLEAN UP STACK POP B INX H SPHL PUSH B XCHG PCHL ;AND RETURN ST1ZER: LDAX D ;LENGTH OF SECOND STRING CPI 0 JRNZ DGRT ;SECOND STRING NOT ZERO, 2ND IS GREATER THAN 1ST POP D ;BOTH HAVE ZERO LENGTH, EQUAL ; intrinsic function for square root ; NAME SQRT ENTRY SQRT,L135 EXT FPABS INCLUDE DEFLT.SRC INCLUDE FCTMAC.SRC ; L135: ; ; (* ; * intrinsic function for square root ; *) ; function sqrt( x:real ): real; ; var j,i,k: real; ; begin FCT527 sqrt: ENTR D,2,12 ; i := 0.0; MOV H,A MOV L,A PUSH H PUSH H LXI H,3 DADD S XCHG PUSH IX POP H XCHG LXI B,4 LDDR POP H POP H ; if x < 0.0 then x := abs( x ); LXI H,-4 DADD S SPHL XCHG PUSH IX POP HINDEX VALUE POP H ;TOP OF 1ST STRING JR ICLN ; ;STRING LENGTH ROUTINE ; LENGTH: ENTR D,2,0 LXI H,255+8 PUSH X POP D DAD D ;HL<-ACTUAL LENGTH BYTE MOV A,M MOV 2(X),A ;RETURNS LENGTH EXIT D,256 ; ; ;SET STRING LENGTH ; SETLEN: ENTR D,2,0 LXI H,11 PUSH X POP D DAD D MOV H,11(X) ;HL <- ACTUAL LENGTH BYTE MOV L,10(X) MOV C,8(X) ;NEW LENGTH MOV M,C ;ASSIGN NEW LENGTH EXIT D,4  EQUAL CPI GEIND JRC NTTRU JR TRU STRLEQ CALL STRCMP ;LESS THAN OR EQUAL CPI LEIND JRNC NTTRU JR TRU TRU: XRA A STC RET NTTRU XRA A RET STRCMP: LXI H,3 DAD S ;SKIP 2 RETURN ADDRESSES MVI D,0 MOV E,C ;SIZE OF SECOND STRING DAD D ;TOP OF SECOND STRING PUSH H MOV E,B ;SIZE OF FIRST STRING DAD D ;TOP OF FIRST STRING POP D PUSH H ;HL <- TOP OF FIRST STRING PUSH D ;DE <- TOP OF SECOND STRING MOV A,M ;ACTUAL LENGTH OF FIRST STRING CPI 0 ;ZERO LENGTH? JRZ ST1ZER ;YE POP D ;LAST CHARS EQUAL POP H LDAX D ;WHICH IS LONGER STRING? CMP M JRC HLONG JRNZ DLONG STREQU: MVI A,EQIND ;EQUAL STRINGS JR CLNUP HGRT POP D POP H HLONG MVI A,GTIND ;FIRST IS LONGER JR CLNUP DGRT POP D POP H DLONG MVI A,LTIND ;SECOND IS LONGER CLNUP POP D ;CLEAN UP STACK POP B INX H SPHL PUSH B XCHG PCHL ;AND RETURN ST1ZER: LDAX D ;LENGTH OF SECOND STRING CPI 0 JRNZ DGRT ;SECOND STRING NOT ZERO, 2ND IS GREATER THAN 1ST POP D ;BOTH HAVE ZERO LENGTH, EQUAL LXI B,8 DADD B LXI B,4 LDIR MOV H,A MOV L,A PUSH H PUSH H LESS D,-4 JNC FCT535 LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR CALL FPABS LXI H,3 DADD S XCHG PUSH IX POP H LXI B,11 DADD B XCHG LXI B,4 LDDR POP H POP H FCT535 ; j := x / 2.0; LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR dcx d xchg ;decrement exponent by 1 dcr m XCHG PUSH IX POP H LXI B,-4 DADD B XCHG LXI B,4 LDDR POP H POP H ; if x <> 0.0 then repeat LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR MOV H,A MOV L,A PUSH H PUSH H NEQL D,-4 JNC FCT561 ; k := i; FCT569 LXI H,-4 DADD S SPHL XCHG PUSH IX POP H DCX H DCX H DCX H LXI B,4 LDIR LXI H,3 DADD S XCHG PUSH IX POP H LXI B,-8 DADD B XCHG LXI B,4 LDDR POP H POP H ; i := j; LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LH LXI B,-4 DADD B XCHG LXI B,4 LDDR POP H POP H ; until (j = i) or (j = k); LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-7 DADD B LXI B,4 LDIR LXI H,-4 DADD S SPHL XCHG PUSH IX POP H DCX H DCX H DCX H LXI B,4 LDIR EQUL D,-4 JC FCT595 LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-7 DADD B LXI B,4 LDIR LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-11 DADD B LXI B,4 LDIR EQUL D,-4 JNC FCT569 FCT568CALL FADD IF F JC FLTERR ENDIF ELSE IF 'Q'-'C' DAD Q D ELSE IF M XRA A DADC H JV MLTERR ELSE DAD H ENDIF ENDIF ENDIF ENDMAC ENTR: MACRO Q,LVL,VSIZ IF LVL-1 MVI B,LVL LXI D,1-VSIZ IF S CALL ENTRSC ELSE CALL ENTER ENDIF ELSE LXI H,1-VSIZ DAD S SPHL CHAIN$: EXX LXI H,LAST EXX LXI H,-MARGIN DAD S LXI D,LAST DSUB D JC STKERR ENDIF ENDMAC EXIT: MACRO Q,SSIZ LXI H,SSIZ+8 JMP EXITF ENDMAC L98: DAD D DAD D MOV E,M INX H MSLE ENDIF ELSE CALL ILE ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STRLEQ ENDIF ENDMAC LESS: MACRO Q,SIZE1,SIZE2 IF 'Q'-'S' IF SIZE1 IF SIZE1&8000H CALL FPLT ELSE LXI B,SIZE1 CALL SLT ENDIF ELSE CALL ILT ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STRLSS ENDIF ENDMAC GE: MACRO Q,SIZE1,SIZE2 IF 'Q'-'S' IF SIZE1 IF SIZE1&8000H CALL FPGTE ELSE LXI B,SIZE1 CALL SGE ENDIF ELSE CALL IGE ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STRGEQ ENDIF ENDML IMOD IF M JC DIVERR ENDIF ENDMAC NEGT: MACRO REG IF 'REG'-'H' IF 'REG'-'D' POP H POP D MVI A,80H XRA E MOV E,A PUSH D PUSH H ELSE MOV A,E CMA MOV E,A MOV A,REG CMA MOV REG,A INX REG ENDIF ELSE MOV A,L CMA MOV L,A MOV A,REG CMA MOV REG,A INX REG ENDIF XRA A ENDMAC CTRL: MACRO IF C CALL CSTS JRZ $+16 CALL CI CPI 'C'&3FH JZ ERROR MVI C,7 CALL CO XRA A ENDIF ENDMAC RCHK: MACRO REG,LBND,HBND IF R LXI B,LBND IF 'REGXI B,-7 DADD B LXI B,4 LDIR LXI H,3 DADD S XCHG PUSH IX POP H XCHG LXI B,4 LDDR POP H POP H ; j := (x / j + j )/2.0; LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-7 DADD B LXI B,4 LDIR FDVD D,-4 LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-7 DADD B LXI B,4 LDIR DADD D,-4 lxi h,3 dad s dcr m ;decrement exponent by 1 XCHG PUSH IX POP FCT595 EQU FCT568 FCT561 ; sqrt := j ; end; LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-7 DADD B LXI B,4 LDIR dcx d PUSH IX POP H LXI B,15 DADD B XCHG LXI B,4 LDDR EXIT D,4 ; X H LXI B,4 LDIR EQUL D,-4 JC FCT595 LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-7 DADD B LXI B,4 LDIR LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-11 DADD B LXI B,4 LDIR EQUL D,-4 JNC FCT569 FCT568OV D,M XCHG PCHL EQUL: MACRO Q,SIZE1,SIZE2 IF 'Q'-'S' IF SIZE1 IF SIZE1&8000H CALL FPEQ ELSE LXI B,SIZE1 CALL SEQUL ENDIF ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STREQL ENDIF ENDMAC NEQL: MACRO Q,SIZE1,SIZE2 IF 'Q'-'S' IF SIZE1 IF SIZE1&8000H CALL FPNEQ ELSE LXI B,SIZE1 CALL SNE ENDIF ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STRNQL ENDIF ENDMAC LE: MACRO Q,SIZE1,SIZE2 IF 'Q'-'S' IF SIZE1 IF SIZE1&8000H CALL FPLTE ELSE LXI B,SIZE1 CALL AC GRET: MACRO Q,SIZE1,SIZE2 IF 'Q'-'S' IF SIZE1 IF SIZE1&8000H CALL FPGT ELSE LXI B,SIZE1 CALL SGT ENDIF ELSE CALL IGT ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STRGRT ENDIF ENDMAC FDVD: MACRO Q,SIZE CALL FDIVD IF F JC DIVERR ENDIF ENDMAC MULT: MACRO Q,SIZE IF 0!SIZE&8000H CALL FMULT IF F JC MLTERR ENDIF ELSE IF M CALL IMULT ELSE CALL QMULT ENDIF ENDIF ENDMAC DIVD: MACRO CALL IDIVD IF M&D JC DIVERR ENDIF ENDMAC MMOD: MACRO CAL'-'H' IF 'REG'-'S' PUSH H LXI H,HBND CALL CHKDE POP H ELSE MVI A,LBND CMP M JC STRERR XRA A ENDIF ELSE PUSH D LXI D,HBND CALL CHKHL POP D ENDIF ENDIF ENDMAC STMT: MACRO Q,NUMBER IF T+E VALID SET 0FFFFH EXX LXI B,NUMBER IF T IF 'M'-'Q' CALL PSTAT ENDIF ENDIF EXX ELSE IF VALID EXX MOV B,A MOV C,A EXX VALID SET 00000H ENDIF ENDIF ENDMAC GLBP MACRO Q,OFFSET,SIZE PUSH Y POP B DAD B MOV B,M DCX H MOV L,M MOV H,B LXI B,OFFSET DAD B IF SIZE-1 MOV B,M DCX H MOV L,M MOV H,B ELSE MOV L,M MOV H,A ENDIF ENDMAC IF NOT COMPILER STRERR: LXI H,STRMSG JR PERROR HPERR: LXI H,STKMSG JR PERROR REFERR: LXI H,REFMSG JR PERROR RNGERR: LXI H,RNGMSG JR PERROR ENDIF FLTERR: LXI H,FLTMSG JR PERROR STKERR: LXI H,STKMSG JR PERROR DIVERR: LXI H,OUMSG JR PERROR MLTERR LXI H,MLTMSG PERROR: CALL TXTYP JMP ERROR IF NOT COMPILER STRMSG DB 'String too lon','g'+80H REFMSG DB 'Call by reference precis SPHL MVI B,OFF2 CSETCL SET $ MOV M,A INX H DJNZ CSETCL ENDIF ENDMAC UNIN: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL UNION ENDMAC MEMB: MACRO Q,OFFSET,OFF2 LXI D,OFF2 LXI H,OFFSET CALL INN ENDMAC INCL: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL LTEQ ENDMAC SBST: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL GTEQ ENDMAC INTR: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL INSECT ENDMAC DIFF: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI fxdcvt else call fout endif else call cvtflt endif else xchg call cvtflt endif else pop b pop d pop h push d push b call cvtflt xcfp endif else pop h call cvtflt endif else lxi h,value call cvtflt endif endmac dsb1 macro reg xra a dsbc reg d endmac cmpi macro q,value cpi value endmac svln: macro mov a,m exx mov e,a xra a exx dcx h endmac gtln: macro reg,size exx mov a,e exx mov c,a xra a mov b,a lxi h,size ;MULTIPLY ROUTINES ; NAME MULT ENTRY QMULT,IMULT EXT MLTERR ; ; ;MULTIPLY REQUIRES THE A REGISTER TO BE 0 ;THE MULTIPLIER MUST BE IN DE AND THE MULTIPLICAND MUST BE IN HL ;FAST MULTIPLY -- NO ERROR CHECKING QMULT: CMP D ;OPTIMIZATION SECTION... JRZ OPT ;...CHECK FOR A ZERO HIGH BYTE MVI B,17 ;17 FOR A LONG MULTIPLY CMP H JRNZ NOOPT ;CAN'T FIND ONE XCHG OPT: MVI B,9 ;ONLY DO NINE SHIFTS MOV D,E NOOPT: MOV A,B ;NUMBER OF SHIFTS MOV B,H ;COPY HL -> BC MOV C,L LXI H,0 ;CLEAR RES ;IS THE MULTIPLICAND 0? CAND0: XRA A CMP H JRNZ SETUP CMP L JRNZ OP2ONE ;MULTIPLICAND IS ZERO POP PSW ;SIGN XRA A RET ;IS MULTIPLICAND 1 OR -1 OP2ONE: DCR L INX H JRNZ SETUP ;IT'S A ONE, WHAT'S THE SIGN? POP PSW ;SIGN OF RESULT XCHG XRA H MOV A,D ;CLEAR ACC RP ;SIGN STAYS THE SAME ;CHANGE THE SIGN JR CSIGN SETUP: MOV B,D MOV C,E XCHG MOV H,A MOV L,A ;MULTIPLY LOOP MCONT: SRAR B ;SHIFT MULTIPLICAND RRAR C JRNC MTEST DAD D BIT 7,H JNZ MLTERion erro','r'+80H RNGMSG DB 'Index or value out of rang','e'+80H ENDIF OUMSG DB 'Attempted divide by zer','o'+80H MLTMSG IF COMPILER DB 'Too many error','s'+80H ELSE DB 'Multiply overflo','w'+80H ENDIF STKMSG IF COMPILER DB 'Program too comple','x'+80H ELSE DB 'Stack overflo','w'+80H ENDIF FLTMSG DB 'Floating point overflow/underflo','w'+80H STMTMSG DB ' -- statement',' '+80H CRLF DB CR,LF+80H CSET: MACRO Q,OFF1,OFF2 IF OFF1 LXI H,OFF1 CALL CONSET ELSE LXI H,-OFF2 DAD SD,OFFSET CALL ORGAN ENDMAC MTCH: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL COMP ENDMAC NOMT: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL FUSS ENDMAC xcfp: macro pop d pop h pop b xthl push d push h push b endmac cvtf: macro where,value if 'A'-'where' if 'B'-'where' if 'C'-'where' if 'D'-'where' if 'H'-'where' if value-4 mov a,l pop b pop d pop h mov h,a push h push d push b xra a call fout lxi h,13 dad s push h call dsub b dad s mvi m,cr endmac h push d push b call cvtflt xcfp endif else pop h call cvtflt endif else lxi h,value call cvtflt endif endmac dsb1 macro reg xra a dsbc reg d endmac cmpi macro q,value cpi value endmac svln: macro mov a,m exx mov e,a xra a exx dcx h endmac gtln: macro reg,size exx mov a,e exx mov c,a xra a mov b,a lxi h,size ULT MLOOP: DCR A ;CHECK SHIFT COUNTER RZ DAD H ;SHIFT PARTIAL RESULT SLAR E ;SHIFT MULTIPLIER RLAR D JRNC MLOOP ;NEXT SHIFT DAD B ;ADD IN MULTIPLICAND JR MLOOP ; ; IMULT: MOV A,H ;SAVE SIGN OF RESULT XRA D PUSH PSW ;MAKE BOTH OPERANDS POSITIVE BIT 7,D JRZ CANDP ;MULTIPLICAND POSITIVE MOV A,D CMA MOV D,A MOV A,E CMA MOV E,A ;MAKE POSITIVE INX D CANDP: BIT 7,H JRZ CAND0 ;MULTIPLIER POSITIVE MOV A,H CMA MOV H,A MOV A,L CMA MOV L,A ;MAKE POSITIVE INX H R ;JUMP TO OVERFLOW ERROR ROUTINE MTEST: MOV A,B ORA C JRZ MLTDON XCHG DADC H XCHG JNV MCONT JMP MLTERR ;DONE MULTIPLY MLTDON: POP PSW ;SIGN OF RESULT MOV A,C ;CLEAR ACC RP CSIGN: XCHG XRA A MOV H,A MOV L,A DSBC D RET  XCHG MOV H,A MOV L,A ;MULTIPLY LOOP MCONT: SRAR B ;SHIFT MULTIPLICAND RRAR C JRNC MTEST DAD D BIT 7,H JNZ MLTER;INPUT ROUTINES ; NAME INPT ENTRY READ,READLN,INPUT,ERRTYP,L110,L112 EXT EOF,EOLN,ERROR,PERROR,LOOK,FLTIN,TIN,TXTIN EXT TXTYP,BYTIN,STRERR,STRMSG,CO INCLUDE DEFLT.SRC ; IF COMPILER ;Compiler never calls RBLOCK RBLOCK: ELSE EXT RBLOCK ENDIF ; ;READLN INPUTS DATA FROM THE FILE INTO THE LISTED ;PARAMETERS. THEN ADVANCES THE POINTER IN THE FILE TO ;THE BEGINNING OF THE NEXT LINE IN THE FILE AND SETS THE ;END OF LINE FLAG. IF THE END OF FILE IS REACHED BEFORE ;THE END OF THE PARAMETE CALL INPUT ;NO....SKIP ANOTHER CHARACTER JR SKCR ONEMOR: MOV A,H ;CHECK FOR A CONSOLE FILE ORA A ;IF SO THEN SKIP THE EXTRA READ RZ CALL EOF CNC INPUT ;SKIP THE SPACE XRA A ;CLEAR ACC RET ;INPUT IS CALLED WITH THE PASCAL FILE BUFFER ADDRESS IN HL ;IT RETURNS THE NEXT READ BYTE IN REGISTER A. ;INPUT CAN CHANGE ONLY THE A REGISTER AND C REGISTER INPUT: MOV A,H ORA A JRNZ NCONS ;ZERO ADDRESS IN HL MEANS INPUT IS FROM THE CONSOLE WITH NO LOOK AHEAD. CALL TIN JM LSTCR MVIF MOV D,H MOV E,L BIT 0,M ;TEST EOLN BIT JRZ NCONS1 ;NOT EOLN. GET NEXT CHAR. ;RETURN A SPACE FOR A READ WHEN EOLN IS TRUE INX H INX H INX H ;FCB CALL BYTIN JRC GEOF ;EOF? CPI EOFMRK ;TEST FOR END OF FILE MARK JRZ GEOF CALL BYTIN JRC GEOF ;EOF? CPI EOFMRK JRZ GEOF DCX H DCX H DCX H CPI CR ;CHECK FOR ANOTHER EOLN JRZ LOTS RES 0,M ;RESET EOLN BIT LOTS: INX H MOV M,A ;NEW CHAR IN READ AHEAD BYTE DCX H MVI A,' ' ;RETURN A SPACE CMP A ;SET FLAGS POP D POP MOV A,C DCX H BSET 0,M ;SET EOLN BSET 1,M ;SET EOF JR NTXIT ;READ BEYOND END OF FILE, FATAL ERROR RBEOF: LXI H,EOFMES JMP PERROR EOFMES: IF NOT COMPILER DB 'Read beyond EO','F'+80H ELSE DB 'premature EO','F'+80H ENDIF ;PROCESS THE PARAMETER LIST, THE ODD WORDS SPECIFY THE TYPE ;1-BOOLEAN, 2-INTEGER, 3-CHARACTER,4-SCALAR, 5-NON-TEXT, ;6-FLOATING POINT,7-STRING. ;THE EVEN WORDS ARE THE ADDRESS OF THE PARAMETER. ;FILE BUFFER ADDRESS ALREADY IN HL RSSLOC EQU 5 ;SKIP RETUR CMP -2(X) ;IDENTIFY FILE TYPE JRNZ BEGIN ;CONSOLE FILE...GO PROCESS PARAMETER LIST MOV H,0(X) ;FILE BUFFER ADDRESS MOV L,-1(X) CMP B ;SEE IF THIS IS A READLN JRZ NTRDLN ;NO, NOT A READLN BSET 5,M ;SET BIT TO SAY SO NTRDLN: DCX D ;FILE INFO. TAKES 8 BYTES,OR TWO PARAMATERS DCX D LXI B,-8 DADX B ;FIRST PARAMETER PUSH D ;SAVE PARAMETER COUNT ON STACK PUSH H ;SAVE FBA MOV A,4(X) ;RECORD NUMBER HIGH BYTE MOV E,3(X) ;RECORD NUMBER LOW BYTE ORA E ;DIRECT ACCESS? JRZ SEQRD ;NO, SEQUR LIST A FATAL ERROR IS DETECTED ;AND EXECUTION IS TERMINATED. L112: READ: CALL READIT ;READ WHAT'S IN THE LIST RET ;AND RETURN L110: READLN: CMP C ;ARE THERE ANY PARAMETERS? JRNZ REDLN2 ;YES PROCESS THE READLN CMP B JRZ SKCR ;NO PARAMETERS REDLN2: INR A ;INDICATE THAT THIS IS A READLN CALL READIT ;IF WE'RE AT THE END OF A LINE THEN DON'T SCAN AT ALL ;OTHERWISE, SEARCH FOR THE NEXT CARRIAGE RETURN, LINE FEED SKCR: CALL EOLN ;CHECK FOR EOL JRC ONEMOR ;ONE MORE CALL TO INPUT L,0 RET ;CARRIAGE RETURN ENCOUNTERED CHECK FOR END OF INPUT ITEM LSTCR: CPI 'C'&3FH ;CHECK FOR CTRL-C JZ ERROR DCR L ;CHECK FOR FIRST BYTE OF ITEM CZ TXTIN ;GET MORE IF THIS IS THE FIRST CALL CALL TIN ;GET FIRST CHARACTER AND RETURN TO CALLER CPI 'C'&3FH ;CHECK FOR CTRL-C JZ ERROR CPI LF RNZ MVI A,CR RET ;DON'T RETURN A LINE FEED, USE A CR INSTEAD ;NON-ZERO ADDRESS IN HL MEANS DISK FILE INPUT NCONS: PUSH B PUSH D XRA A BIT 1,M ;CHECK FOR READ BEYOND END OF FILE JNZ RBEOB RET ;DONE NCONS1: INX H INX H INX H CALL BYTIN ;GET NEXT CHARACTER JRC GEOF CPI EOFMRK ; Test for end of file mark. JRZ GEOF MOV B,A DCX H ;POINT TO FLAG BYTE DCX H DCX H RES 0,M ;RESET EOLN CPI CR JRNZ FIN ;NEXT CHARACTER A CR BSET 0,M ;SET EOLN TRUE FIN: RES 1,M ;RESET EOF FLAG INX H MOV C,M ;READ LOOK AHEAD MOV M,B DCX H MOV A,C NTXIT: POP D POP B CPI ' ' ;SET FLAGS LIKE TIN RET ;END OF FILE GEOF: DCX H DCX H MOV C,M ;READ LOOK AHEAD MOV M,AN ADDRESSES READIT: PUSH X LXI X,RSSLOC MOV D,B ;NUMBER OF PARMS MOV E,C DADX SP ;EACH PARAMETER IS 4 BYTES LONG DADX D ;SET X TO START OF PARAMETER LIST DADX D ;SET X TO START OF PARAMETER DADX D ;SET X TO START OF PARAMETER DADX D ;SET X TO START OF PARAMETER PUSH X ;NEW STACK POINTER ;IX POINTS TO NEXT BYTE ON PARAMETER LIST ;DE HOLDS THE NUMBER OF PARAMATERS IN THE PARAMETER LIST MOV B,A ;SAVE READ/READLN INDICATOR XRA A LXI H,0 ;ASSUME CONSOLE FILE UNTIL PROVEN OTHERWISE ENTIAL READ RRPREP: BSET 4,M ;RANDOMLY ACCESSED MOV D,4(X) ;RECORD NUMBER HIGH BYTE MOV H,2(X) ;RECORD SIZE HIGH BYTE MOV L,1(X) ;RECORD SIZE LOW BYTE POP B ;FILE BUFFER ADDRESS PUSH B XRA A ;ZERO IN A REG TO RBLOCK INDICATES READ CALL RBLOCK ;PERFORM DIRECT READ RRCLN: POP H ;FBA POP D ;PARAMETER COUNT JR FILTST SEQRD: POP H ;FBA PUSH H BIT 3,M ;WAS PREVIOUS OPERATION A WRITE JRNZ RRPREP ;YES, MUST FLUSH BUFFER POP H POP D ;PARAM. COUNT FILTST: XRA A ;NO,SEQUENTIAL READ CMP 5(X) ;TEXT OR NON-TEXT JNZ NTXT ;NON-TEXT FILE ;TEST FOR THE END OF LIST BEGIN: MOV A,D ORA E JRZ THREW ;ZERO COUNT ;GET PARAMETER TYPE NEWPAR: XRA A CMP H JRNZ NEWP1 ;CHECK FOR CONSOLE FILE INR L ;INDICATE FIRST CHARACTER NEWP1: MOV B,-2(X) DCR B CZ BOOLE ;BOOLEAN DCR B CZ RINTEG ;INTEGER DCR B CZ CHARA ;CHARACTER DCR B CZ ENUM ;SYMBOLIC READ OF AN ENUMERATION TYPE DCR B DCR B IF NOT COMPILER ;Compiler doesn't need this CZ FLTIN ;GET A FLOATING POINT NUMBERE FILE ;AND MOVES IT TO THE APPROPRIATE LOCATION. CHARA: MOV B,-3(X) ;GET LENGTH PUSH H ;FILE BUFFER ADDRESS MOV H,0(X) ;GET ADDRESS OF VARIABLE MOV L,-1(X) ;INPUT THE CHARACTERS XTHL CALL EOF JC RBEOF ;READING A NEW PARAM. WITH EOF TRUE. FATAL ERROR MOV A,H ;CHECK FOR A CONSOLE FILE ORA A JRZ CHST ;ALWAYS CALL INPUT AT LEAST ONCE FOR THE CONSOLE CALL EOLN JRNC CHST BIT 5,M ;TEST FOR READLN CALL JRZ DOSKIP ;NOT A READLN SO DON'T CHECK PARM COUNT DCX D ;CHECK FOR LAST PARM MFER ADDRESS RET NLIST ;BOOLEAN READS THE CHARACTER STRING TRUE OR ;FALSE FROM THE INPUT FILE AND TRANSFORMS T TO 1 ;AND F TO 0 AND STORES IT IN THE APPROPRIATE PLACE. BOOLE: IF NOT COMPILER ;DON'T USE WITH COMPILER CALL INPUT CPI 'T' JRZ TRUIN ;TRUE CPI 't' JRZ TRUIN ;TRUE CPI 'F' ;FALSE JRZ FALIN CPI 'f' JRZ FALIN ;FALSE CPI ' ' ;A BLANK JRZ BOOLE JMP ERRTYP ;TYPE ERROR ;TRUE, FIND THE E OR e OR ' ' OR CR OR LF OR SKIP AT MOST THE NEXT ;THREE CHARACTERS. TRUIN:XT CHARACTER CPI 'E' RZ ;E FOUND CPI 'e' RZ ;e FOUND CPI ' ' RZ ;BLANK FOUND CPI ',' ;COMMA FOUND RZ CALL EOF ;RECOGNIZE END OF FILE AS A TERMINATER RC DJNZ SKIM RET ENDIF ;ENUM READS AN IDENTIFIER FROM THE INPUT STREAM AND ;ATTEMPTS TO MAKE A SYMBOLIC MATCH AGAINST THE LIST OF ;POSSIBLE IDENTIFIERS FOR THIS ENUMERATION TYPE. IF A ;MATCH IS MADE THEN THE TABLE POSITION OF THE MATCH IS ;THE ORDINAL NUMBER OF THE VARIABLE IN QUESTION. ENUM: IF NOT COMPILER DCX D ;DEDCH CPI '#' ;CHECK FOR ALLOWED CHAR JRZ OK CPI '_' JRZ OK CPI '$' JRZ OK CPI 'z'+1 ;CHECK FOR LOWER CASE LETTER JRC LOWCHK UPCASE: CPI 'Z'+1 ;CHECK FOR UPPER CASE LETTER JRC CAPCHK DGIT: CPI '9'+1 ;CHECK FOR DIGITS JRC DGTCHK JMP SCERR ;CHAR NOT ALLOWED LOWCHK: CPI 'a' ;CHECK FOR LOWER CASE LETTER JRC UPCASE ;NOT LOWER CASE ANI 0DFH ;CONVERT TO UPPER CASE JR OK CAPCHK: CPI 'A' ;CHECK FOR UPPER CASE LETTER JRC DGIT ;NOT UPPER CASE JR OK DGTCHK: CPI '0' ;CHECK FOR DIGIT ENDIF DCR B CZ STREAD ;STRING DCX D ;COUNTER LXI B,-4 ;POINTER DADX B JR BEGIN ;REMOVE PARAMETER LIST FROM STACK, RESTORE X, AND RETURN THREW: XCHG POP H ;POP NEW STACK POINTER MOV M,D ;SAVE BUFFER ADDRESS DCX H MOV M,E POP X ;RESTORE X POP D ;SECOND RETURN ADDRESS POP B ;FIRST RETURN ADDRESS SPHL ;NEW STACK POINTER POP H ;FILE BUFFER ADDRESS PUSH B ;FIRST RETURN ADDRESS PUSH D ;SECOND RETURN ADDRESS RET ;RETURN ;CHARACTER READS THE NEXT CHARACTER IN FROM THOV A,E ORA D INX D ;RESTORE COUNT JRZ FILLIN ;LAST PARM OF A READLN SO DON'T SKIP DOSKIP: CALL INPUT JR FILLIN STRIN: XTHL ;SWITCH VARIABLE ADDRESS WITH CALL EOF ;RECOGNIZE END OF FILE AS A TERMINATER JRC FILLIN CALL EOLN JRC FILLIN CHST: CALL INPUT XTHL ;FILE BUFFER ADDRESS MOV M,A ;STORE CHARACTER DCX H DJNZ STRIN POP H ;FILE BUFFER ADDRESS RET ;FILLIN PADS STRING OUT TO REQUIRED LENGTH WITH BLANKS FILLIN: XTHL FILLN1: MVI M,' ' DCX H DJNZ FILLN1 POP H ;FILE BUF MVI B,3 CALL SKIM MVI B,1 ;VARIABLE GETS ONE JMPR STOBOO ;FALSE, FIND THE E,e,' ',OR SKIP AT MOST FOUR CHARACTERS. FALIN: MVI B,4 CALL SKIM MVI B,0 ;VARIABLE GETS 0 ;GET VARIABLE LOCATION STOBOO: PUSH H ;SAVE BUFFER ADDRESS MOV H,0(X) MOV L,-1(X) ;STORE BOOLEAN VALUE MOV M,B XRA A ;CLEAR A MOV B,A ;CLEAR B POP H ;RESTORE BUFFER ADDRESS RET ;SKIM SCANS THE NEXT N CHARACTERS (N IN B) OF THE INPUT ;STREAM AND STOPS AFTER THE FIRST E OR ' '. SKIM: CALL INPUT ;GET THE NECR PARAM COUNTER PUSH D ;SAVE PARAM COUNTER PUSH H ;SAVE FILE BUFFER ADDR PUSH X ;SAVE VAR ADDR ENUM1: XRA A MOV C,A MOV B,A JR CHK STR: CALL EOF JRC ENDSTR CALL EOLN JRC ENDSTR CHK: XRA A CMP C ;FIRST CHAR ? JRZ GETCHR ;YES CALL LOOK ;NO,LOOK AT NEXT CHAR JMP SEPCHK GETCHR: CALL INPUT ;GET NEXT CHAR SEPCHK: CPI ' ' ;CHECK FOR SEPARATORS JRZ LEADCH CPI CR ;CARR. RET. JRZ LEADCH CPI 9 ;TAB JRZ LEADCH CPI LF ;LINE FEED JRZ LEADCH CPI 12 ;FORM FEED JRZ LEA JC SCERR ;CHAR NOT ALLOWED MOV D,A ;SAVE DIGIT XRA A CMP C ;FIRST CHAR? JNC SCERR ;DIGIT CAN'T BE FIRST CHAR MOV A,D OK: MOV D,A MVI A,8 CMP C ;IS VAR 8 CHARS LONG? JRZ VARFUL ;YES.DON'T PUSH XRA A CMP C ;FIRST CHAR? JRZ NOINPT ;YES.CHAR ALREADY INPUT CALL INPUT NOINPT: PUSH D ;SAVE CHAR INX SP ;ONLY ADDING ONE BYTE INR C ;COUNT CHARS IN STRING JR STR VARFUL: CALL INPUT JMP STR LEADCH: XRA A CMP C ;ANY CHARS IN STRING YET? JZ GETCHR ;NO. GET NEXT CHAR ENDSTR: MOV H,-4(X) ;GET TABLE ADDR TOP MOV L,-5(X) PUSH H ;SAVE TABLE ADDR MOV A,-7(X) ;GET SIZE OF TABLE LXI X,1 DADX S ;X GETS TOP OF STK DADX B MOV B,A ;B GETS MAX SIZE OF TABLE XRA A MOV E,A CPAR: INR E ;COUNT CURRENT CHAR MOV A,0(X) CMP M ;ARE CHARS THE SAME? JRZ TSTLNG ;LETTERS EQUAL.CHECK LENGTH XRA A ;LETTERS NOT EQUAL SUB B ;CHK IF LAST TABLE ENTRY JRZ NOMTCH ;LAST ENTRY.NO MATCH NXTSTR DCR B ;DEC STRINGS LEFT IN TABLE XRA A MOV D,A DCR E DADX D ;BACK TO FIRST CHAR IN ST ;GET TABLE ADDR DAD S SPHL ;VAR OFF STACK POP X ;GET VAR ADDR MOV A,-7(X) ;GET MAX TABLE INDEX VALUE SUB B ;SUB NUMBER OF TABLE ENTRIES NOT CHECKED MOV H,0(X) ;HL GETS VAR ADDR MOV L,-1(X) MOV M,A ;STORE TABLE INDEX VALUE POP H ;RESTORE FILE BUFFER ADDR POP D ;RESTORE PARA COUNTER LXI B,-4 DADX B ;DECR IX FOUR BYTES RET SCERR: LXI H,0 JR NM1 NOMTCH: LXI H,2 ;SKIP TABLE ADDRESS ON STACK NM1: DAD SP XRA A MOV B,A DAD B ;BC HAS # OF CHARS. PUT ON STACK SPHL ;SP -> LOW <- ADDRESS OF STRING MOV L,-1(X) MOV B,-3(X) ;MAX LENGTH DCX H ;FIRST CHAR. SPACE XTHL CALL EOF JC RBEOF ;READING NEW PARAM. WITH EOF TRUE ;READ BEYOND EOF ERROR MOV A,H ORA A ;CHECK FOR CONSOLE JRZ STRNPT ;READ AT LEAST ONE CHAR FROM CONSOLE CALL EOLN JRNC STRNPT STRG1: XTHL INX H ;LENGTH BYTE OF STRING XRA A MOV M,A ;ZERO LENGTH POP H RET STRG: XTHL CALL EOF ;CHECK FOR EOF JRC NDSTR ;END OF STRING CALL EOLN ;CHECK FOR EOLN JRC NDSTR STRNPT: CALL INPUT ;GALL CO ;CARRIAGE RETURN LXI H,REPROM ;'error in input, try again' CALL TXTYP ;PRINT MESSAGE POP H STRER1: CALL TIN ;FLUSH BUFFER CALL EOLN ;UNTIL EOLN JRNC STRER1 CALL TXTIN ;GET NEW INPUT FROM CONSOLE JMP STREAD ;AND READ IT NDSTR: XTHL XRA A MOV B,A DAD B ;BEGINNING OF STRING INX H MOV M,C ;SAVE ACTUAL LENGTH POP H ;FBA RET ENDIF ; ;RINTEG GETS THE INTEGER FROM THE INPUT FILE AND STORES IT RINTEG: IF NOT COMPILER ;DON'T USE WITH COMPILER MOV B,-3(X) DCR B JRNZHE BUFFER ADDRESS XRA A ;0 A MOV B,A ;0 B RET ;INT2 CONVERTS A CHARACTER STRING TO A DOUBLE ;BYTE INTEGER IN THE RANGE FROM 32,767 TO -32768. ;IT PRODUCES AN ERROR MESSAGE. INT2: CALL CONV ;MOVE NUMBER TO MEMORY, CONV CATCHES THE 15 BIT OVERFLOWS. PUSH H ;SAVE BUFFER ADDRESS MOV H,0(X) ;GET PARAMETER ADDRESS MOV L,-1(X) MOV M,B ;HI BYTE DCX H MOV M,C ;LOW BYTE POP H XRA A MOV B,A RET ;CONVERT READS IN THE DIGITS, AND CONVERTS THEM TO ;A 15 BIT NUMBER IN THE BC REGISTK MVI A,8 SUB E MOV E,A DAD D ;HL GETS FIRST CHAR OF NXT TABLE ENTRY XRA A MOV E,A ;CHAR COUNT SET TO ZERO JR CPAR TSTLNG XRA A MOV A,E CMP C ;TEST IF LAST CHAR OF STR JRZ MAYMAT DCX X ;NOT LAST CHAR INX H ;GET NXT CHAR IN TABLE JR CPAR MAYMAT XRA A MVI A,8 CMP E ;CHK IF 8TH CHAR JRZ MATCH ;MATCH FOUND INX H ;GET NXT CHAR IN TABLE XRA A MVI A,' ' CMP M DCX H ;A MATCH JRNZ NXTSTR ;NO MATCH GET NXT STR MATCH XRA A MOV H,A ;GET VAR OFF STACK MOV L,E POP DBYTE OF VARIABLE ADDR POP X ;VAR. ADDR. POP H ;FBA XRA A CMP H ;CONSOLE FILE? JNZ ERRTYP ;NO, TERMINATE PUSH H ;YES,FBA BACK ON STACK LXI H,REPROM CALL TXTYP ;REPROMPT NM2: CALL TIN ;CLEAR INPUT BUFFER CPI CR JRNZ NM2 POP H ;RESET HL AND FIX UP STACK PUSH H PUSH X JMP ENUM1 JMP ERRTYP ;SCALAR ERROR ENDIF ; ;STREAD READS A STRING OF CHARACTERS ; STREAD: XRA A IF NOT COMPILER ;Compiler doesn't need this MOV C,A ;ZERO CHARACTER COUNTER PUSH H ;FBA MOV H,0(X) ;HLET CHARACTER CPI CR ;CARRIAGE RETURN? JRZ NDSTR CPI LF ;LINE FEED? JRZ NDSTR CPI EOFMRK JRZ NDSTR ;END OF FILE? XTHL INR C ;INCREMENT ACTUAL LENGTH EXAF MOV A,B ;MAXIMUM LENGTH CMP C ;CHECK FOR STRING OVERFLOW JRC STRER ;OVERFLOW EXAF MOV M,A ;STORE CHAR. DCX H JR STRG ;GET NEXT CHAR STRER: POP H ;FBA XRA A CMP H ;CONSOLE FILE? JNZ STRERR ;NO PUSH H ;YES, TYPE ERROR MESSAGE AND TRY AGAIN LXI H,STRMSG ;'string too long' CALL TXTYP ;PRINT MESSAGE MVI C,20H C INT2 ;DOUBLE BYTE INTEGER ; ;INT1 CONVERTS A CHARACTER STRING TO A SINGLE BYTE ;BYTE INTEGER IN THE RANGE FROM 0 TO 255. IT PRODUCES ;AN ERROR MESSAGE IF THE CHARACTER STRING REPRESENTS A ;NUMBER LARGER THAN THIS. INT1: CALL CONV ;GET THE NUMBER IN BC CMP B ;CHECK THE SIZE JRZ SMPOS ;POSITIVE CMP H JNZ ERRTYP PUSH H LXI H,REPROM CALL TXTYP POP H JMPR INT1 ;MOVE LOW BYTE TO MEMORY SMPOS: PUSH H MOV H,0(X) ;GET ADDRESS MOV L,-1(X) MOV M,C ;MOVE NUMBER POP H ;RESTORE TER PAIR. CONVERT ;DETECTS 15 BIT OVERFLOWS, TRUNCATES THE RESULT TO ;15 BITS AND CAUSES AN ERROR MESSAGE TO BE PRINTED. CONV: PUSH D ;SAVE D,H PUSH H LXI H,0 ;INITIALIZE THE RESULT MOV B,H ;SIGN INDICATOR, DEFAULT +IVE XTHL BLNK1: CALL INPUT CPI ' ' JRZ BLNK1 ;LEADING BLANK? CPI '-' ;MINUS SIGN? JRNZ NMINUS INR B ;INDICATE NEGATIVE RESULT JR GETDIG NMINUS: CPI '+' ;POSITIVE SIGN JRNZ CHKDIG ;NO, CHECK FOR A DIGIT GETDIG: CALL INPUT ;GET NEXT CHARACTER ;CHECK FOR A VALID DIGIT CHKDIG: CPI '9'+1 JRNC OVFMSG ;TOO LARGE SUI '0' JRC OVFMSG ;TOO SMALL VALDIG: XTHL ;GET PARTIAL RESULT CALL TIMES10 ;MULTIPLY BY 10 AND ADD THIS DIGIT XTHL ;SAVE PARTIAL RESULT ON STACK JV OVFMSG ;ERROR ON 15 BIT OVERFLOW call look ;look ahead one character CHKCHR: CPI '9'+1 JRNC NOTDIG SUI '0' JRNC GETDIG ;PROCESS NEXT DIGIT ;NOT DIGIT INDICATES THAT THE END OF THE STRING HAS BEEN ;REACHED. NOTDIG: XRA A CMP B ;IS RESULT SUPPOSED TO BE NEGALATOR TIMES10 MOV D,H MOV E,L ;COPY HL -> DE ORA A ;CLEAR CARRY DADC H ;X2 RV ;RETURN IF 15 BIT OVERFLOW DADC H ;X4 RV DADC D ;X5 RV DADC H ;X10 RV MOV E,A MVI D,0 DADC D ;PLUS THE NEW DIGIT RET ENDIF ;NTXT INPUTS A DATA STREAM FROM A NON-TEXT DATA FILE NTXT: PUSH D ;PARAMETER COUNT PUSH H ;FILE BUFFER ADDRESS MOV H,0(X) ;GET ADDRESS MOV L,-1(X) MOV D,-2(X) ;GET BYTE COUNT MOV E,-3(X) TXLP: XTHL CALL EOF JC RBEOF INX H INX H INX H CALL BYTF NOT COMPILER ;Compiler doesn't need this DB 'Type error on inpu','t'+80H REPROM: DB 'Error in input, try again',CR,LF+80H ENDIF THE LIST POINTER DADX B POP H ;FILE BUFFER ADDRESS POP D ;CHECK FOR END OF PARAMETER LIST DCX D MOV A,D ORA E JRNZ NTXT JMP THREW ;ERROR TYPE OF INPUT DOESN'T MATCH VARIABLE ;FATAL ERROR ERRTYP: LXI H,TYPMES JMP PERROR TYPMES: I;INDIRECT LOAD AND STORE, AND ADDR. CALCULATION ROUTINES ; NAME INDIR ENTRY ILOD1,ILOD11,ILOD12,ILOD2,ILOD21,ILOD22,ILODV,ILODV1 ENTRY ILODV2,ISTOR,ISTOR1,ISTOR2,XADDR,YADDR ; ILOD1: MOV C,A ;LOAD A ZERO ILOD11: MOV B,A ;CLEAR THE HIGH BYTE ILOD12: PUSH B ;SAVE THE OFFSET PUSH X ;INDIRECT ALWAYS OF X REG POP B ;ADD OFFSET REG TO VADDR FIELD DAD B ;WHICH IS IN HL MOV B,M ;GET VARIABLE BASE ADDRESS DCX H MOV C,M IL1V: POP H ;GET OFFSET DAD B ;ADD TO BASE ADDRESS MOV L,M ;A ZERO ILODV1: MOV B,A ;CLEAR THE HIGH BYTE ILODV2: PUSH B ;SAVE THE OFFSET PUSH X ;ALWAYS USE X-REG FOR INDIRECT POP B ;ADD OFFSET REG TO VADDR FIELD DAD B ;WHICH IS IN HL MOV B,M ;GET HIGH ORDER ADDRESS BYTE DCX H MOV C,M ;GET LOW ORDER ADDRESS BYTE DCX H MOV A,M ;GET VARIABLE SIZE DCR A ;CHECK SIZE JRZ IL1V ;LOAD VAR OF SIZE 1 XRA A ;LOAD VAR OF SIZE 2 JR IL2V ;DONE!!! ; ; ISTOR: MOV C,A ;LOAD A ZERO ISTOR1: MOV B,A ;CLEAR THE HIGH BYTE ISTOR2: PUSH B ;SAVE TIVE POP B POP D ;RESTORE ARGUMENT COUNT RZ ;RETURN IF RESULT IS +IVE MOV A,B CMA MOV B,A MOV A,C CMA MOV C,A INX B XRA A RET ;SIGN IS FIXED, ALL DONE!! OVFMSG: XRA A ;CHECK FOR CONSOLE FILE CMP H JRNZ ERRTYP ;NO, FATAL ERROR POP B POP D LXI H,REPROM ;YES, GET NEW INPUT CALL TXTYP OVF1 CALL TIN ;CLEAR INPUT BUFFER CPI CR JRNZ OVF1 LXI H,1 ;CONSOLE FILE JR CONV ;GET NEXT NUMBER ; MULTIPLY A NUMBER BY TEN AND ADD IN THE DIGIT ; STORED IN THE ACCUMUIN ;GET NEXT DATA BYTE DCX H DCX H MOV B,M MOV M,A MOV A,B DCX H JRNC NTCONT BSET 1,M ;SET EOF FLAG NTCONT: XTHL MOV M,A ;STORE IT DCX H ;MEMORY ADDRESS DCX D ;BYTE COUNT MOV A,D ;CHECK FOR END ORA E JRNZ TXLP LXI B,-4 ;MOVE THE LIST POINTER DADX B POP H ;FILE BUFFER ADDRESS POP D ;CHECK FOR END OF PARAMETER LIST DCX D MOV A,D ORA E JRNZ NTXT JMP THREW ;ERROR TYPE OF INPUT DOESN'T MATCH VARIABLE ;FATAL ERROR ERRTYP: LXI H,TYPMES JMP PERROR TYPMES: IGET VALUE MOV H,A ;CLEAR HIGH BYTE RET ;DONE!!! ; ; ILOD2: MOV C,A ;LOAD A ZERO ILOD21: MOV B,A ;CLEAR THE HIGH BYTE ILOD22: PUSH B ;SAVE THE OFFSET PUSH X ;INDIRECT ALWAYS OF X REG POP B ;ADD OFFSET REG TO VADDR FIELD DAD B ;WHICH IS IN HL MOV B,M ;GET VARIABLE BASE ADDRESS DCX H MOV C,M IL2V: POP H ;GET OFFSET DAD B ;ADD TO BASE ADDRESS MOV B,M ;GET HIGH BYTE DCX H MOV L,M ;GET LOW BYTE MOV H,B ;RESTORE HIGH BYTE RET ;DONE!!! ; ; ILODV: MOV C,A ;LOAD THE OFFSET PUSH X ;ALWAYS USE X-REG FOR INDIRECT POP B ;ADD OFFSET REG TO VADDR FIELD DAD B ;WHICH IS IN HL MOV B,M ;HIGH PART DCX H MOV C,M ;LOW PART DCX H MOV A,M ;GET VARIABLE SIZE POP H ;RESTORE OFFSET DAD B ;ADD OFFSET TO THE VARIABLE ADDRESS DCR A JRZ ISTR1 ;STORE A ONE BYTE VARIABLE XRA A ;CLEAR ACCUMULATOR MOV M,D ;STORE HIGH BYTE MOV D,A ;CLEAR HIGH BYTE DCX H ISTR1: MOV M,E ;STORE LOW BYTE CMP D ;CHECK HIGH BYTE FOR OVERFLOW RET ; ; XADDR: XRA A DSBC D ;SUBTRACT VARPART PUSH X ;GET X-REG POP D ;X-REG -> B-REG DAD D ;ADD OFFSET TO REGISTER RET ;DONE!!! ; ; YADDR: XRA A DSBC D ;SUBTRACT VARPART PUSH Y ;GET Y-REG POP D ;Y-REG -> B-REG DAD D ;ADD OFFSET TO REGISTER RET ;DONE!!! ;V D,A ;CLEAR HIGH BYTE DCX H ISTR1: MOV M,E ;STORE LOW BYTE CMP D ;CHECK HIGH BYTE FOR OVERFLOW RET ; ; XADDR: XRA; look -- routine to look one character ahead ; NAME LOOK ENTRY LOOK INCLUDE DEFLT.SRC ; look: xra a ;check for console/disk file cmp h jrz fcons ;console file.... inx h ;from disk.... mov a,m ;...get look-ahead char from the buffer dcx h ret ;....and done fcons: push d ;save de lhld 6 ;get the char from the txtin buffer lxi d,-getp dad d mov e,m mov d,a ;d <- 0 dad d inx h ;point to the next char mov a,m ;get it lxi h,0 ;restore the zero buffer pointer ; LAST LINE OF PROGRAM ; NAME LAST ENTRY LAST ; LAST EQU $ ;INPT SRCINPT SRC INDIR SRCLOOK SRCLAST $$$;SUBROUTINES FOR OPENING FILES FOR OUTPUT AND INPUT ; NAME OPFILE ENTRY OPNOT,OPNIN EXT SELDSK,POPHDB,DERR,PUSHBD INCLUDE DEFLT.SRC ; ;OPNOT OPENS A FILE FOR OUTPUT. THE POINTER TO THE FILE DESCRIPTOR IS ;PASSED IN HL. ANY FILE WITH THE SAME NAME ALREADY IN THE DIRECTORY IS ;DELETED. OPNOT CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A PUSH PSW CALL SELDSK XCHG MVI C,22 ; CP/M CODE TO CREATE A FILE ENTRY. CALL CPM CPI 255 ; CHECK FOR DIRECTORY FULL ERROR. JZ DERR POP PSW POP E. CALL CPM ADI 1 ; CARRY NOW SET IF ERROR OCCURRED. POP B MOV A,B ; RESTORE A WITHOUT AFFECTING THE FLAGS. JMP POPHDB ; PTOR OF BYTE POINTER. DAD D MVI M,0FFH ; SET BYTE POINTER TO EMPTY. INX H ; HL NOW POINTS TO LSBYT MVI M,0FFH POP H ; RESTORE HL (IT NOW POINTS TO START OF FCB). CALL SELDSK ; SELECT PROPER DRIVE. XCHG MVI C,15 ; CP/M CODE FOR OPEN FIL pop d ;restore de ret ;...and done! ole/disk file cmp h jrz fcons ;console file.... inx h ;from disk.... mov a,m ;...get look-ahead char from the buffer dcx h ret ;....and done fcons: push d ;save de lhld 6 ;get the char from the txtin buffer lxi d,-getp dad d mov e,m mov d,a ;d <- 0 dad d inx h ;point to the next char mov a,m ;get it lxi h,0 ;restore the zero buffer pointer H POP D POP B EXX EXAF POP PSW EXAF POP Y POP X POP H POP D POP B ; FALL THROUGH AND DO CODE FOR OPENING AN INPUT FILE. OPNIN CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A PUSH PSW PUSH H LXI D,BYTPT ; OFFSET INTO FILE DESCRIPTOR OF BYTE POINTER. DAD D MVI M,0FFH ; SET BYTE POINTER TO EMPTY. INX H ; HL NOW POINTS TO LSBYT MVI M,0FFH POP H ; RESTORE HL (IT NOW POINTS TO START OF FCB). CALL SELDSK ; SELECT PROPER DRIVE. XCHG MVI C,15 ; CP/M CODE FOR OPEN FIL; intrinsic function for calculating natural log ; NAME NATLOG ENTRY LN,L134 EXT FPSQR,RNGERR INCLUDE DEFLT.SRC INCLUDE FCTMAC.SRC ; L118 EQU FPSQR ; ; ; function ln( x: real ): real; ; const c1 = 2.8853913; ; c3 = 0.9614706; ; c5 = 0.59897865; ; sqrtp5 = 0.7071068; ; loge2 = 0.6931472; ; var y: record ; case char of ; 'a': ( a: real ); ; 'b': ( b1, b2, b3, b4: 0..255 ) ; end; ; z, z2: real; ; i: integer; ; begin L134: ln: ENTR D,2,14 PUSH IX ;c XCHG LXI B,4 LDDR POP H POP H JMP FC2206 FC2193 ; y.a := x; LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR LXI H,3 DADD S XCHG PUSH IX POP H LXI B,-10 DADD B XCHG LXI B,4 LDDR POP H POP H ; i := (y.b1 + 128) mod 256 - 128; MOV H,A MOV L,-10(IX) LXI D,128 DADD D,0 LXI D,256 MMOD D,0 LXI D,-128 DADD D,0 MOV -8(IX),H MOV -9(IX),L ; y.b1 := 0; MOV -10(IX),A ; z := (y.a - sqrtp5) / (y.a + sqrtp5); LXI H,,3 DADD S XCHG PUSH IX POP H LXI B,-4 DADD B XCHG LXI B,4 LDDR POP H POP H ; ln := (((c5*z2 + c3)*z2 + c1)*z - 0.5 + i) * loge2; LXI H,76 LXI D,-21675 PUSH H PUSH D LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-7 DADD B LXI B,4 LDIR MULT D,-4 LXI H,123 LXI D,4471 PUSH H PUSH D DADD D,-4 LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-7 DADD B LXI B,4 LDIR MULT D,-4 LXI H,604 LXI D,21792 PUSH H PUSH D DADD D,-4 ;PRINTS STATEMENT NUMBER IF TRACES OR EXT.ERROR MESSAGES ON ; NAME PSTAT ENTRY PSTAT EXT STMTMSG,TXTYP,CO,CRLF ; PSTAT: PUSH H ;SAVE HEAP POINTER LXI H,STMTMSG ;PRINT STATEMENT MESSAGE PUSH B ;STATEMENT NUMBER -> HL CALL TXTYP POP H PUSH H LXI D,1000 ;DO THOUSANDS DIGIT CALL DIGIT LXI D,100 ;DO HUNDREDS DIGIT CALL DIGIT LXI D,10 ;DO TENS DIGIT CALL DIGIT LXI D,1 ;DO ONES DIGIT CALL DIGIT LXI H,CRLF ;POINT TO CRLF CALL TXTYP ;PRINT IT POP B ;RESTORE STATEMEN;MANIPULATE A TEXT BUFFER AND ASSOCIATED POINTERS ; NAME TEXT ENTRY TIN,TXTIN,TOUT,TXTYP EXT POPHDB,CO,PUSHBD INCLUDE DEFLT.SRC ; ; ;THE TIN, TXTIN, AND TOUT ROUTINES MANIPULATE A TEXT BUFFER AND ;THEIR ASSOCIATED POINTERS. THE BUFFER RESIDES IN THE TOP OF THE ;TPA. ;EACH CALL TO TIN RETURNS THE NEXT CHARACTER IN THE TEXT BUFFER. ;A CARRAIGE RETURN IS PASSED TO INDICATE END OF LINE. A CPI 20H ;IS DONE BEFORE CONTROL IS RETURNED TO THE CALLING PROGRAM. THUS, ;Z IS TRUE IF THE CHARACTERheck if x is a negative number POP H LXI B,10 ;byte containing sign bit of mantissa DAD B BIT 7,M ;test bit JNZ RNGERR ;negative number, error message and abort ; if x = 1.0 then ln := 0.0 LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,8 DADD B LXI B,4 LDIR LXI H,320 MOV D,A MOV E,A PUSH H PUSH D EQUL D,-4 JNC FC2193 ; else begin MOV H,A MOV L,A MOV D,A MOV E,A PUSH H PUSH D LXI H,3 DADD S XCHG PUSH IX POP H LXI B,15 DADD B -4 DADD S SPHL XCHG PUSH IX POP H LXI B,-13 DADD B LXI B,4 LDIR LXI H,90 LXI D,-32135 PUSH H PUSH D DSUB D,-4 LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-13 DADD B LXI B,4 LDIR LXI H,90 LXI D,-32135 PUSH H PUSH D DADD D,-4 FDVD D,-4 LXI H,3 DADD S XCHG PUSH IX POP H XCHG LXI B,4 LDDR POP H POP H ; z2 := sqr( z ); LXI H,-4 DADD S SPHL XCHG PUSH IX POP H DCX H DCX H DCX H LXI B,4 LDIR CALL L118 LXI HLXI H,-4 DADD S SPHL XCHG PUSH IX POP H DCX H DCX H DCX H LXI B,4 LDIR MULT D,-4 LXI H,64 MOV D,A MOV E,A PUSH H PUSH D DSUB D,-4 MOV L,-9(IX) MOV H,-8(IX) PUSH H CVTF B DADD D,-4 LXI H,88 LXI D,-18164 PUSH H PUSH D MULT D,-4 LXI H,3 DADD S XCHG PUSH IX POP H LXI B,15 DADD B XCHG LXI B,4 LDDR POP H POP H ; end ; end; FC2206 EXIT D,4 ; T NUMBER POP H ;RESTORE HEAP POINTER XRA A ;CLEAR ACC RET ; DIGIT: MVI C,'0'-1 ;INITIALIZE ASCII COUNTER XRA A ;CLEAR CARRY DIG1: INR C ;BUMP COUNTER DSBC D ;TRY ANOTHER SUBTRACTION JRNC DIG1 ;KEEP IT UP WHILE POSITIVE RESULT DAD D ;ELSE MAKE RESULT +IVE JMP CO ;PRINT CHAR AND RETURN TO CALLER ALL DIGIT LXI D,1 ;DO ONES DIGIT CALL DIGIT LXI H,CRLF ;POINT TO CRLF CALL TXTYP ;PRINT IT POP B ;RESTORE STATEMEN IS A SPACE AND M AND C ARE TRUE IF ;THE RETURNED CHARACTER IS A CONTROL CHARACTER. THE CHARACTER IS ;RETURNED IN A. TIN CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A LHLD 6 ; HL POINTS TO TOP OF TPA + 1. LXI D,-GETP DAD D PUSH H ; Save pointer to text_in_pointer. MOV E,M MVI D,0 DAD D ; HL points to next character to read - 1. INX H MOV A,M POP H CPI ' ' ; Test for end of line. JRC ENDL INR M CPI ' ' EN: JMP POPHDB ENDL INX H ; HL POINTS TO LAST CHARACTER POINTER. MVI M,0 ; MAKE IT 1 FOR FUTURE TOUT CALLS. JMPR EN ;TXTIN READS A LINE INTO THE TEXT BUFFER AND SETS THE TEXT IN ;POINTER TO THE FIRST CHARACTER (TEXT IN POINTER := 1). TXTIN CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A LHLD 6 LXI D,-GETP DAD D ; HL POINTS TO START OF TEXT BUFFER. MVI M,BUFLEN-1 ; TELL CP/M THE MAXIMUM # OF CHARS TO READ. XCHG MVI C,10 ; CP/M CODE TO READ A LINE. CALL CPM MVI C,CR CALL TOUT MVI C,LF CALL CO JMP POPHDB ;TOUT STUFFS THE CHARACTER PASSED INER IN C. MOV M,C ; STUFF IT. POP PSW ORA A JMP POPHDB BFULL DCR M ; Make it work. MVI C,CR ; Put CR at end of text buffer. CALL TOUT ; Watch out, here's Recursive Robert. POP PSW STC JMP POPHDB ;TXTYP WRITES THE STRING OF CHARACTERS POINTED TO BY HL TO THE CONSOLE. ;A NULL OR A CHARACTER WITH ITS MSB SET MARKS THE END OF THE STRING. TXTYP MOV A,M ORA A RZ PUSH PSW ANI 7FH MOV C,A CALL CO POP PSW RM INX H JMPR TXTYP ;  MAXIMUM LENGTH STRPT1: DCX D DCX X MOV C,0(X) ;GET NEXT CHAR. CALL PRINT DJNZ STRPT1 ;DO FOR ALL CHARS IN STRING POP B ;B <- ACT LENGTH, C<- MAX LENGTH STRZRO: MOV A,C SUB B JRZ STSKP ;NO UNUSED BYTES MOV B,A ;NUMBER OF UNUSED BYTES STSKIP: DCX X ;SKIP UNUSED BYTES DCX D DJNZ STSKIP STSKP: DCX X DCX D RET ENDIF ;INTEGER OUTPUTS THE INTEGER RIGHT JUSTIFIED ;IN THE FIELD WIDTH SPECIFIED BY THE NEXT BYTE ;IN THE PARAMETER LIST. IF THE NUMBER IS TOO ;BIG FOR THE FIELD, THE SIGN BYTE DCX X NUM: MOV C,A ;ZERO CHARACTER COUNT LXI D,10000 CALL FIGURE LXI D,1000 CALL FIGURE LXI D,100 CALL FIGURE LXI D,10 CALL FIGURE MOV B,L ;LAST DIGIT CALL ADIGIT MOV B,A DADX B INX X ;X POINTS TO THE SIGN MOV A,0(X) CPI '-' JRNZ CHK0 INR C JMPR NEGA CHK0: CMP C JRNZ POSN MVI 0(X),'0' ;OUTPUT A ZERO INR C JMPR NEGA POSN: DCX X NEGA: MOV B,C POP H MOV A,M ;GET FIELD LENGTH XTHL ;FILE BUFFER ADDRESS ; ;SAVE PARAMETER LIST POINTER SU GOES INTO HL FIGURE: XRA A ;CLEAR CARRY DCR B CONT: INR B ;COUNTER DSBC D JRNC CONT TOOFAR: DAD D ;PUT BACK LAST TRY ;ADIGIT ADDS A DIGIT TO THE STRING ON THE STACK ;IF THE FIRST NON-ZERO DIGIT HAS BEEN ;ENCOUNTERED. IT ALSO INCREMENTS THE DIGIT COUNTER. ADIGIT: CMP B JRNZ NUDIG CMP C ;DIGIT IS A 0 RZ ;FIRST DIGIT NUDIG: MVI A,30H ;ASCII ADD B MOV 0(X),A ;ADD DIGIT TO STRING DCX X INR C ;DIGIT COUNTER XRA A MOV B,A RET ;NONTXT OUTPUTS A DATA STREAM TO A NON-TEXT C INTO THE TEXT BUFFER. THE CARRY IS ;SET IFF THE BUFFER IS FULL. THE TEXT_IN_POINT IS RESET TO THE FIRST ;CHARACTER ON EVERY CALL. TOUT CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A PUSH PSW LHLD 6 LXI D,-GETP DAD D ; HL POINTS TO THE TEXT_IN_POINTER. MVI M,1 ; TEXT_IN_POINTER := 1 INX H MOV A,M ; A := TEXT_FILL_POINTER CPI BUFLEN JRZ BFULL ; BRANCH IF BUFFER IS FULL. INR M ; TEXT_FILL_POINTER := TEXT_FILL_POINTER + 1 MOV E,M MVI D,0 DAD D ; HL POINTS TO SLOT FOR CHARACTIN FIELD LENGTH DCX X ;BYTE POINTER DCX X DCX X DCX D ;BYTE COUNTER DCX D DCX D MOV C,1(X) ;LOW BYTE OF SIZE=MAXLENGTH+1 DCR C ;C <- MAX LENGTH PUSH B ;SAVE MAX. LENGTH(C) AND ACTUAL LENGTH(B) SUB B ;CALCULATE PADDING IF ANY JRZ STPRNT ;NONE NEEDED JRC STPRNT MOV B,A ;PAD TO FILL OUT MIN. FIELD LENGTH MVI C,' ' SFILL: CALL PRINT DJNZ SFILL STPRNT: POP B ;B <- ACT. LENGTH, C<- MAX LENGTH XRA A CMP B ;CHECK FOR ZERO LENGTH STRIN JRZ STRZRO PUSH B ;SAVE ACTUAL LENGTH AND FIELD IS EXTENDED ON ;THE RIGHT. INTEG: DCX D DCX D DCX D PUSH D ;BYTE COUNTER MOV D,-1(X) ;GET VALUE MOV E,-2(X) PUSH X POP B LXI X,-6 ;RESERVE STACK SPACE FOR DIGIT STRING DADX S SPIX PUSH H ;FILE BUFFER ADDRESS PUSH B ;PARAMETER LIST POINTER LXI B,5 DADX B ;DIGIT STRING POINTER BIT 7,D ;TEST SIGN JRZ POSNUM MVI 0(X),'-';NEGATIVE NUMBER DCX X XRA A ;CLEAR CARRY MOV H,A MOV L,A MOV B,A DSBC D JMPR NUM POSNUM: XCHG ;POSITIVE NUMBER MOV 0(X),A ;ZEROB B JRC PERFIT ;EXTEND THE FIELD TO MATCH JRZ PERFIT ;FIELD MATCHES MOV D,A MVI C,' ' ;PAD THE NUMBER TO MATCH THE FIELD PAD: CALL PRINT DCR D JRNZ PAD PERFIT: MOV C,0(X) ;PRINT THE DIGIT STRING CALL PRINT DCX X DJNZ PERFIT ;NUMBER IS PRINTED CLEANUP MESS AND RETURN POP X ;RESTORE LIST POINTER DCX X DCX X DCX X XCHG ;REMOVE DIGIT STRING FROM STACK LXI H,6 DAD S SPHL XCHG POP D ;RESTORE PARAMETER BYTE COUNTER XRA A ;CLEAR A RET ;FIGURE COUNTS HOW MANY TIMES DEDISK FILE NONTXT: PUSH H ;SAVE FILE BUFFER ADDRESS NONTX1: LXI B,-4 ;UPDATE PARAMETER POINTER DADX B XCHG DAD B XCHG MOV H,2(X) ;GET BYTE COUNT MOV L,1(X) NTLP: MOV C,0(X) ;GET NEXT DATA BYTE DCX X ;POINTER DCX H ;BYTE COUNT DCX D ;PARAMETER COUNT XTHL CALL DIS ;TO THE DATA XTHL MOV A,H ;DONE? ORA L JRNZ NTLP MOV A,D ;END OF PARAMETER LIST ORA E ;ALL PARAMETERS ARE EITHER TEXT OR NON-TEXT JRNZ NONTX1 POP H ;FILE BUFFER COUNT JMP CLEAN ;BUFFER ADDRESS IS NON-ZE