CP/M

home *** CD-ROM | disk | FTP | other *** search

/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol071 / promain.src < prev next >

Wrap

Text File | 1984-04-29 | 12KB | 804 lines

; Pascal/Z run-time support interface -- WITH PROFILER ; COPYRIGHT 1978, 1979, 1980, 1981 BY JEFF MOSKOW NAME MAIN ENTRY .FLTERR,.HPERR,.REFERR,.STKERR,.RNGERR,.DIVERR,.MLTERR,L98,.CRLF ENTRY .PERROR,.STMTMSG,.CHIN$,.STRERR,.MAXOUT,.MXOUT,.MXUT1,.STRMSG ENTRY .START EXT .ILDV,.ILDV1,.ILDV2,.ILD1,.ILD11,.ILD12,.ILD2,.ILD21 EXT .ILD22 EXT .ISTR,.ISTR1,.ISTR2,.XADDR,.YADDR,.FSUB,.FADD,.ENTRSC,.ENTER EXT .EXITF,.FPEQ,.SEQUL,.FPNEQ,.SNE,.FPLTE,.SLE,.ILE,.FPLT,.SLT,.ILT EXT .FPGTE,.SGE,.IGE,.FPGT,.SGT,.IGT,.FMULT,.IMULT,.QMULT,.IDIVD,.IMOD EXT .NCDVD,.NCMOD,.ERROR,.CSTS,.CI,.CO,.CHKDE,.CHKHL,.PSTAT,.CONSET EXT .RCSET,.UNION,.INN,.LTEQ EXT .GTEQ,.INSECT,.ORGAN,.COMP,.FUSS,.FOUT,.FXDCVT,.CVTFLT,.TOUT EXT .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 S: SET 0FFFFH D: SET 0FFFFH E: SET 00000H F: SET 0FFFFH T: SET 00000H VALID: SET 00000H FIRSTMT SET 00000H ; NO 'STMT' CALLS YET MINSTMT SET 00000H ; LOWEST, HIGHEST TRACED MAXSTMT SET 00000H ; ..STATEMENT NUMBERS .MAXOUT EQU 4 .MXOUT EQU .MAXOUT*256 .MXUT1 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 DJNZ CLRSTK INX H MOV M,A LXI H,80H MOV A,M CPI 2 JRC NOCOM MOV B,M DCR B INX H INITLP INX H MOV C,M CALL .TOUT DJNZ INITLP NOCOM MVI C,CR CALL .TOUT ; code to clear the profile table to zero lbcd proclear ; bytes in stmt buckets lxi h,proftab ; start of bucket area mvi m,00h ; begin zeros lxi d,proftab+1 ldir ; propogate zero ; end inserted code JMP L99 ; code inserted to increment a statement count .profinc: push psw push b push h lhld profset ; -(lowest number) dad b ; relative stmt number dad h ; relative byte lxi b,proftab ; base address dad b ; hl->stmt bucket mov b,m ; pick up stmt's counter inx h mov c,m inx b ; ..increment, mov m,c ; ..put back dcx h mov m,b pop h pop b pop psw ret ; end of insertion FINI: MACRO ; as modified to write profile table mvi c,19 lxi d,profile call cpm ; erase existing profile mvi c,22 lxi d,profile call cpm ; create 'A:PROFILER.DAT' lxi h,proferr inr a jz .ERROR ; -- make failed lxi h,prodata ; hl->next record lda pronio mov b,a ; b=record count profout: xchg ; de->next record push d ; (save it) mvi c,26 push b ; (save loop count) call cpm ; set buffer address lxi d,profile mvi c,21 call cpm ; write one record lxi h,proferr ora a jnz .ERROR pop b pop h lxi d,128 dad d ; hl->next record djnz profout ; repeat for all sectors ; lxi d,profile mvi c,16 call cpm ; close file lxi h,proferr inr a jz .ERROR ; end of insertion JMP L0 ; the profile work areas proferr: ; error message for make, write, close dbs 'Error writing A:PROFILE.DAT' profile: ; file control block: A:PROFILER.DAT db 1,'PROFILER','DAT',0,0,0,0 dw 0,0,0,0,0,0,0,0 db 0,0,0,0 ; the following definitions have to be at the end of ; the program, following the last set of MAX/MINSTMT. IF MINSTMT pronums set MAXSTMT-MINSTMT+1 ; number of traced stmts ELSE pronums set 0 ENDIF prosize set pronums*2 ; bytes of stmt buckets prorecs set prosize+6 ; allow for count, lo, hi prorecs set prorecs+127 ; round to logical sector prorecs set prorecs/128 ; number of logical sectors ; IF PRONUMS proclear dw prosize ; for clearing the array ELSE proclear set 2 ENDIF profset dw -MINSTMT ; for addressing buckets pronio db prorecs ; for write-loop ; prodata equ $ ; start of profiler.dat promsb set pronums/256 prolsb set promsb*256 prolsb set pronums-prolsb db promsb,prolsb ; integer number of stmts promsb set MINSTMT/256 prolsb set promsb*256 prolsb set MINSTMT-prolsb db promsb,prolsb ; int. lowest stmt number promsb set MAXSTMT/256 prolsb set promsb*256 prolsb set MAXSTMT-prolsb db promsb,prolsb ; int. highest ditto proftab ds prosize ; statement buckets db 0 ; force .rel file to size ; end of insertion 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 MLOAD: 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 .ILDV,OFST ELSE IF SIZE-1 MLOAD .ILD2,OFST ELSE MLOAD .ILD1,OFST ENDIF ENDIF ENDMAC ISTR: MACRO Q,SIZE,OFST MLOAD .ISTR,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 MOV E,L DCX H DCX H LXI B,DISTANCE LDDR POP D POP H POP B ELSE POP D ENDIF ENDMAC LPUSH: MACRO REG,SIZE IF SIZE-2 PUSH REG LXI H,0 DAD S XCHG LXI H,-2 DAD S SPHL XCHG LXI B,SIZE+2 LDIR POP D LXI H,SIZE DAD S MOV M,E INX H MOV M,D ELSE IF 'REG'-'H' XCHG ENDIF XTHL PUSH H 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 CALL .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 .CHIN$: 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 MOV 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,255*SIZE1-257+SIZE1+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,255*SIZE1-257+SIZE1+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 .SLE ENDIF ELSE CALL .ILE ENDIF ELSE LXI B,255*SIZE1-257+SIZE1+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,255*SIZE1-257+SIZE1+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,255*SIZE1-257+SIZE1+SIZE2 CALL .STRGEQ ENDIF ENDMAC 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,255*SIZE1-257+SIZE1+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 IF M CALL .IDIVD ELSE CALL .NCDVD ENDIF ENDMAC MMOD: MACRO IF M CALL .IMOD ELSE CALL .NCMOD 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 Q,X STMT M,X 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 LXI B,LBND IF 'REG'-'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 ENDMAC STMT: MACRO Q,NUMBER IF T+E VALID SET 0FFFFH EXX LXI B,NUMBER IF T IF NOT FIRSTMT MINSTMT SET NUMBER FIRSTMT SET 0FFFFH ENDIF ; FIRST STMT MAXSTMT SET NUMBER IF 'M'-'Q' call .profinc ENDIF ; Q IS D ENDIF ; T TRUE EXX ELSE ; NEITHER T NOR E IF VALID EXX MOV B,A MOV C,A EXX VALID SET 00000H ENDIF ; VALID ENDIF ; T+E 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 .REFERR: LXI H,.REFMSG JR .PERROR .RNGERR: LXI H,.RNGMSG JR .PERROR ENDIF .HPERR: LXI H,.STKMSG JR .PERROR .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 precision 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,OFF IF OFF IF OFF-1 CALL .RCSET ELSE CALL .CONSET ENDIF ELSE MVI B,16 LXI H,0 CSETCL: SET $ PUSH H DJNZ CSETCL ENDIF ENDMAC UNIN: MACRO Q,OFFSET,OFF1 CALL .UNION ENDMAC MEMB: MACRO Q,OFFSET,OFF2 CALL .INN ENDMAC INCL: MACRO Q,OFFSET,OFF1 CALL .LTEQ ENDMAC SBST: MACRO Q,OFFSET,OFF1 CALL .GTEQ ENDMAC INTR: MACRO Q,OFFSET,OFF1 CALL .INSECT ENDMAC DIFF: MACRO Q,OFFSET,OFF1 CALL .ORGAN ENDMAC MTCH: MACRO Q,OFFSET,OFF1 CALL .COMP ENDMAC NOMT: MACRO Q,OFFSET,OFF1 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 dcx s lxi h,14 dad s push h call .fxdcvt else call .fout dcx s lxi h,0 dad s xchg lxi h,1 dad d lxi b,14 ldir dcx h mvi m,14 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 dsub b dad s mvi m,cr endmac