|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 8832 (0x2280)
Types: TextFile
Names: »MAIN.SRC«
└─⟦c9df7130d⟧ Bits:30005915 Pascal MT+ Release 5.2 (Jet-80)
└─ ⟦this⟧ »MAIN.SRC«
; 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,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 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 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 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 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 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 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 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 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,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 SLE 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 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,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 CALL 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 '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 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 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,OFF1,OFF2 IF OFF1 LXI H,OFF1 CALL CONSET ELSE LXI H,-OFF2 DAD S 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 D,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 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 dsub b dad s mvi m,cr endmac «eof»