seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-26 09:54:20 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Upload

Browse Source 
Digital Research
This commit is contained in:
Sepp J Morris
2020-11-06 18:50:37 +01:00
parent 621ed8ccaf
commit 31738079c4
8481 changed files with 1888323 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

46
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/AS0COM.ASM Normal file
View File

@@ -0,0 +1,46 @@
TITLE 'ASM COMMON DATA AREA'
;
; COPYRIGHT (C) 1977, 1978
; DIGITAL RESEARCH
; BOX 579, PACIFIC GROVE
; CALIFORNIA, 93950
;
; COMMON DATA FOR CP/M ASSEMBLER MODULE
ORG 100H
ENDA EQU 20F0H ;END OF ASSEMBLER PROGRAM
BDOS EQU 5H ;ENTRY TO DOS, USED TO COMPUTE END MEMORY
LXI SP,ENDMOD
LHLD BDOS+1
SHLD SYMAX ;COMPUTE END OF MEMORY
JMP ENDMOD
COPY: DB ' COPYRIGHT(C) 1978, DIGITAL RESEARCH '
ORG COPY
;
; PRINT BUFFER AND PRINT BUFFER POINTER
PBMAX EQU 120 ;MAX PRINT BUFFER
PBUFF: DS PBMAX
PBP: DS 1 ;PRINT BUFFER POINTER
;
; SCANNER PARAMETERS
TOKEN: DS 1 ;CURRENT TOKEN
VALUE: DS 2 ;BINARY VALUE FOR NUMBERS
ACCLEN: DS 1 ;ACCUMULATOR LENGTH
ACMAX EQU 64 ;LENGTH OF ACCUMULATOR
ACCUM: DS ACMAX ;ACCUMULATOR (MUST FOLLLOW ACCLEN)
;
; OPERAND EXPRESSION EVALUATOR PARAMETERS
EVALUE: DS 2 ;VALUE OF EXPRESSION AFTER EVALUATION
;
; SYMBOL TABLE MODULE PARAMETERS
SYTOP: DW ENDA ;FIRST LOCATION AVAILABLE FOR SYMBOL TABLE
SYMAX: DS 2 ;LAST AVAILABLE LOCATION FOR SYMBOL TABLE
;
; MISCELLANEOUS DATA AREAS
PASS: DS 1 ;PASS # 0,1
FPC: DS 2 ;FILL ADDRESS FOR NEXT HEX RECORD
ASPC: DS 2 ;ASSEMBLER'S PSEUDO PC
SYBAS: DW ENDA ;SYMBOL TABLE BASE
SYADR: DS 2 ;CURRENT SYMBOL BASE
ENDMOD EQU ($ AND 0FF00H)+100H
END


727
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/AS1IO.ASM Normal file
View File

@@ -0,0 +1,727 @@
TITLE 'ASM IO MODULE'
; I/O MODULE FOR CP/M ASSEMBLER
;
ORG 200H
BOOT EQU 000H ;REBOOT LOCATION
; I/O MODULE ENTRY POINTS
JMP INIT ;INITIALIZE, START ASSEMBLER
JMP SETUP ;FILE SETUP
JMP GNC ;GET NEXT CHARACTER
JMP PNC ;PUT NEXT OUTPUT CHARACTER
JMP PNB ;PUT NEXT HEX BYTE
JMP PCHAR ;PRINT CONSOLE CHARACTER
JMP PCON ;PRINT CONSOLE BUFFER TO CRLF
JMP WOBUFF ;WRITE OUTBUFFER
JMP PERR ;PLACE ERROR CHARACTER INTO PBUFF
JMP DHEX ;PLACE HEX BYTE INTO OUTPUT BUFFER
JMP EOR ;END OF ASSEMBLY
; DATA FOR I/O MODULE
BPC: DS 2 ;BASE PC FOR CURRENT HEX RECORD
DBL: DS 1 ;HEX BUFFER LENGTH
DBUFF: DS 16 ;HEX BUFFER
;
; DISK NAMES
CDISK: DS 1 ;CURRENTLY SELECTED DISK
ADISK: DS 1 ;.ASM DISK
PDISK: DS 1 ;.PRN DISK
HDISK: DS 1 ;.HEX DISK
;
;
;
; COMMON EQUATES
QBMAX EQU 120 ;MAX PRINT SIZE
QBUFF EQU 10CH ;PRINT BUFFER
QBP EQU QBUFF+QBMAX ;PRINT BUFFER POINTER
;
TOKEN EQU QBP+1 ;CURRENT TOKEN UDER SCAN
VALUE EQU TOKEN+1 ;VALUE OF NUMBER IN BINARY
ACCLEN EQU VALUE+2 ;ACCUMULATOR LENGTH
ACMAX EQU 64 ;MAX ACCUMULATOR LENGTH
ACCUM EQU ACCLEN+1
;
EVALUE EQU ACCUM+ACMAX ;VALUE FROM EXPRESSION ANALYSIS
;
SYTOP EQU EVALUE+2 ;CURRENT SYMBOL TOP
SYMAX EQU SYTOP+2 ;MAX ADDRESS+1
;
PASS EQU SYMAX+2 ;CURRENT PASS NUMBER
FPC EQU PASS+1 ;FILL ADDRESS FOR DHEX ROUTINE
ASPC EQU FPC+2 ;ASSEMBLER'S PSEUDO PC
;
CR EQU 0DH ;CARRIAGE RETURN
LF EQU 0AH ;LINE FEED
EOF EQU 1AH ;END OF FILE MARK
;
;
; DOS ENTRY POINTS
BDOS EQU 5H ;DOS ENTRY POINT
READC EQU 1 ;READ CONSOLE DEVICE
WRITC EQU 2 ;WRITE CONSOLE DEVICE
REDYC EQU 11 ;CONSOLE CHARACTER READY
SELECT EQU 14 ;SELECT DISK SPECIFIED BY REGISTER E
OPENF EQU 15 ;OPEN FILE
CLOSF EQU 16 ;CLOSE FILE
DELEF EQU 19 ;DELETE FILE
READF EQU 20 ;READ FILE
WRITF EQU 21 ;WRITE FILE
MAKEF EQU 22 ;MAKE A FILE
CSEL EQU 25 ;RETURN CURRENTLY SELECTED DISK
SETDM EQU 26 ;SET DMA ADDRESS
;
; FILE AND BUFFERING PARAMETERS
NSB EQU 8 ;NUMBER OF SOURCE BUFFERS
NPB EQU 6 ;NUMBER OF PRINT BUFFERS
NHB EQU 6 ;NUMBER OF HEX BUFFERS
;
SSIZE EQU NSB*128
PSIZE EQU NPB*128
HSIZE EQU NHB*128
;
; FILE CONTROL BLOCKS
SCB: DS 9 ;FILE NAME
DB 'ASM' ;FILE TYPE
SCBR: DS 1 ;REEL NUMBER (ZEROED IN SETUP)
DS 19 ;MISC AND DISK MAP
SCBCR: DS 1 ;CURRENT RECORD (ZEROED IN SETUP)
;
PCB: DS 9
DB 'PRN',0
DS 19
DB 0 ;RECORD TO WRITE NEXT
;
HCB: DS 9
DB 'HEX',0
DS 19
DB 0
;
; POINTERS AND BUFFERS
SBP: DW SSIZE ;NEXT CHARACTER POSITION TO READ
SBUFF: DS SSIZE
;
PBP: DW 0
PBUFF: DS PSIZE
;
HBP: DW 0
HBUFF: DS HSIZE
FCB EQU 5CH ;FILE CONTROL BLOCK ADDRESS
FNM EQU 1 ;POSITION OF FILE NAME
FLN EQU 9 ;FILE NAME LENGTH
BUFF EQU 80H ;INPUT DISK BUFFER ADDRESS
;
SEL: ;SELECT DISK IN REG-A
LXI H,CDISK
CMP M ;SAME?
RZ
MOV M,A ;CHANGE CURRENT DISK
MOV E,A
MVI C,SELECT
CALL BDOS
RET
;
SCNP: ;SCAN THE NEXT PARAMETER
INX H
MOV A,M
CPI ' '
JZ SCNP0
SBI 'A' ;NORMALIZE
RET
SCNP0: LDA CDISK
RET
;
PCON: ;PRINT MESSAGE AT H,L TO CONSOLE DEVICE
MOV A,M
CALL PCHAR
MOV A,M
INX H
CPI CR
JNZ PCON
MVI A,LF
CALL PCHAR
RET
;
FNAME: ;FILL NAME FROM DEFAULT FILE CONTROL BLOCK
LXI D,FCB
MVI B,FLN
FNAM0: LDAX D ;GET NEXT FILE CHARACTER
CPI '?'
JZ FNERR ;FILE NAME ERROR
MOV M,A ;STORE TO FILE CNTRL BLOCK
INX H
INX D
DCR B
JNZ FNAM0 ;FOR NEXT CHARACTER
RET
;
INIT: ;SET UP STACK AND FILES, START ASSEMBLER
LXI H,TITL
CALL PCON
JMP SET0
;
OPEN: ;OPEN FILE ADDRESSED BY D,E
MVI C,OPENF
CALL BDOS
CPI 255
RNZ
; OPEN ERROR
LXI H,ERROP
CALL PCON
JMP BOOT
;
CLOSE: ;CLOSE FILE ADDRESSED BY D,E
MVI C,CLOSF
CALL BDOS
CPI 255
RNZ ;CLOSE OK
LXI H,ERRCL
CALL PCON
JMP BOOT
;
DELETE: ;DELETE FILE ADDRESSED BY D,E
MVI C,DELEF
JMP BDOS
;
MAKE: ;MAKE FILE ADDRESSED BY D,E
MVI C,MAKEF
CALL BDOS
CPI 255
RNZ
; MAKE ERROR
LXI H,ERRMA
CALL PCON
JMP BOOT
;
SELA: LDA ADISK
CALL SEL
RET
;
NPR: ;RETURN ZERO FLAG IF NO PRINT FILE
LDA PDISK
CPI 'Z'-'A'
RZ
CPI 'X'-'A' ;CONSOLE
RET
;
SELP: LDA PDISK
CALL SEL
RET
;
SELH: LDA HDISK
CALL SEL
RET
;
SET0: ;SET UP FILES FOR INPUT AND OUTPUT
LDA FCB ;GET FIRST CHARACTER
CPI ' ' ;MAY HAVE FORGOTTEN NAME
JZ FNERR ;FILE NAME ERROR
MVI C,CSEL ;CURRENT DISK?
CALL BDOS ;GET IT TO REG-A
STA CDISK
;
; SCAN PARAMETERS
LXI H,FCB+FLN-1
CALL SCNP
STA ADISK
CALL SCNP
STA HDISK
CALL SCNP
STA PDISK
;
LXI H,SCB ;ADDRESS SOURCE FILE CONTROL BLOCK
CALL FNAME ;FILE NAME OBTAINED FROM DEFAULT FCB
;
CALL NPR ;Z OR X?
JZ NOPR
LXI H,PCB ;ADDRESS PRINT FILE CONTROL BLOCK
PUSH H ;SAVE A COPY FOR OPEN
PUSH H ;SAVE A COPY FOR DELETE
CALL FNAME ;FILL PCB
CALL SELP
POP D ;FCB ADDRESS
CALL DELETE
POP D ;FCB ADDRESS
CALL MAKE
;
NOPR: ;TEST FOR HEX FILE
LDA HDISK
CPI 'Z'-'A'
JZ NOHEX
LXI H,HCB
PUSH H
PUSH H
CALL FNAME
CALL SELH
POP D
CALL DELETE
POP D
CALL MAKE
;
; FILES SET UP, CALL ASSEMBLER
NOHEX: JMP ENDMOD
;
SETUP: ;SETUP INPUT FILE FOR SOURCE PROGRAM
LXI H,SSIZE
SHLD SBP ;CAUSE IMMEDIATE READ
XRA A ;ZERO VALUE
STA SCBR ;CLEAR REEL NUMBER
STA SCBCR ;CLEAR CURRENT RECORD
STA DBL ;CLEAR HEX BUFFER LENGTH
CALL SELA
LXI D,SCB
CALL OPEN
;
RET
;
FNERR: ;FILE NAME ERROR
LXI H,ERRFN
CALL PCON
JMP BOOT
;
;
GCOMP: ;COMPARE D,E AGAINS H,L
MOV A,D
CMP H
RNZ
MOV A,E
CMP L
RET
;
GNC: ;GET NEXT CHARACTER FROM SOURCE BUFFER
PUSH B
PUSH D
PUSH H ;ENVIRONMENT SAVED
LHLD SBP
LXI D,SSIZE
CALL GCOMP
JNZ GNC2
;
; READ ANOTHER BUFFER
CALL SELA
LXI H,0
SHLD SBP
MVI B,NSB ;NUMBER OF SOURCE BUFFERS
LXI H,SBUFF
GNC0: ;READ 128 BYTES
PUSH B ;SAVE COUNT
PUSH H ;SAVE BUFFER ADDRESS
MVI C,READF
LXI D,SCB
CALL BDOS ;PERFORM THE READ
POP H ;RESTORE BUFFER ADDRESS
POP B ;RESTORE BUFFER COUNT
ORA A ;SET FLAGS
MVI C,128
JNZ GNC1
; NORMAL READ OCCURRED
LXI D,BUFF ;SOURCE BUFFER ADDRESS
MVI C,128
MOV0: LDAX D ;GET CHARACTER
MOV M,A ;STORE CHARACTER
INX D
INX H
DCR C
JNZ MOV0
; BUFFER LOADED, TRY NEXT BUFFER
;
DCR B
JNZ GNC0
JMP GNC2
;
GNC1: ;EOF OR ERROR
CPI 3 ;ALLOW 0,1,2
JNC FRERR ;FILE READ ERROR
GNCE: MVI M,EOF ;STORE AND END OF FILE CHARACTER
INX H
DCR C
JNZ GNCE ;FILL CURRENT BUFFER WITH EOF'S
;
GNC2: ;GET CHARACTER TO ACCUMULATOR AND RETURN
LXI D,SBUFF
LHLD SBP
PUSH H ;SAVE CURRENT SBP
INX H ;READY FOR NEXT READ
SHLD SBP
POP H ;RESTORE PREVIOUS SBP
DAD D ;ABSOLUTE ADDRESS OF CHARACTER
MOV A,M ;GET IT
POP H
POP D
POP B
RET
;
FRERR: LXI H,ERRFR
CALL PCON ;PRINT READ ERROR MESSAGE
JMP BOOT
;
PNC: ;SAME AT PNCF, BUT ENVIRONMENT IS SAVED FIRST
PUSH B
; CHECK FOR CONSOLE OUTPUT / NO OUTPUT
MOV B,A ;SAVE CHARACTER
LDA PDISK ;Z OR X?
CPI 'Z'-'A' ;Z NO OUTPUT
JZ PNRET
;
CPI 'X'-'A'
MOV A,B ;RECOVER CHAR FOR CON OUT
JNZ PNGO
CALL PCHAR
JMP PNRET
;
; NOT X OR Z, SO PRINT IT
PNGO: PUSH D
PUSH H
CALL PNCF
POP H
POP D
PNRET: POP B
RET
;
PNCF: ;PRINT NEXT CHARACTER
LHLD PBP
XCHG
LXI H,PBUFF
DAD D
MOV M,A ;CHARACTER STORED AT PBP IN PBUFF
XCHG ;PBP TO H,L
INX H ;POINT TO NEXT CHARACTER
SHLD PBP ;REPLACE IT
XCHG
LXI H,PSIZE
CALL GCOMP ;AT END OF BUFFER?
RNZ ;RETURN IF NOT
;
; OVERFLOW, WRITE BUFFER
CALL SELP
LXI H,0
SHLD PBP
LXI H,PBUFF
LXI D,PCB ;D,E ADDRESS FILE CONTROL BLOCK
MVI B,NPB ;NUMBER OF BUFFERS TO B
; (DROP THROUGH TO WBUFF)
;
WBUFF: ;WRITE BUFFERS STARTING AT H,L FOR B BUFFERS
; CHECK FOR EOF'S
MOV A,M
CPI EOF
RZ ;DON'T DO THE WRITE
;
PUSH B ;SAVE NUMBER OF BUFFERS
PUSH D ;SAVE FCB ADDRESS
MVI C,128 ;READY FOR MOVE
LXI D,BUFF
WBUF0: ;MOVE TO BUFFER
MOV A,M ;GET CHARACTER
STAX D ;PUT CHARACTER
INX H
INX D
DCR C
JNZ WBUF0
;
; WRITE BUFFER
POP D ;RECOVER FCB ADDRESS
PUSH D ;SAVE IT AGAIN FOR LATER
PUSH H ;SAVE BUFFER ADDRESS
MVI C,WRITF ;DOS WRITE FUNCTION
CALL BDOS
POP H ;RECOVER BUFFER ADDRESS
POP D ;RECOVER FCB ADDRESS
POP B ;RECOVER BUFFER COUNT
ORA A ;SET ERROR RETURN FLAGS
JNZ FWERR
;
; WRITE OK
DCR B
RZ ;RETURN IF NO MORE BUFFERS TO WRITE
JMP WBUFF
;
FWERR: ;ERROR IN WRITE
LXI H,ERRFW
CALL PCON ;ERROR MESSAGE OUT
JMP EORC ;TO CLOSE AND REBOOT
;
;
PNB: ;PUT NEXT HEX BYTE
PUSH B
PUSH D
PUSH H
CALL PNBF
POP H
POP D
POP B
RET
;
PNBF: ;PUT NEXT BYTE
; (SIMILAR TO THE PNCF SUBROUTINE)
LHLD HBP
XCHG
LXI H,HBUFF
DAD D
MOV M,A ;CHARACTER STORED AT HBP IN HBUFF
XCHG
INX H ;HBP INCREMENTED
SHLD HBP
XCHG ;BACK TO D,E
LXI H,HSIZE
CALL GCOMP ;EQUAL?
RNZ
;
; OVERFLOW, WRITE BUFFERS
CALL SELH
LXI H,0
SHLD HBP
LXI H,HBUFF
LXI D,HCB ;FILE CONTROL BLOCK FOR HEX FILE
MVI B,NHB
JMP WBUFF ;WRITE BUFFERS
;
PCHAR: ;PRINT CHARACTER IN REGISTER A
PUSH B
PUSH D
PUSH H
MVI C,WRITC
MOV E,A
CALL BDOS
POP H
POP D
POP B
RET
;
WOCHAR: ;WRITE CHARACTER IN REG-A WITH REFLECT AT CONSOLE IF ERROR
MOV C,A ;SAVE THE CHAR
CALL PNC ;PRINT CHAR
LDA QBUFF
CPI ' '
RZ
; ERROR IN LINE
LDA PDISK
CPI 'X'-'A'
RZ ;ALREADY PRINTED IF 'X'
;
MOV A,C ;RECOVER CHARACTER
CALL PCHAR ;PRINT IT
RET
;
WOBUFF: ;WRITE THE OUTPUT BUFFER TO THE PRINT FILE
LDA QBP ;GET CHARACTER COUNT
LXI H,QBUFF ;BASE OF BUFFER
WOB0: ORA A ;ZERO COUNT?
JZ WOBE
; NOT END, SAVE COUNT AND GET CHARACTER
MOV B,A ;SAVE COUNT
MOV A,M
CALL WOCHAR ;WRITE CHARACTER
INX H ;ADDRESS NEXT CHARACTER OF BUFFER
MOV A,B ;GET COUNT
DCR A
JMP WOB0
;
WOBE: ;END OF PRINT - ZERO QBP
STA QBP
; FOLLOW BY CR LF
MVI A,CR
CALL WOCHAR
MVI A,LF
CALL WOCHAR
LXI H,QBUFF
MVI A,QBMAX ;READY TO BLANK OUT
WOB2: MVI M,' '
INX H
DCR A
JNZ WOB2
RET
;
;
PERR: ;FILL QBUFF ERROR MESSAGE POSITION
MOV B,A ;SAVE CHARACTER
LXI H,QBUFF
MOV A,M
CPI ' '
RNZ ;DON'T CHANGE IT IF ALREADY SET
MOV M,B ;STORE ERROR CHARACTER
RET
;
EOR: ;END OF ASSEMBLER
CALL NPR ;Z OR A?
JZ EOPR
; FILL OUTPUT FILES WITH EOF'S
EOR2: LHLD PBP
MOV A,L
ORA H ;VALUE ZERO?
JZ EOPR
MVI A,EOF ;CTL-Z IS END OF FILE
CALL PNC ;PUT ENDFILES IN PRINT BUFFER
JMP EOR2 ;EVENTUALLY BUFFER IS WRITTEN
;
EOPR: ;END OF PRINT FILE, CHECK HEX
LDA HDISK
CPI 'Z'-'A'
JZ EORC
EOR0: ;WRITE TERMINATING RECORD INTO HEX FILE
LDA DBL ;MAY BE ZERO ALREADY
ORA A
CNZ WHEX ;WRITE HEX BUFFER IF NOT ZERO
LHLD FPC ;GET CURRENT FPC AS LAST ADDRESS
SHLD BPC ;RECORD LENGTH ZERO, BASE ADDRESS 0000
CALL WHEX ;WRITE HEX BUFFER
;
; NOW CLEAR OUTPUT BUFFER FOR HEX FILE
EOR1: LHLD HBP
MOV A,L
ORA H
JZ EORC
MVI A,EOF
CALL PNB
JMP EOR1
;
; CLOSE FILES AND TERMINATE
EORC:
CALL NPR
JZ EORPC
CALL SELP
LXI D,PCB
CALL CLOSE
EORPC:
LDA HDISK
CPI 'Z'-'A'
JZ EORHC
CALL SELH
LXI D,HCB
CALL CLOSE
;
EORHC:
LXI H,ENDA
CALL PCON
JMP BOOT
;
TITL: DB 'CP/M ASSEMBLER - VER 1.4',CR
ERROP: DB 'NO SOURCE FILE PRESENT',CR
ERRMA: DB 'NO DIRECTORY SPACE',CR
ERRFN: DB 'SOURCE FILE NAME ERROR',CR
ERRFR: DB 'SOURCE FILE READ ERROR',CR
ERRFW: DB 'OUTPUT FILE WRITE ERROR',CR
ERRCL: DB 'CANNOT CLOSE FILES',CR
ENDA: DB 'END OF ASSEMBLY',CR
;
DHEX: ;DATA TO HEX BUFFER (BYTE IN REG-A)
PUSH B
MOV B,A ;HOLD CHARACTER FOR 'Z' TEST
LDA HDISK
CPI 'Z'-'A'
MOV A,B ;RECOVER CHARACTER
JZ DHRET
PUSH D ;ENVIRONMENT SAVED
PUSH PSW ;SAVE DATA BYTE
LXI H,DBL ;CURRENT LENGTH
MOV A,M ;TO ACCUM
ORA A ;ZERO?
JZ DHEX3
;
; LENGTH NOT ZERO, MAY BE FULL BUFFER
CPI 16
JC DHEX1 ;BR IF LESS THAN 16 BYTES
; BUFFER FULL, DUMP IT
CALL WHEX ;DBL = 0 UPON RETURN
JMP DHEX3 ;SET BPC AND DATA BYTE
;
DHEX1: ;PARTIAL BUFFER IN PROGRESS, CHECK FOR SEQUENTIAL BYTE LOAD
LHLD FPC
XCHG
LHLD BPC ;BASE PC IN H,L
MOV C,A ;CURRENT LENGTH OF BUFFER
MVI B,0 ;IS IN B,C
DAD B ;BPC+DBL TO H,L
MOV A,E ;READY FOR COMPARE
CMP L ;EQUAL?
JNZ DHEX2 ;BR IF NOT
MOV A,D ;CHECK HO BYTE
CMP H
JZ DHEX4 ;BR IF SAME ADDRESS
;
DHEX2: ;NON SEQUENTIAL ADDRESS, DUMP AND CHANGE BASE ADDRESS
CALL WHEX
DHEX3: ;SET NEW BASE
LHLD FPC
SHLD BPC
;
DHEX4: ;STORE DATA BYTE AND INC DBL
LXI H,DBL
MOV E,M ;LENGTH TO REG-E
INR M ;DBL=DBL+1
MVI D,0 ;HIGH ORDER ZERO FOR DOUBLE ADD
LXI H,DBUFF
DAD D ;DBUFF+DBL TO H,L
POP PSW ;RESTORE DATA BYTE
MOV M,A ;INTO DATA BUFFER
POP D
DHRET: POP B ;ENVIRONMENT RESTORED
RET
;
WRC: ;WRITE CHARACTER WITH CHECK SUM IN D
PUSH PSW
RRC
RRC
RRC
RRC
ANI 0FH
CALL HEXC ;OUTPUT HEX CHARACTER
POP PSW ;RESTORE BYTE
PUSH PSW ;SAVE A VERSION
ANI 0FH
CALL HEXC ;WRITE LOW NIBBLE
POP PSW ;RESTORE BYTE
ADD D ;COMPUTE CHECKSUM
MOV D,A ;SAVE CS
RET
;
HEXC: ;WRITE CHARACTER
ADI 90H
DAA
ACI 40H
DAA
JMP PNB ;PUT BYTE
;
WHEX: ;WRITE CURRENT HEX BUFFER
MVI A,':' ;RECORD HEADER
CALL PNB ;PUT BYTE
LXI H,DBL ;RECORD LENGTH ADDRESS
MOV E,M ;LENGTH TO REG-E
XRA A ;ZERO TO REG-A
MOV D,A ;CLEAR CHECKSUM
MOV M,A ;LENGTH IS ZEROED FOR NEXT WRITE
LHLD BPC ;BASE ADDRESS FOR RECORD
MOV A,E ;LENGTH TO A
CALL WRC ;WRITE HEX VALUE
MOV A,H ;HIGH ORDER BASE ADDR
CALL WRC ;WRITE HO BYTE
MOV A,L ;LOW ORDER BASE ADDR
CALL WRC ;WRITE LO BYTE
XRA A ;ZERO TO A
CALL WRC ;WRITE RECORD TYPE 00
MOV A,E ;CHECK FOR LENGTH 0
ORA A
JZ WHEX1
;
; NON - ZERO, WRITE DATA BYTES
LXI H,DBUFF
WHEX0: MOV A,M ;GET BYTE
INX H
CALL WRC ;WRITE DATA BYTE
DCR E ;END OF BUFFER?
JNZ WHEX0
;
; END OF DATA BYTES, WRITE CHECK SUM
WHEX1: XRA A
SUB D ;COMPUTE CHECKSUM
CALL WRC
;
; SEND CRLF AT END OF RECORD
MVI A,CR
CALL PNB
MVI A,LF
CALL PNB
RET
;
;
;
ENDMOD EQU ($ AND 0FFE0H)+20H
END


405
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/AS2SCAN.ASM Normal file
View File

@@ -0,0 +1,405 @@
TITLE 'ASM SCANNER MODULE'
ORG 1100H
JMP ENDMOD ;END OF THIS MODULE
JMP INITS ;INITIALIZE THE SCANNER
JMP SCAN ;CALL THE SCANNER
;
;
; ENTRY POINTS IN I/O MODULE
IOMOD EQU 200H
GNCF EQU IOMOD+6H
WOBUFF EQU IOMOD+15H
PERR EQU IOMOD+18H
;
LASTC: DS 1 ;LAST CHAR SCANNED
NEXTC: DS 1 ;LOOK AHEAD CHAR
STYPE: DS 1 ;RADIX INDICATOR
;
; COMMON EQUATES
PBMAX EQU 120 ;MAX PRINT SIZE
PBUFF EQU 10CH ;PRINT BUFFER
PBP EQU PBUFF+PBMAX ;PRINT BUFFER POINTER
;
TOKEN EQU PBP+1 ;CURRENT TOKEN UDER SCAN
VALUE EQU TOKEN+1 ;VALUE OF NUMBER IN BINARY
ACCLEN EQU VALUE+2 ;ACCUMULATOR LENGTH
ACMAX EQU 64 ;MAX ACCUMULATOR LENGTH
ACCUM EQU ACCLEN+1
;
EVALUE EQU ACCUM+ACMAX ;VALUE FROM EXPRESSION ANALYSIS
;
SYTOP EQU EVALUE+2 ;CURRENT SYMBOL TOP
SYMAX EQU SYTOP+2 ;MAX ADDRESS+1
;
PASS EQU SYMAX+2 ;CURRENT PASS NUMBER
FPC EQU PASS+1 ;FILL ADDRESS FOR NEXT HEX BYTE
ASPC EQU FPC+2 ;ASSEMBLER'S PSEUDO PC
;
; GLOBAL EQUATES
IDEN EQU 1 ;IDENTIFIER
NUMB EQU 2 ;NUMBER
STRNG EQU 3 ;STRING
SPECL EQU 4 ;SPECIAL CHARACTER
;
PLABT EQU 0001B ;PROGRAM LABEL
DLABT EQU 0010B ;DATA LABEL
EQUT EQU 0100B ;EQUATE
SETT EQU 0101B ;SET
MACT EQU 0110B ;MACRO
;
EXTT EQU 1000B ;EXTERNAL
REFT EQU 1011B ;REFER
GLBT EQU 1100B ;GLOBAL
;
BINV EQU 2
OCTV EQU 8
DECV EQU 10
HEXV EQU 16
CR EQU 0DH
LF EQU 0AH
EOF EQU 1AH
TAB EQU 09H ;TAB CHARACTER
;
;
; UTILITY SUBROUTINES
GNC: ;GET NEXT CHARACTER AND ECHO TO PRINT FILE
CALL GNCF
PUSH PSW
CPI CR
JZ GNC0
CPI LF ;IF LF THEN DUMP CURRENT BUFFER
JZ GNC0
;
;NOT A CR OR LF, PLACE INTO BUFFER IF THERE IS ENOUGH ROOM
LDA PBP
CPI PBMAX
JNC GNC0
; ENOUGH ROOM, PLACE INTO BUFFER
MOV E,A
MVI D,0 ;DOUBLE PRECISION PBP IN D,E
INR A
STA PBP ;INCREMENTED PBP IN MEMORY
LXI H,PBUFF
DAD D ;PBUFF(PBP)
POP PSW
MOV M,A ;PBUFF(PBP) = CHAR
RET
GNC0: ;CHAR NOT PLACED INTO BUFFER
POP PSW
RET
;
INITS: ;INITIALIZE THE SCANNER
CALL ZERO
STA NEXTC ;CLEAR NEXT CHARACTER
STA PBP
MVI A,LF ;SET LAST CHAR TO LF
STA LASTC
CALL WOBUFF ;CLEAR BUFFER
MVI A,16 ;START OF PRINT LINE
STA PBP
RET
;
ZERO: XRA A
STA ACCLEN
STA STYPE
RET
;
SAVER: ;STORE THE NEXT CHARACTER INTO THE ACCUMULATOR AND UPDATE ACCLEN
LXI H,ACCLEN
MOV A,M
CPI ACMAX
JC SAV1 ;JUMP IF NOT UP TO LAST POSITION
MVI M,0
CALL ERRO
SAV1: MOV E,M ;D,E WILL HOLD INDEX
MVI D,0
INR M ;ACCLEN INCREMENTED
INX H ;ADDRESS ACCUMULATOR
DAD D ;ADD INDEX TO ACCUMULATOR
LDA NEXTC ;GET CHARACTER
MOV M,A ;INTO ACCUMULATOR
RET
;
TDOLL: ;TEST FOR DOLLAR SIGN, ASSUMING H,L ADDRESS NEXTC
MOV A,M
CPI '$'
RNZ
XRA A ;TO GET A ZERO
MOV M,A ;CLEARS NEXTC
RET ;WITH ZERO FLAG SET
;
NUMERIC: ;CHECK NEXTC FOR NUMERIC, RETURN ZERO FLAG IF NOT NUMERIC
LDA NEXTC
SUI '0'
CPI 10
; CARRY RESET IF NUMERIC
RAL
ANI 1B ;ZERO IF NOT NUMERIC
RET
;
HEX: ;RETURN ZERO FLAG IF NEXTC IS NOT HEXADECIMAL
CALL NUMERIC
RNZ ;RETURNS IF 0-9
LDA NEXTC
SUI 'A'
CPI 6
; CARRY SET IF OUT OF RANGE
RAL
ANI 1B
RET
;
LETTER: ;RETURN ZERO FLAG IF NEXTC IS NOT A LETTER
LDA NEXTC
SUI 'A'
CPI 26
RAL
ANI 1B
RET
;
ALNUM: ;RETURN ZERO FLAG IF NOT ALPHANUMERIC
CALL LETTER
RNZ
CALL NUMERIC
RET
;
TRANS: ;TRANSLATE TO UPPER CASE
LDA NEXTC
CPI 'A' OR 1100000B ;LOWER CASE A
RC ;CARRY IF LESS THAN LOWER A
CPI ('Z' OR 1100000B)+1 ;LOWER CASE Z
RNC ;NO CARRY IF GREATER THAN LOWER Z
ANI 1011111B ;CONVERT TO UPPER CASE
STA NEXTC
RET
;
GNCN: ;GET CHARACTER AND STORE TO NEXTC
CALL GNC
STA NEXTC
CALL TRANS ;TRANSLATE TO UPPER CASE
RET
;
EOLT: ;END OF LINE TEST FOR COMMENT SCAN
CPI CR
RZ
CPI EOF
RZ
CPI '!'
RET
;
SCAN: ;FIND NEXT TOKEN IN INPUT STREAM
XRA A
STA TOKEN
CALL ZERO
;
; DEBLANK
DEBL: LDA NEXTC
CPI TAB ;TAB CHARACTER TREATED AS BLANK OUTSIDE STRING
JZ DEB0
CPI ';' ;MAY BE A COMMENT
JZ DEB1 ;DEBLANK THROUGH COMMENT
CPI '*' ;PROCESSOR TECH COMMENT
JNZ DEB2 ;NOT *
LDA LASTC
CPI LF ;LAST LINE FEED?
JNZ DEB2 ;NOT LF*
; COMMENT FOUND, REMOVE IT
DEB1: CALL GNCN
CALL EOLT ;CR, EOF, OR !
JZ FINDL ;HANDLE END OF LINE
JMP DEB1 ;OTHERWISE CONTINUE SCAN
DEB2: ORI ' ' ;MAY BE ZERO
CPI ' '
JNZ FINDL
DEB0: CALL GNCN ;GET NEXT AND STORE TO NEXTC
JMP DEBL
;
; LINE DEBLANKED, FIND TOKEN TYPE
FINDL: ;LOOK FOR LETTER, DECIMAL DIGIT, OR STRING QUOTE
CALL LETTER
JZ FIND0
MVI A,IDEN
JMP STOKEN
;
FIND0: CALL NUMERIC
JZ FIND1
MVI A,NUMB
JMP STOKEN
;
FIND1: LDA NEXTC
CPI ''''
JNZ FIND2
XRA A
STA NEXTC ;DON'T STORE THE QUOTE
MVI A,STRNG
JMP STOKEN
;
FIND2: ;ASSUME IT IS A SPECIAL CHARACTER
CPI LF ;IF LF THEN DUMP THE BUFFER
JNZ FIND3
; LF FOUND
LDA PASS
ORA A
CNZ WOBUFF
LXI H,PBUFF ;CLEAR ERROR CHAR ON BOTH PASSES
MVI M,' '
MVI A,16
STA PBP ;START NEW LINE
FIND3: MVI A,SPECL
;
STOKEN: STA TOKEN
;
;
; LOOP WHILE CURRENT ITEM IS ACCUMULATING
SCTOK: LDA NEXTC
STA LASTC ;SAVE LAST CHARACTER
ORA A
CNZ SAVER ;STORE CHARACTER INTO ACCUM IF NOT ZERO
CALL GNCN ;GET NEXT TO NEXTC
LDA TOKEN
CPI SPECL
RZ ;RETURN IF SPECIAL CHARACTER
CPI STRNG
CNZ TRANS ;TRANSLATE TO UPPER CASE IF NOT IN STRING
LXI H,NEXTC
LDA TOKEN
;
CPI IDEN
JNZ SCT2
;
; ACCUMULATING AN IDENTIFIER
CALL TDOLL ;$?
JZ SCTOK ;IF SO, SKIP IT
CALL ALNUM ;ALPHA NUMERIC?
RZ ;RETURN IF END
; NOT END OF THE IDENTIFIER
JMP SCTOK
;
SCT2: ;NOT SPECIAL OR IDENT, CHECK NUMBER
CPI NUMB
JNZ SCT3
;
; ACCUMULATING A NUMBER, CHECK FOR $
CALL TDOLL
JZ SCTOK ;SKIP IF FOUND
CALL HEX ;HEX CHARACTER?
JNZ SCTOK ;STORE IT IF FOUND
; END OF NUMBER, LOOK FOR RADIX INDICATOR
;
LDA NEXTC
CPI 'O' ;OCTAL INDICATOR
JZ NOCT
CPI 'Q' ;OCTAL INDICATOR
JNZ NUM2
;
NOCT: ;OCTAL
MVI A,OCTV
JMP SSTYP
;
NUM2: CPI 'H'
JNZ NUM3
MVI A,HEXV
SSTYP: STA STYPE
XRA A
STA NEXTC ;CLEARS THE LOOKAHEAD CHARACTER
JMP NCON
;
; RADIX MUST COME FROM ACCUM
NUM3: LDA LASTC
CPI 'B'
JNZ NUM4
MVI A,BINV
JMP SSTY1
;
NUM4: CPI 'D'
MVI A,DECV
JNZ SSTY2
SSTY1: LXI H,ACCLEN
DCR M ;ACCLEN DECREMENTED TO REMOVE RADIX INDICATOR
SSTY2: STA STYPE
;
NCON: ;NUMERIC CONVERSION OCCURS HERE
LXI H,0
SHLD VALUE ;VALUE ACCUMULATES BINARY EQUIVALENT
LXI H,ACCLEN
MOV C,M ;C=ACCLEN
INX H ;ADDRESSES ACCUM
CLOP: ;NEXT DIGIT IS PROCESSED HERE
MOV A,M
INX H ;READY FOR NEXT LOOP
CPI 'A'
JNC CLOP1 ;NOT HEX A-F
SUI '0' ;NORMALIZE
JMP CLOP2
;
CLOP1: ;HEX A-F
SUI 'A'-10
CLOP2: ;CHECK SIZE AGAINST RADIX
PUSH H ;SAVE ACCUM ADDR
PUSH B ;SAVE CURRENT POSITION
MOV C,A
LXI H,STYPE
CMP M
CNC ERRV ;VALUE ERROR IF DIGIT>=RADIX
MVI B,0 ;DOUBLE PRECISION DIGIT
MOV A,M ;RADIX TO ACCUMULATOR
LHLD VALUE
XCHG ;VALUE TO D,E - ACCUMULATE RESULT IN H,L
LXI H,0 ;ZERO ACCUMULATOR
CLOP3: ;LOOP UNTIL RADIX GOES TO ZERO
ORA A
JZ CLOP4
RAR ;TEST LSB
JNC TTWO ;SKIP SUMMING OPERATION IF LSB=0
DAD D ;ADD IN VALUE
TTWO: ;MULTIPLY VALUE * 2 FOR SHL OPERATION
XCHG
DAD H
XCHG
JMP CLOP3
;
;
CLOP4: ;END OF NUMBER CONVERSION
DAD B ;DIGIT ADDED IN
SHLD VALUE
POP B
POP H
DCR C ;MORE DIGITS?
JNZ CLOP
RET ;DONE WITH THE NUMBER
;
SCT3: ;MUST BE A STRING
LDA NEXTC
CPI CR ;END OF LINE?
JZ ERRO ;AND RETURN
CPI ''''
JNZ SCTOK
CALL GNCN
CPI ''''
RNZ ;RETURN IF SINGLE QUOTE ENCOUNTERED
JMP SCTOK ;OTHERWISE TREAT AS ONE QUOTE
;
; END OF SCANNER
;
; ERROR MESSAGE ROUTINES
ERRV: ;'V' VALUE ERROR
PUSH PSW
MVI A,'V'
JMP ERR
;
ERRO: ;'O' OVERFLOW ERROR
PUSH PSW
MVI A,'O'
JMP ERR
;
ERR: ;PRINT ERROR MESSAGE
PUSH B
PUSH H
CALL PERR
POP H
POP B
POP PSW
RET
;
ENDMOD EQU ($ AND 0FFE0H) + 20H
END


382
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/AS3SYM.ASM Normal file
View File

@@ -0,0 +1,382 @@
TITLE 'ASM SYMBOL TABLE MODULE'
; SYMBOL TABLE MANIPULATION MODULE
;
ORG 1340H
IOMOD EQU 200H ;IO MODULE ENTRY POINT
PCON EQU IOMOD+12H
EOR EQU IOMOD+1EH
;
;
; ENTRY POINTS TO SYMBOL TABLE MODULE
JMP ENDMOD
JMP INISY
JMP LOOKUP
JMP FOUND
JMP ENTER
JMP SETTY
JMP GETTY
JMP SETVAL
JMP GETVAL
;
; COMMON EQUATES
PBMAX EQU 120 ;MAX PRINT SIZE
PBUFF EQU 10CH ;PRINT BUFFER
PBP EQU PBUFF+PBMAX ;PRINT BUFFER POINTER
;
TOKEN EQU PBP+1 ;CURRENT TOKEN UDER SCAN
VALUE EQU TOKEN+1 ;VALUE OF NUMBER IN BINARY
ACCLEN EQU VALUE+2 ;ACCUMULATOR LENGTH
ACMAX EQU 64 ;MAX ACCUMULATOR LENGTH
ACCUM EQU ACCLEN+1
;
EVALUE EQU ACCUM+ACMAX ;VALUE FROM EXPRESSION ANALYSIS
;
SYTOP EQU EVALUE+2 ;CURRENT SYMBOL TOP
SYMAX EQU SYTOP+2 ;MAX ADDRESS+1
;
PASS EQU SYMAX+2 ;CURRENT PASS NUMBER
FPC EQU PASS+1 ;FILL ADDRESS FOR NEXT HEX BYTE
ASPC EQU FPC+2 ;ASSEMBLER'S PSEUDO PC
SYBAS EQU ASPC+2 ;BASE OF SYMBOL TABLE
SYADR EQU SYBAS+2 ;CURRENT SYMBOL BEING ACCESSED
;
; GLOBAL EQUATES
IDEN EQU 1 ;IDENTIFIER
NUMB EQU 2 ;NUMBER
STRNG EQU 3 ;STRING
SPECL EQU 4 ;SPECIAL CHARACTER
;
PLABT EQU 0001B ;PROGRAM LABEL
DLABT EQU 0010B ;DATA LABEL
EQUT EQU 0100B ;EQUATE
SETT EQU 0101B ;SET
MACT EQU 0110B ;MACRO
;
EXTT EQU 1000B ;EXTERNAL
REFT EQU 1011B ;REFER
GLBT EQU 1100B ;GLOBAL
;
;
CR EQU 0DH
;
; DATA AREAS
; SYMBOL TABLE BEGINS AT THE END OF THIS MODULE
FIXD EQU 5 ;5 BYTES OVERHEAD WITH EACH SYMBOL ENTRY
; 2BY COLLISION, 1BY TYPE/LEN, 2BY VALUE
HSIZE EQU 128 ;HASH TABLE SIZE
HMASK EQU HSIZE-1 ;HASH MASK FOR CODING
HASHT: DS HSIZE*2 ;HASH TABLE
HASHC: DS 1 ;HASH CODE AFTER CALL ON LOOKUP
;
; SYMBOL TABLE ENTRY FORMAT IS
; -----------------
; : HIGH VAL BYTE :
; -----------------
; : LOW VAL BYTE :
; -----------------
; : CHARACTER N :
; -----------------
; : ... :
; -----------------
; : CHARACTER 1 :
; -----------------
; : TYPE : LENG :
; -----------------
; : HIGH COLLISION:
; -----------------
; SYADR= : LOW COLLISION :
; -----------------
;
; WHERE THE LOW/HIGH COLLISION FIELD ADDRESSES ANOTHER ENTRY WITH
; THE SAME HASH CODE (OR ZERO IF THE END OF CHAIN), TYPE DESCRIBES
; THE ENTRY TYPE (GIVEN BELOW), LENG IS THE NUMBER OF CHARACTERS IN
; THE SYMBOL PRINTNAME -1 (I.E., LENG=0 IS A SINGLE CHARACTER PRINT-
; NAME, WHILE LENG=15 INDICATES A 16 CHARACTER NAME). CHARACTER 1
; THROUGH N GIVE THE PRINTNAME CHARACTERS IN ASCII UPPER CASE (ALL
; LOWER CASE NAMES ARE TRANSLATED ON INPUT), AND THE LOW/HIGH VALUE
; GIVE THE PARTICULAR ADDRESS OR CONSTANT VALUE ASSOCIATED WITH THE
; NAME. THE REPRESENTATION OF MACROS DIFFERS IN THE FIELDS WHICH
; FOLLOW THE VALUE FIELD (MACROS ARE NOT CURRENTLY IMPLEMENTED).
;
; THE TYPE FIELD CONSISTS OF FOUR BITS WHICH ARE ASSIGNED AS
; FOLLOWS:
;
; 0000 UNDEFINED SYMBOL
; 0001 LOCAL LABELLED PROGRAM
; 0010 LOCAL LABELLED DATA
; 0011 (UNUSED)
; 0100 EQUATE
; 0101 SET
; 0110 MACRO
; 0111 (UNUSED)
;
; 1000 (UNUSED)
; 1001 EXTERN LABELLED PROGRAM
; 1010 EXTERN LABELLED DATA
; 1011 REFERENCE TO MODULE
; 1100 (UNUSED)
; 1101 GLOBAL UNDEFINED SYMBOL
; 1110 GLOBAL LABELLED PROGRAM
; 1111 (UNUSED)
;
; TYPE DEFINITIONS
;
PLABT EQU 0001B ;PROGRAM LABEL
DLABT EQU 0010B ;DATA LABEL
EQUT EQU 0100B ;EQUATE
SETT EQU 0101B ;SET
MACT EQU 0110B ;MACRO
;
EXTT EQU 1000B ;EXTERNAL ATTRIBUTE
REFT EQU 1011B ;REFER
GLBT EQU 1100B ;GLOBAL ATTRIBUTE
;
;
INISY: ;INITIALIZE THE SYMBOL TABLE
LXI H,HASHT ;ZERO THE HASH TABLE
MVI B,HSIZE
XRA A ;CLEAR ACCUM
INI0:
MOV M,A
INX H
MOV M,A ;CLEAR DOUBLE WORD
INX H
DCR B
JNZ INI0
;
; SET SYMBOL TABLE POINTERS
LXI H,0
SHLD SYADR
;
RET
;
CHASH: ;COMPUTE HASH CODE FOR CURRENT ACCUMULATOR
LXI H,ACCLEN
MOV B,M ;GET ACCUM LENGTH
XRA A ;CLEAR ACCUMULATOR
CH0: INX H ;MOVE TO FIRST/NEXT CHARACTER POSITION
ADD M ;ADD WITH OVERFLOW
DCR B
JNZ CH0
ANI HMASK ;MASK BITS FOR MODULO HZISE
STA HASHC ;FILL HASHC WITH RESULT
RET
;
SETLN: ;SET THE LENGTH FIELD OF THE CURRENT SYMBOL
MOV B,A ;SAVE LENGTH IN B
LHLD SYADR
INX H
INX H
MOV A,M ;GET TYPE/LENGTH FIELD
ANI 0F0H ;MASK OUT TYPE FIELD
ORA B ;MASK IN LENGTH
MOV M,A
RET
;
GETLN: ;GET THE LENGTH FIELD TO REG-A
LHLD SYADR
INX H
INX H
MOV A,M
ANI 0FH
INR A ;LENGTH IS STORED AS VALUE - 1
RET
;
FOUND: ;FOUND RETURNS TRUE IF SYADR IS NOT ZERO (TRUE IS NZ FLAG HERE)
LHLD SYADR
MOV A,L
ORA H
RET
;
LOOKUP: ;LOOK FOR SYMBOL IN ACCUMULATOR
CALL CHASH ;COMPUTE HASH CODE
; NORMALIZE IDENTIFIER TO 16 CHARACTERS
LXI H,ACCLEN
MOV A,M
CPI 17
JC LENOK
MVI M,16
LENOK:
; LOOK FOR SYMBOL THROUGH HASH TABLE
LXI H,HASHC
MOV E,M
MVI D,0 ;DOUBLE HASH CODE IN D,E
LXI H,HASHT ;BASE OF HASH TABLE
DAD D
DAD D ;HASHT(HASHC)
MOV E,M ;LOW ORDER ADDRESS
INX H
MOV H,M
MOV L,E ;HEADER TO LIST OF SYMBOLS IS IN H,L
LOOK0: SHLD SYADR
CALL FOUND
RZ ;RETURN IF SYADR BECOMES ZERO
;
; OTHERWISE EXAMINE CHARACTER STRING FOR MATCH
CALL GETLN ;GET LENGTH TO REG-A
LXI H,ACCLEN
CMP M
JNZ LCOMP
;
; LENGTH MATCH, TRY TO MATCH CHARACTERS
MOV B,A ;STRING LENGTH IN B
INX H ;HL ADDRESSES ACCUM
XCHG ;TO D,E
LHLD SYADR
INX H
INX H
INX H ;ADDRESSES CHARACTERS
LOOK1: LDAX D ;NEXT CHARACTER FROM ACCUM
CMP M ;NEXT CHARACTER IN SYMBOL TABLE
JNZ LCOMP
; CHARACTER MATCHED, INCREMENT TO NEXT
INX D
INX H
DCR B
JNZ LOOK1
;
; COMPLETE MATCH AT CURRENT SYMBOL, SYADR IS SET
RET
;
LCOMP: ;NOT FOUND, MOVE SYADR DOWN ONE COLLISION ADDRESS
LHLD SYADR
MOV E,M
INX H
MOV D,M ;COLLISION ADDRESS IN D,E
XCHG
JMP LOOK0
;
;
ENTER: ;ENTER SYMBOL IN ACCUMULATOR
; ENSURE THERE IS ENOUGH SPACE IN THE TABLE
LXI H,ACCLEN
MOV E,M
MVI D,0 ;DOUBLE PRECISION ACCLEN IN D,E
LHLD SYTOP
SHLD SYADR ;NEXT SYMBOL LOCATION
DAD D ;SYTOP+ACCLEN
LXI D,FIXD ;FIXED DATA/SYMBOL
DAD D ;HL HAS NEXT TABLE LOCATION FOR SYMBOL
XCHG ;NEW SYTOP IN D,E
LHLD SYMAX ;MAXIMUM SYMTOP VALUE
MOV A,E
SUB L ;COMPUTE 16-BIT DIFFERENCE
MOV A,D
SBB H
XCHG ;NEW SYTOP IN H,L
JNC OVERER ;OVERFLOW IN TABLE
;
; OTHERWISE NO ERROR
SHLD SYTOP ;SET NEW TABLE TOP
LHLD SYADR ;SET COLLISION FIELD
XCHG ;CURRENT SYMBOL ADDRESS TO D,E
LXI H,HASHC ;HASH CODE FOR CURRENT SYMBOL TO H,L
MOV C,M ;LOW BYTE
MVI B,0 ;DOUBLE PRECISION VALUE IN B,C
LXI H,HASHT ;BASE OF HASH TABLE
DAD B
DAD B ;HASHT(HASHC) IN H,L
; D,E ADDRESSES CURRENT SYMBOL - CHANGE LINKS
MOV C,M ;LOW ORDER OLD HEADER
INX H
MOV B,M ;HIGH ORDER OLD HEADER
MOV M,D ;HIGH ORDER NEW HEADER TO HASH TABLE
DCX H
MOV M,E ;LOW ORDER NEW HEADER TO HASH TABLE
XCHG ;H,L HOLDS SYMBOL TABLE ADDRESS
MOV M,C ;LOW ORDER OLD HEADER TO COLLISION FIELD
INX H
MOV M,B ;HIGH ORDER OLD HEADER TO COLLISION FIELD
;
; HASH CHAIN NOW REPAIRED FOR THIS ENTRY, COPY THE PRINTNAME
LXI D,ACCLEN
LDAX D ;GET SYMBOL LENGTH
CPI 17 ;LARGER THAN 16 SYMBOLS?
JC ENT1
MVI A,16 ;TRUNCATE TO 16 CHARACTERS
; COPY LENGTH FIELD, FOLLOWED BY PRINTNAME CHARACTERS
ENT1: MOV B,A ;COPY LENGTH TO B
DCR A ;1-16 CHANGED TO 0-15
INX H ;FOLLOWING COLLISION FIELD
MOV M,A ;STORE LENGTH WITH UNDEFINED TYPE (0000)
ENT2: INX H
INX D
LDAX D
MOV M,A ;STORE NEXT CHARACTER OF PRINTNAME
DCR B ;LENGTH=LENGTH-1
JNZ ENT2 ;FOR ANOTHER CHARACTER
;
; PRINTNAME COPIED, ZERO THE VALUE FIELD
XRA A ;ZERO A
INX H ;LOW ORDER VALUE
MOV M,A
INX H
MOV M,A ;HIGH ORDER VALUE
RET
;
OVERER: ;OVERFLOW IN SYMBOL TABLE
LXI H,ERRO
CALL PCON
JMP EOR ;END OF EXECUTION
ERRO: DB 'SYMBOL TABLE OVERFLOW',CR
;
SETTY: ;SET CURRENT SYMBOL TYPE TO VALUE IN REG-A
RAL
RAL
RAL
RAL
ANI 0F0H ;TYPE MOVED TO HIGH ORDER 4-BITS
MOV B,A ;SAVE IT IN B
LHLD SYADR ;BASE OF SYMBOL TO ACCESS
INX H
INX H ;ADDRESS OF TYPE/LENGTH FIELD
MOV A,M ;GET IT AND MASK
ANI 0FH ;LEAVE LENGTH
ORA B ;MASK IN TYPE
MOV M,A ;STORE IT
RET
;
GETTY: ;RETURN THE TYPE OF THE VALUE IN CURRENT SYMBOL
LHLD SYADR
INX H
INX H
MOV A,M
RAR
RAR
RAR
RAR
ANI 0FH ;TYPE MOVED TO LOW 4-BITS OF REG-A
RET
;
VALADR: ;GET VALUE FIELD ADDRESS FOR CURRENT SYMBOL
CALL GETLN ;PRINTNAME LENGTH TO ACCUM
LHLD SYADR ;BASE ADDRESS
MOV E,A
MVI D,0
DAD D ;BASE(LEN)
INX H
INX H ;FOR COLLISION FIELD
INX H ;FOR TYPE/LEN FIELD
RET ;WITH H,L ADDRESSING VALUE FIELD
;
SETVAL: ;SET THE VALUE FIELD OF THE CURRENT SYMBOL
; VALUE IS SENT IN H,L
PUSH H ;SAVE VALUE TO SET
CALL VALADR
POP D ;POP VALUE TO SET, HL HAS ADDRESS TO FILL
MOV M,E
INX H
MOV M,D ;FIELD SET
RET
;
GETVAL: ;GET THE VALUE FIELD OF THE CURRENT SYMBOL TO H,L
CALL VALADR ;ADDRESS OF VALUE FIELD TO H,L
MOV E,M
INX H
MOV D,M
XCHG
RET
;
ENDMOD EQU ($ AND 0FFE0H) + 20H
END


415
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/AS4SEAR.ASM Normal file
View File

@@ -0,0 +1,415 @@
TITLE 'ASM TABLE SEARCH MODULE'
ORG 15A0H
JMP ENDMOD ;TO NEXT MODULE
JMP BSEAR
JMP BGET
;
; COMMON EQUATES
PBMAX EQU 120 ;MAX PRINT SIZE
PBUFF EQU 10CH ;PRINT BUFFER
PBP EQU PBUFF+PBMAX ;PRINT BUFFER POINTER
;
TOKEN EQU PBP+1 ;CURRENT TOKEN UDER SCAN
VALUE EQU TOKEN+1 ;VALUE OF NUMBER IN BINARY
ACCLEN EQU VALUE+2 ;ACCUMULATOR LENGTH
ACMAX EQU 64 ;MAX ACCUMULATOR LENGTH
ACCUM EQU ACCLEN+1
;
EVALUE EQU ACCUM+ACMAX ;VALUE FROM EXPRESSION ANALYSIS
;
SYTOP EQU EVALUE+2 ;CURRENT SYMBOL TOP
SYMAX EQU SYTOP+2 ;MAX ADDRESS+1
;
PASS EQU SYMAX+2 ;CURRENT PASS NUMBER
FPC EQU PASS+1 ;FILL ADDRESS FOR NEXT HEX BYTE
ASPC EQU FPC+2 ;ASSEMBLER'S PSEUDO PC
;
; GLOBAL EQUATES
IDEN EQU 1 ;IDENTIFIER
NUMB EQU 2 ;NUMBER
STRNG EQU 3 ;STRING
SPECL EQU 4 ;SPECIAL CHARACTER
;
PLABT EQU 0001B ;PROGRAM LABEL
DLABT EQU 0010B ;DATA LABEL
EQUT EQU 0100B ;EQUATE
SETT EQU 0101B ;SET
MACT EQU 0110B ;MACRO
;
EXTT EQU 1000B ;EXTERNAL
REFT EQU 1011B ;REFER
GLBT EQU 1100B ;GLOBAL
;
;
CR EQU 0DH ;CARRIAGE RETURN
;
;
; TABLE DEFINITIONS
;
; TYPES
XBASE EQU 0 ;START OF OPERATORS
; O1 THROUGH O15 DENOTE OPERATIONS
RT EQU 16
PT EQU RT+1 ;RT IS REGISTER TYPE, PT IS PSEUDO OPERATION
OBASE EQU PT+1
O1 EQU OBASE+1 ;SIMPLE
O2 EQU OBASE+2 ;LXI
O3 EQU OBASE+3 ;DAD
O4 EQU OBASE+4 ;PUSH/POP
O5 EQU OBASE+5 ;JMP/CALL
O6 EQU OBASE+6 ;MOV
O7 EQU OBASE+7 ;MVI
O8 EQU OBASE+8 ;ACC IMMEDIATE
O9 EQU OBASE+9 ;LDAX/STAX
O10 EQU OBASE+10 ;LHLD/SHLD/LDA/STA
O11 EQU OBASE+11 ;ACCUM REGISTER
O12 EQU OBASE+12 ;INC/DEC
O13 EQU OBASE+13 ;INX/DCX
O14 EQU OBASE+14 ;RST
O15 EQU OBASE+15 ;IN/OUT
;
; X1 THROUGH X15 DENOTE OPERATORS
X1 EQU XBASE ;*
X2 EQU XBASE+1 ;/
X3 EQU XBASE+2 ;MOD
X4 EQU XBASE+3 ;SHL
X5 EQU XBASE+4 ;SHR
X6 EQU XBASE+5 ;+
X7 EQU XBASE+6 ;-
X8 EQU XBASE+7 ;UNARY -
X9 EQU XBASE+8 ;NOT
X10 EQU XBASE+9 ;AND
X11 EQU XBASE+10;OR
X12 EQU XBASE+11;XOR
X13 EQU XBASE+12;(
X14 EQU XBASE+13;)
X15 EQU XBASE+14;,
X16 EQU XBASE+15;CR
;
;
;
;
; RESERVED WORD TABLES
;
; BASE ADDRESS VECTOR FOR CHARACTERS
CINX: DW CHAR1 ;LENGTH 1 BASE
DW CHAR2 ;LENGTH 2 BASE
DW CHAR3 ;LENGTH 3 BASE
DW CHAR4 ;LENGTH 4 BASE
DW CHAR5 ;LENGTH 5 BASE
DW CHAR6 ;LENGTH 6 BASE
;
CMAX EQU ($-CINX)/2-1 ;LARGEST STRING TO MATCH
;
CLEN: ;LENGTH VECTOR GIVES THE NUMBER OF ITEMS IN EACH TABLE
DB CHAR2-CHAR1
DB (CHAR3-CHAR2)/2
DB (CHAR4-CHAR3)/3
DB (CHAR5-CHAR4)/4
DB (CHAR6-CHAR5)/5
;
TVINX: ;TABLE OF TYPE,VALUE PAIRS FOR EACH RESERVED SYMBOL
DW TV1
DW TV2
DW TV3
DW TV4
DW TV5
;
; CHARACTER VECTORS FOR 1,2,3,4, AND 5 CHARACTER NAMES
CHAR1: DB CR,'()*'
DB '+'
DB ',-/A'
DB 'BCDE'
DB 'HLM'
;
CHAR2: DB 'DBDIDSDW'
DB 'EIIFINOR'
DB 'SP'
;
CHAR3: DB 'ACIADCADDADI'
DB 'ANAANDANICMA'
DB 'CMCCMPCPIDAA'
DB 'DADDCRDCXEND'
DB 'EQUHLTINRINX'
DB 'JMPLDALXIMOD'
DB 'MOVMVINOPNOT'
DB 'ORAORGORIOUT'
DB 'POPPSWRALRAR'
DB 'RETRLCRRCRST'
DB 'SBBSBISETSHL'
DB 'SHRSTASTCSUB'
DB 'SUIXORXRAXRI'
;
CHAR4: DB 'CALLENDMLDAXLHLDPCHL'
DB 'PUSHSHLDSPHLSTAX'
DB 'XCHGXTHL'
;
CHAR5: DB 'ENDIFMACROTITLE'
;
CHAR6: ;END OF CHARACTER VECTOR
;
TV1: ;TYPE,VALUE PAIRS FOR CHAR1 VECTOR
DB X16,10, X13,20 ;CR (
DB X14,30, X1,80 ;) *
DB X6,70 ;+
DB X15,10, X7,70 ;, -
DB X2,80, RT,7 ;/ A
DB RT,0, RT,1 ;B C
DB RT,2, RT,3 ;D E
DB RT,4, RT,5 ;H L
DB RT,6 ;M
;
TV2: ;TYPE,VALUE PAIRS FOR CHAR2 VECTOR
DB PT,1, O1,0F3H ;DB DI
DB PT,2, PT,3 ;DS DW
DB O1,0FBH, PT,8 ;EI IF
DB O15,0DBH, X11,40 ;IN OR
DB RT,6 ;SP
;
;
TV3: ;TYPE,VALUE PAIRS FOR CHAR3 VECTOR
DB O8,0CEH, O11,88H ;ACI ADC
DB O11,80H, O8,0C6H ;ADD ADI
DB O11,0A0H, X10,50 ;ANA AND
DB O8,0E6H, O1,2FH ;ANI CMA
DB O1,3FH, O11,0B8H ;CMC CMP
DB O8,0FEH, O1,27H ;CPI DAA
DB O3,09H, O12,05H ;DAD DCR
DB O13,0BH, PT,4 ;DCX END
DB PT,7, O1,76H ;EQU HLT
DB O12,04H, O13,03H ;INR INX
DB O5,0C3H, O10,3AH ;JMP LDA
DB O2,01H, X3,80 ;LXI MOD
DB O6,40H, O7,06H ;MOV MVI
DB O1,00H, X9,60 ;NOP NOT
DB O11,0B0H, PT,10 ;ORA ORG
DB O8,0F6H, O15,0D3H ;ORI OUT
DB O4,0C1H, RT,6 ;POP PSW
DB O1,17H, O1,1FH ;RAL RAR
DB O1,0C9H, O1,07H ;RET RLC
DB O1,0FH, O14,0C7H ;RRC RST
DB O11,098H, O8,0DEH ;SBB SBI
DB PT,11, X4,80 ;SET SHL
DB X5,80, O10,32H ;STA STC
DB O1,37H, O11,90H ;STC SUB
DB O8,0D6H, X12,40 ;SUI XOR
DB O11,0A8H, O8,0EEH ;XRA XRI
;
;
TV4: ;TYPE,VALUE PAIRS FOR CHAR4 VECTOR
DB O5,0CDH ;CALL
DB PT,6, O9,0AH ;ENDM LDAX
DB O10,02AH, O1,0E9H ;LHLD PCHL
DB O4,0C5H, O10,22H ;PUSH SHLD
DB O1,0F9H, O9,02H ;SPHL STAX
DB O1,0EBH, O1,0E3H ;XCHG XTHL
;
TV5: ;TYPE,VALUE PAIRS FOR CHAR5 VECTOR
DB PT,5, PT,9 ;ENDIF MACRO
DB PT,12 ;TITLE
;
SUFTAB: ;TABLE OF SUFFIXES FOR J C AND R OPERATIONS
DB 'NZZ NCC POPEP M '
;
BSEAR: ;BINARY SEARCH MNEMONIC TABLE
; INPUT: UR = UPPER BOUND OF TABLE (I.E., TABLE LENGTH-1)
; SR = SIZE OF EACH TABLE ELEMENT
; H,L ADDRESS BASE OF TABLE TO SEARCH
; OUTPUT: ZERO FLAG INDICATES MATCH WAS FOUND, IN WHICH CASE
; THE ACCUMULATOR CONTAINS AN INDEX TO THE ELEMENT
; NOT ZERO FLAG INDICATES NO MATCH FOUND IN TABLE
;
UR EQU B ;UPPER BOUND REGISTER
LR EQU C ;LOWER BOUND REGISTER
SR EQU D ;SIZE REGISTER
MR EQU E ;MIDDLE POINTER REGISTER
SP1 EQU B ;SIZE PRIME, USED IN COMPUTING MIDDLE POSITON
SP1P EQU C ;ANOTHER COPY OF SIZE PRIME
KR EQU H ;K
;
MVI MR,255 ;MARK M <> OLD M
INR UR ;U=U+1
MVI LR,0 ;L = 0
;
; COMPUTE M' = (U+L)/2
NEXT: XRA A
MOV A,UR ;CY=0, A=U
ADD LR ;(U+L)
RAR ;(U+L)/2
CMP MR ;SAME AS LAST TIME THROUGH?
JZ NMATCH ;JUMP IF = TO NO MATCH
;
; MORE ELEMENTS TO SCAN
MOV MR,A ;NEW MIDDLE VALUE
PUSH H ;SAVE A COPY OF THE BASE ADDRESS
PUSH D ;SAVE S,M
PUSH B ;SAVE U,L
PUSH H ;SAVE ANOTHER COPY OF THE BASE ADDRESS
MOV SP1,SR ;S' = S
MOV SP1P,SP1 ;S'' = S'
MVI SR,0 ;FOR DOUBLE ADD OPERATION BELOW (DOUBLE M)
;
LXI KR,0 ;K=0
SUMK: DAD D ;K = K + M
DCR SP1 ;S' = S' - 1
JNZ SUMK ;DECREMENT IF SP1 <> 0
;
; K IS NOW RELATIVE BYTE POSITION
POP D ;TABLE BASE ADDRESS
DAD D ;H,L CONTAINS ABSOLUTE ADDRESS OF BYTE TO COMPARE
LXI D,ACCUM ;D,E ADDRESS CHARACTERS TO COMPARE
;
COMK: ;COMPARE NEXT CHARACTER
LDAX D ;ACCUM CHARACTER TO REG A
CMP M ;SAME AS TABLE ENTRY?
INX D
INX H ;TO NEXT POSITIONS
JNZ NCOM ;JUMP IF NOT THE SAME
DCR SP1P ;MORE CHARACTERS?
JNZ COMK
;
; COMPLETE MATCH AT M
POP B
POP D ;M RESTORED
POP H
MOV A,MR ;VALUE OF M COPIED IN A
RET ;WITH ZERO FLAG SET
;
NCOM: ;NO MATCH, DETERMINE IF LESS OR GREATER
POP B ;U,L
POP D ;S,M
POP H ;TABLE ADDRESS
JC NCOML
; ACCUM IS HIGHER
MOV LR,MR ;L = M
JMP NEXT
;
NCOML: ;ACCUMULATOR IS LOW
MOV UR,MR ;U = M
JMP NEXT
;
NMATCH: ;NO MATCH
XRA A
INR A ;SETS NOT ZERO FLAG
RET
;
PREFIX: ;J C OR R PREFIX?
LDA ACCUM
LXI B,(0C2H SHL 8) OR O5 ;JNZ OPCODE TO B, TYPE TO C
CPI 'J'
RZ ;RETURN WITH ZERO FLAG SET IF J
MVI B,0C4H ;CNZ OPCODE TO B, TYPE IS IN C
CPI 'C'
RZ
LXI B,(0C0H SHL 8) OR O1 ;RNZ OPCODE
CPI 'R'
RET
;
SUFFIX: ;J R OR C RECOGNIZED, LOOK FOR SUFFIX
LDA ACCLEN
CPI 4 ;CHECK LENGTH
JNC NSUFF ;CARRY IF 0,1,2,3 IN LENGTH
CPI 3
JZ SUF0 ;ASSUME 1 OR 2 IF NO BRANCH
CPI 2
JNZ NSUFF ;RETURNS IF 0 OR 1
LXI H,ACCUM+2
MVI M,' ' ;BLANK-OUT FOR MATCH ATTEMPT
SUF0: ;SEARCH 'TIL END OF TABLE
LXI B,8 ;B=0, C=8 COUNTS TABLE DOWN TO ZERO OR MATCH
LXI D,SUFTAB
NEXTS: ;LOOK AT NEXT SUFFIX
LXI H,ACCUM+1 ;SUFFIX POSITION
LDAX D ;CHARACTER TO ACCUM
CMP M
INX D ;READY FOR NEXT CHARACTER
JNZ NEXT0 ;JMP IF NO MATCH
LDAX D ;GET NEXT CHARACTER
INX H ;READY FOR COMPARE WITH ACCUM
CMP M ;SAME?
RZ ;RETURN WITH ZERO FLAG SET, B IS SUFIX
NEXT0: INX D ;MOVE TO NEXT CHARACTER
INR B ;COUNT SUFFIX UP
DCR C ;COUNT TABLE LENGTH DOWN
JNZ NEXTS
; END OF TABLE, MARK WITH NON ZERO FLAG
INR C
RET
;
NSUFF: ;NOT PROPER SUFFIX - SET NON ZERO FLAG
XRA A
INR A
RET
;
BGET: ;PERFORM BINARY SEARCH, AND EXTRACT TYPE AND VAL FIELDS FOR
; THE ITEM. ZERO FLAG INDICATES MATCH WAS FOUND, WITH TYPE
; IN THE ACCUMULATOR, AND VAL IN REGISTER B. THE SEARCH IS BASED
; UPON THE LENGTH OF THE ACCUMULATOR
LDA ACCLEN ;ITEM LENGTH
MOV C,A ;SAVE A COPY
DCR A ;ACCLEN-1
MOV E,A
MVI D,0 ;DOUBLE ACCLEN-1 TO D,E
PUSH D ;SAVE A COPY FOR LATER
CPI CMAX ;TOO LONG?
JNC NGET ;NOT IN RANGE IF CARRY
LXI H,CLEN ;LENGTH VECTOR
DAD D
MOV UR,M ;FILL UPPER BOUND FROM MEMORY
LXI H,CINX
DAD D
DAD D ;BASE ADDRESS TO H,L
MOV D,M
INX H
MOV H,M
MOV L,D ;NOW IN H,L
MOV SR,C ;FILL THE SIZE REGISTER
CALL BSEAR ;PERFORM THE BINARY SEARCH
JNZ SCASE ;ZERO IF FOUND
POP D ;RESTORE INDEX
LXI H,TVINX
DAD D
DAD D ;ADDRESSING PROPER TV ELEMENT
MOV E,M
INX H
MOV D,M
; D,E IS BASE ADDRESS OF TYPE/VALUE VECTOR, ADD DISPLACEMENT
MOV L,A
MVI H,0
DAD H ;DOUBLED
DAD D ;INDEXED
MOV A,M ;TYPE TO ACC
INX H
MOV B,M ;VALUE TO B
RET ;TYPE IN ACC, VALUE IN B
;
SCASE: ;NAME NOT TOO LONG, BUT NOT FOUND IN TABLES, MAY BE J C OR R
POP D ;RESTORE INDEX
CALL PREFIX
RNZ ;NOT FOUND AS PREFIX J C OR R IF NOT ZERO FLAG
PUSH B ;SAVE VALUE AND TYPE
CALL SUFFIX ;ZERO IF SUFFIX MATCHED
MOV A,B ;READY FOR MASK IF ZERO FLAG
POP B ;RECALL VALUE AND TYPE
RNZ ;RETURN IF NOT ZERO FLAG SET
; MASK IN THE PROPER BITS AND RETURN
ORA A ;CLEAR CARRY
RAL
RAL
RAL
ORA B ;VALUE SET TO JNZ ...
MOV B,A ;REPLACE
MOV A,C ;RETURN WITH TYPE IN REGISTER A
CMP A ;CLEAR THE ZERO FLAG
RET
;
NGET: ;CAN'T FIND THE ENTRY, RETURN WITH ZERO FLAG RESET
POP D ;GET THE ELEMENT BACK
XRA A ;CLEAR
INR A ;ZERO FLAG RESET
RET
;
;
ENDMOD EQU ($ AND 0FFE0H) + 20H ;NEXT MODULE ADDRESS
END


594
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/AS5OPER.ASM Normal file
View File

@@ -0,0 +1,594 @@
TITLE 'ASM OPERAND SCAN MODULE'
; OPERAND SCAN MODULE
ORG 1860H
;
; EXTERNALS
IOMOD EQU 200H ;I/O MODULE
SCMOD EQU 1100H ;SCANNER MODULE
SYMOD EQU 1340H ;SYMBOL TABLE MODULE
BMOD EQU 15A0H ;BINARY SEARCH MODULE
;
;
PERR EQU IOMOD+18H
SCAN EQU SCMOD+6H ;SCANNER ENTRY POINT
CR EQU 0DH ;CARRIAGE RETURN
;
LOOKUP EQU SYMOD+6H ;LOOKUP
FOUND EQU LOOKUP+3 ;FOUND SYMBOL IF ZERO FLAG NOT SET
ENTER EQU FOUND+3 ;ENTER SYMBOL
SETTY EQU ENTER+3 ;SET TYPE FIELD
GETTY EQU SETTY+3 ;SET TYPE FIELD
SETVAL EQU GETTY+3 ;SET VALUE FIELD
GETVAL EQU SETVAL+3 ;GET VALUE FIELD
;
BSEAR EQU BMOD+3 ;BINARY SEARCH ROUTINE
BGET EQU BSEAR+3 ;GET VALUES WITH SEARCH
;
; COMMON EQUATES
PBMAX EQU 120 ;MAX PRINT SIZE
PBUFF EQU 10CH ;PRINT BUFFER
PBP EQU PBUFF+PBMAX ;PRINT BUFFER POINTER
;
TOKEN EQU PBP+1 ;CURRENT TOKEN UDER SCAN
VALUE EQU TOKEN+1 ;VALUE OF NUMBER IN BINARY
ACCLEN EQU VALUE+2 ;ACCUMULATOR LENGTH
ACMAX EQU 64 ;MAX ACCUMULATOR LENGTH
ACCUM EQU ACCLEN+1
;
EVALUE EQU ACCUM+ACMAX ;VALUE FROM EXPRESSION ANALYSIS
;
SYTOP EQU EVALUE+2 ;CURRENT SYMBOL TOP
SYMAX EQU SYTOP+2 ;MAX ADDRESS+1
;
PASS EQU SYMAX+2 ;CURRENT PASS NUMBER
FPC EQU PASS+1 ;FILL ADDRESS FOR NEXT HEX BYTE
ASPC EQU FPC+2 ;ASSEMBLER'S PSEUDO PC
;
; GLOBAL EQUATES
IDEN EQU 1 ;IDENTIFIER
NUMB EQU 2 ;NUMBER
STRNG EQU 3 ;STRING
SPECL EQU 4 ;SPECIAL CHARACTER
;
PLABT EQU 0001B ;PROGRAM LABEL
DLABT EQU 0010B ;DATA LABEL
EQUT EQU 0100B ;EQUATE
SETT EQU 0101B ;SET
MACT EQU 0110B ;MACRO
;
EXTT EQU 1000B ;EXTERNAL
REFT EQU 1011B ;REFER
GLBT EQU 1100B ;GLOBAL
;
;
; TABLE DEFINITIONS
XBASE EQU 0 ;START OF OPERATORS
OPER EQU 15 ;LAST OPERATOR
RT EQU 16
PT EQU RT+1 ;RT IS REGISTER TYPE, PT IS PSEUDO OPERATION
OBASE EQU PT+1
;
PLUS EQU 5
MINUS EQU 6
NOTF EQU 8 ;NOT
LPAR EQU 12
RPAR EQU 13
OSMAX EQU 10
VSMAX EQU 8*2
;
;
; BEGINNING OF MODULE
JMP ENDMOD ;PAST THIS MODULE
JMP OPAND ;SCAN OPERAND FIELD
JMP MULF ;MULTIPLY FUNCTION
JMP DIVE ;DIVIDE FUNCTION
UNARY: DS 1 ;TRUE IF NEXT OPERATOR IS UNARY
OPERV: DS OSMAX ;OPERATOR STACK
HIERV: DS OSMAX ;OPERATOR PRIORITY
VSTACK: DS VSMAX ;VALUE STACK
OSP: DS 1 ;OPERATOR STACK POINTER
VSP: DS 1 ;VALUE STACK POINTER
;
;
;
STKV: ;PLACE CURRENT H,L VALUE AT TOP OF VSTACK
XCHG ;HOLD VALUE IN D,E
LXI H,VSP
MOV A,M
CPI VSMAX
JC STKV0
CALL ERREX ;OVERFLOW IN EXPRESSION
MVI M,0 ;VSP=0
STKV0: MOV A,M ;GET VSP
INR M ;VSP=VSP+1
INR M ;VSP=VSP+2
MOV C,A ;SAVE VSP
MVI B,0 ;DOUBLE VSP
LXI H,VSTACK
DAD B
MOV M,E ;LOW BYTE
INX H
MOV M,D ;HIGH BYTE
RET
;
STKO: ;STACK OPERATOR (REG-A) AND PRIORITY (REG-B)
PUSH PSW ;SAVE IT
LXI H,OSP
MOV A,M
CPI OSMAX
JC STKO1
MVI M,0
CALL ERREX ;OPERATOR STACK OVERFLOW
STKO1: MOV E,M ;GET OSP
MVI D,0
INR M ;OSP=OSP+1
POP PSW ;RECALL OPERATOR
LXI H,OPERV
DAD D ;OPERV(OSP)
MOV M,A ;OPERV(OSP)=OPERATOR
LXI H,HIERV
DAD D
MOV M,B ;HIERV(OSP)=PRIORITY
RET
;
LODV1: ;LOAD TOP ELEMENT FROM VSTACK TO H,L
LXI H,VSP
MOV A,M
ORA A
JNZ LODOK
CALL ERREX ;UNDERFLOW
LXI H,0
RET
;
LODOK: DCR M
DCR M ;VSP=VSP-2
MOV C,M ;LOW BYTE
MVI B,0
LXI H,VSTACK
DAD B ;VSTACK(VSP)
MOV C,M ;GET LOW BYTE
INX H
MOV H,M
MOV L,C
RET
;
LODV2: ;LOAD TOP TWO ELEMENTS DE HOLDS TOP, HL HOLDS TOP-1
CALL LODV1
XCHG
CALL LODV1
RET
;
APPLY: ;APPLY OPERATOR IN REG-A TO TOP OF STACK
MOV L,A
MVI H,0
DAD H ;OPERATOR NUMBER*2
LXI D,OPTAB
DAD D ;INDEXED OPTAB
MOV E,M ;LOW ADDRESS
INX H
MOV H,M ;HIGH ADDRESS
MOV L,E
PCHL ;SET PC AND GO TO SUBROUTINE
;
OPTAB: DW MULOP
DW DIVOP
DW MODOP
DW SHLOP
DW SHROP
DW ADDOP
DW SUBOP
DW NEGOP
DW NOTOP
DW ANDOP
DW OROP
DW XOROP
DW ERREX ;(
;
; SPECIFIC HANDLERS FOLLOW
SHFT: ;SET UP OPERANDS FOR SHIFT L AND R
CALL LODV2
MOV A,D ;ENSURE 0-15
ORA A
JNZ SHERR
MOV A,E
CPI 17
RC ;RETURN IF 0-16 SHIFT
SHERR: CALL ERREX
MVI A,16
RET
;
NEGF: ;COMPUTE 0-H,L TO H,L
XRA A
SUB L
MOV L,A
MVI A,0
SBB H
MOV H,A
RET
;
DIVF: CALL LODV2
DIVE: ;(EXTERNAL ENTRY FROM MAIN PROGRAM)
XCHG ;SWAP D,E WITH H,L FOR DIVIDE FUNCTION
; COMPUTE X/Y WHERE X IS IN D,E AND Y IS IN H,L
; THE VALUE OF X/Y APPEARS IN D,E AND X MOD Y IS IN H,L
;
SHLD DTEMP ;SAVE X IN TEMPORARY
LXI H,BNUM ;STORE BIT COUNT
MVI M,11H
LXI B,0 ;INTIALIZE RESULT
PUSH B
XRA A ;CLEAR FLAGS
DLOOP:
MOV A,E ;GET LOW Y BYTE
RAL
MOV E,A
MOV A,D
RAL
MOV D,A
DCR M ;DECREMENT BIT COUNT
POP H ;RESTORE TEMP RESULT
RZ ;ZERO BIT COUNT MEANS ALL DONE
MVI A,0 ;ADD IN CARRY
ACI 0 ;CARRY
DAD H ;SHIFT TEMP RESULT LEFT ONE BIT
MOV B,H ;COPY HA AND L TO A A ND C
ADD L
LHLD DTEMP ;GET ADDRESS OF X
SUB L ;SUBTRACT FROM TEMPORARY RESULT
MOV C,A
MOV A,B
SBB H
MOV B,A
PUSH B ;SAVE TEMP RESULT IN STACK
JNC DSKIP ;NO BORROW FROM SUBTRACT
DAD B ;ADD X BACK IN
XTHL ;REPLACE TEMP RESULT ON STACK
DSKIP: LXI H,BNUM ;RESTORE H,L
CMC
JMP DLOOP ;REPEAT LOOP STEPS
;
DTEMP: DS 2
BNUM: DS 1
;
MULF: ;MULTIPLY D,E BY H,L AND REPLACE H,L WITH RESULT
MOV B,H
MOV C,L ;COPY OF 1ST VALUE TO B,C FOR SHIFT AND ADD
LXI H,0 ;H,L IS THE ACCUMULATOR
MUL0: XRA A
MOV A,B ;CARRY IS CLEARED
RAR
MOV B,A
MOV A,C
RAR
MOV C,A
JC MUL1 ;SKIP THIS ADD IF LSB IS ZERO
ORA B
RZ ;RETURN WITH H,L
JMP MUL2 ;SKIP ADD
MUL1: DAD D ;ADD CURRENT VALUE OF D
MUL2: XCHG ;READY FOR *2
DAD H
XCHG
JMP MUL0
;
MULOP: ;MULTIPLY D,E BY H,L
CALL LODV2
CALL MULF
JMP ENDOP
;
DIVOP: ;DIVIDE H,L BY D,E
CALL DIVF
XCHG ;RESULT TO H,L
JMP ENDOP
;
MODOP: CALL DIVF
JMP ENDOP
;
SHLOP: CALL SHFT ;CHECK VALUES
SHL0: ORA A ;DONE?
JZ ENDOP
DAD H ;HL=HL*2
DCR A
JMP SHL0
;
SHROP: CALL SHFT
SHR0: ORA A ;DONE?
JZ ENDOP
PUSH PSW ;SAVE CURRENT COUNT
XRA A
MOV A,H
RAR
MOV H,A
MOV A,L
RAR
MOV L,A
POP PSW
DCR A
JMP SHR0
;
ADDOP: CALL LODV2
ADD0: DAD D
JMP ENDOP
;
SUBOP: CALL LODV2
XCHG ;TREAT AS HL+(-DE)
CALL NEGF ;0-HL
JMP ADD0
;
NEGOP: CALL LODV1
NEG0: CALL NEGF ;COMPUTE 0-HL
JMP ENDOP
;
NOTOP: CALL LODV1
INX H ;65536-HL = 65535-(HL+1)
JMP NEG0
;
ANDOP: CALL LODV2
MOV A,D
ANA H
MOV H,A
MOV A,E
ANA L
MOV L,A
JMP ENDOP
;
OROP: CALL LODV2
MOV A,D
ORA H
MOV H,A
MOV A,E
ORA L
MOV L,A
JMP ENDOP
;
XOROP: CALL LODV2
MOV A,D
XRA H
MOV H,A
MOV A,E
XRA L
MOV L,A
;
ENDOP: JMP STKV
;
;
;
ENDEXP: ;RETURNS ZERO FLAG IF SYMBOL IS CR, ;, OR ,
LDA TOKEN
CPI SPECL
RNZ ;NOT END IF NOT SPECIAL
;
LDA ACCUM
CPI CR
RZ
CPI ';'
RZ
CPI ','
RZ
CPI '!'
RET
;
OPAND: ;SCAN THE OPERAND FIELD OF AN INSTRUCTION
; (NOT A DB WITH FIRST TOKEN STRING > 2 OR 0)
XRA A
STA OSP ;ZERO OPERATOR STACK POINTER
STA VSP
DCR A ;255
STA UNARY
LXI H,0
SHLD EVALUE
;
OP0: ;ARRIVE HERE WITH NEXT ITEM ALREADY SCANNED
CALL ENDEXP ;DONE?
JNZ OP1
; EMPTY THE OPERATOR STACK
EMPOP: LXI H,OSP
MOV A,M ;GET THE OSP AND CHECK FOR EMPTY
ORA A
JZ CHKVAL ;JUMP IF EMPTY
DCR M ;POP ELEMENT
MOV E,A ;COPY FOR DOUBLE ADD
DCR E
MVI D,0
LXI H,OPERV
DAD D ;INDEXED - OPERV(OSP)
MOV A,M ;GET OPERATOR
CALL APPLY ;APPLY OPERATOR
JMP EMPOP
;
CHKVAL:
LDA VSP ;MUST HAVE ONE ELEMENT IT THE STACK
CPI 2
CNZ ERREX
LDA PBUFF
CPI ' '
RNZ ;EVALUE REMAINS AT ZERO
LHLD VSTACK ;GET DOUBLE BYTE IN STACK
SHLD EVALUE
RET
;
OP1: ;MORE TO SCAN
LDA PBUFF
CPI ' '
JNZ GETOP
LDA TOKEN
CPI STRNG ;IS THIS A STRING?
JNZ OP3
;
; STRING - CONVERT TO DOUBLE PRECISION
LDA ACCLEN
ORA A
CZ ERREX ;ERROR IF LENGTH=0
CPI 3
CNC ERREX ;ERROR IF LENGTH>2
MVI D,0
LXI H,ACCUM
MOV E,M ;LSBYTE
INX H
DCR A ;A HAS THE LENGTH
JZ OP2 ;ONE OR TWO BYTES
MOV D,M ;FILL HIGH ORDER
OP2: XCHG ;VALUE TO H,L
JMP STNUM ;STORE TO STACK
;
OP3: ;NOT A STRING, CHECK FOR NUMBER
CPI NUMB
JNZ OP4
LHLD VALUE ;NUMERIC VALUE
JMP STNUM
;
OP4: ;NOT STRING OR NUMBER, MUST BE ID OR SPECL
CALL BGET ;BINARY SEARCH, GET ATTRIBUTES
JNZ OP6 ;MATCH?
; YES, MAY BE OPERATOR
CPI OPER+1
JNC OP5
; OPERATOR ENCOUNTERED MS NIBBLE OF B IS PRIORITY NUMBER LS NIBBLE
; IS THE OPERATOR
; ACC HAS THE OPERATOR NUMBER, B HAS PRIORITY
CPI LPAR ;(?
MOV C,A ;SAVE COPY OF OPERATOR NUMBER
LDA UNARY
JNZ OPER1 ;JUMP IF NOT A (
; ( ENCOUNTERED, UNARY MUST BE TRUE
ORA A
CZ ERREX
MVI A,0FFH
STA UNARY ;UNARY IS SET TRUE
MOV A,C ;RECOVER OPERATOR
JMP OPER4 ;CALLS STKO AND SETS UNARY TO TRUE
;
;
OPER1: ;NOT A LEFT PAREN
ORA A
JNZ OPER6 ;MUST BE + OR - SINCE UNARY IS SET
;
; UNARY NOT SET, MUST BE BINARY OPERATOR
OPER2: ;COMPARE HIERARCHY OF TOS
PUSH B ;SAVE PRIORITY AND OPERATOR NUMBER
LDA OSP
ORA A
JZ OPER3 ;NO MORE OPERATORS IN STACK
MOV E,A ;OSP TO E
DCR E ;OSP-1
MVI D,0
LXI H,HIERV
DAD D ;HL ADDRESSES TOP OF OPERATOR STACK
MOV A,M ;PRIORITY OF TOP OPERATOR
CMP B ;CURRENT GREATER?
JC OPER3 ;JUMP IF SO
; APPLY TOP OPERATOR TO VALUE STACK
LXI H,OSP
MOV M,E ;OSP=OSP-1
LXI H,OPERV
DAD D
MOV A,M ;OPERATOR NUMBER TO ACC
CALL APPLY
POP B ;RESTORE OPERATOR NUMBER AND PRIORITY
JMP OPER2 ;FOR ANOTHER TEST
;
OPER3: ;ARRIVE HERE WHEN OPERATOR IS STACKED
; CHECK FOR RIGHT PAREN BALANCE
POP B ;OPERATOR NUMBER IN C, PRIORITY IN B
MOV A,C
CPI RPAR
JNZ OPER4 ;JUMP IF NOT A RIGHT PAREN
;
; RIGHT PAREN FOUND, STACK MUST CONTAIN LEFT PAREN TO DELETE
LXI H,OSP
MOV A,M
ORA A ;ZERO?
JZ LPERR ;PAREN ERROR IF SO
DCR A ;OSP-1
MOV M,A ;STORED TO MEMORY
MOV E,A
MVI D,0
LXI H,OPERV
DAD D
MOV A,M ;TOP OPERATOR IN REG-A
CPI LPAR
JZ NLERR ;JMP IF NO ERROR - PARENS BALANCE
LPERR: CALL ERREX
NLERR: ;ERROR REPORTING COMPLETE
XRA A
JMP OPER5 ;TO CLEAR UNARY FLAG
;
OPER4: ;ORDINARY OPERATOR
CALL STKO
MVI A,0FFH ;TO SET UNARY FLAG
OPER5: STA UNARY
JMP GETOP ;FOR ANOTHER ELEMENT
;
OPER6: ;UNARY SET, MUST BE + OR -
MOV A,C ;RECALL OPERATOR
CPI PLUS
JZ GETOP ;IGNORE UNARY PLUS
CPI MINUS
JNZ CHKNOT
INR A ;CHANGE TO UNARY MINUS
MOV C,A
JMP OPER2
CHKNOT: ;UNARY NOT SYMBOL?
CPI NOTF
CNZ ERREX
JMP OPER2
;
;
OP5: ;ELEMENT FOUND IN TABLE, NOT AN OPERATOR
CPI PT ;PSEUDO OPERATOR?
CZ ERREX ;ERROR IF SO
MOV L,B ;GET LOW VALUE TO L
MVI H,0 ;ZERO HIGH ORDER BYTE
JMP STNUM ;STORE IT
;
OP6: ;NOT FOUND IN TABLE SCAN, $?
LDA TOKEN
CPI SPECL
JNZ OP7
LDA ACCUM
CPI '$'
JZ CURPC ;USE CURRENT PC
CALL ERREX
LXI H,0
JMP STNUM
CURPC: LHLD ASPC ;GET CURRENT PC
JMP STNUM
;
OP7: ;NOT $, LOOK IT UP
CALL LOOKUP
CALL FOUND
JNZ FIDENT
; NOT FOUND IN SYMBOL TABLE, ENTER IF PASS 1
MVI A,'P'
CALL PERR
CALL ENTER ;ENTER SYMBOL WITH ZERO TYPE FIELD
JMP FIDE0
FIDENT: CALL GETTY ;TYPE TO H,L
ANI 111B
MVI A,'U'
CZ PERR
;
FIDE0:
CALL GETVAL ;VALUE TO H,L
;
STNUM: ;STORE H,L TO VALUE STACK
LDA UNARY
ORA A ;UNARY OPERATION SET
CZ ERREX ;OPERAND ENCOUNTERED WITH UNARY OFF
XRA A
STA UNARY ;SET TO OFF
CALL STKV ;STACK THE VALUE
;
GETOP: CALL SCAN
JMP OP0
;
ERREX: ;PUT 'E' ERROR IN OUTPUT BUFFER
PUSH H
MVI A,'E'
CALL PERR
POP H
RET
;
ENDMOD EQU ($ AND 0FFE0H) + 20H ;NEXT HALF PAGE
END


889
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/AS6MAIN.ASM Normal file
View File

@@ -0,0 +1,889 @@
TITLE 'ASM MAIN MODULE'
; CP/M RESIDENT ASSEMBLER MAIN PROGRAM
;
; COPYRIGHT (C) 1976, 1977, 1978
; DIGITAL RESEARCH
; BOX 579, PACIFIC GROVE
; CALIFORNIA, 93950
;
;
ORG 1BA0H
; MODULE ENTRY POINTS
IOMOD EQU 200H ;IO MODULE
SCMOD EQU 1100H ;SCANNER MODULE
SYMOD EQU 1340H ;SYMBOL TABLE MODULE
BMOD EQU 15A0H ;BINARY SEARCH MODULE
OPMOD EQU 1860H ;OPERAND SCAN MODULE
;
SETUP EQU IOMOD+3H ;FILE SETUP FOR EACH PASS
PCON EQU IOMOD+12H ;WRITE CONSOLE BUFFER TO CR
WOBUFF EQU IOMOD+15H ;WRITE PRINT BUFFER AND REINITIALIZE
PERR EQU IOMOD+18H ;WRITE ERROR CHARACTER TO PRINT BUFFER
DHEX EQU IOMOD+1BH ;SEND HEX CHARACTER TO MACHINE CODE FILE
EOR EQU IOMOD+1EH ;END OF PROCESSING, CLOSE FILES AND TERMINATE
;
INITS EQU SCMOD+3H ;INITIALIZE SCANNER MODULE
SCAN EQU SCMOD+6H ;SCAN NEXT TOKEN
;
INISY EQU SYMOD+3H ;INITIALIZE SYMBOL TABLE
LOOKUP EQU SYMOD+6H ;LOOKUP SYMBOL IN ACCUMULATOR
FOUND EQU SYMOD+9H ;FOUND IF NZ FLAG
ENTER EQU SYMOD+0CH ;ENTER SYMBOL IN ACCUMULATOR
SETTY EQU SYMOD+0FH ;SET TYPE FIELD
GETTY EQU SYMOD+12H ;GET TYPE FIELD
SETVAL EQU SYMOD+15H ;SET VALUE FIELD
GETVAL EQU SYMOD+18H ;GET VALUE FIELD
;
BGET EQU BMOD+6H ;BINARY SEARCH AND GET TYPE/VALUE PAIR
;
OPAND EQU OPMOD+3H ;GET OPERAND VALUE TO 'EVALUE'
MULF EQU OPMOD+6H ;MULT D,E BY H,L TO H,L
DIVF EQU OPMOD+9H ;DIVIDE HL BY DE, RESULT TO DE
;
;
; COMMON EQUATES
PBMAX EQU 120 ;MAX PRINT SIZE
PBUFF EQU 10CH ;PRINT BUFFER
PBP EQU PBUFF+PBMAX ;PRINT BUFFER POINTER
;
TOKEN EQU PBP+1 ;CURRENT TOKEN UDER SCAN
VALUE EQU TOKEN+1 ;VALUE OF NUMBER IN BINARY
ACCLEN EQU VALUE+2 ;ACCUMULATOR LENGTH
ACMAX EQU 64 ;MAX ACCUMULATOR LENGTH
ACCUM EQU ACCLEN+1
;
EVALUE EQU ACCUM+ACMAX ;VALUE FROM EXPRESSION ANALYSIS
;
SYTOP EQU EVALUE+2 ;CURRENT SYMBOL TOP
SYMAX EQU SYTOP+2 ;MAX ADDRESS+1
;
PASS EQU SYMAX+2 ;CURRENT PASS NUMBER
FPC EQU PASS+1 ;FILL ADDRESS FOR NEXT HEX BYTE
ASPC EQU FPC+2 ;ASSEMBLER'S PSEUDO PC
SYBAS EQU ASPC+2 ;BASE OF SYMBOL TABLE
SYADR EQU SYBAS+2 ;CURRENT SYMBOL ADDRESS
;
; GLOBAL EQUATES
IDEN EQU 1 ;IDENTIFIER
NUMB EQU 2 ;NUMBER
STRNG EQU 3 ;STRING
SPECL EQU 4 ;SPECIAL CHARACTER
;
PLABT EQU 0001B ;PROGRAM LABEL
DLABT EQU 0010B ;DATA LABEL
EQUT EQU 0100B ;EQUATE
SETT EQU 0101B ;SET
MACT EQU 0110B ;MACRO
;
EXTT EQU 1000B ;EXTERNAL
REFT EQU 1011B ;REFER
GLBT EQU 1100B ;GLOBAL
;
CR EQU 0DH ;CARRIAGE RETURN
LF EQU 0AH ;LINE FEED
EOF EQU 1AH ;END OF FILE
NBMAX EQU 16 ;STARTING POSITION OF PRINT LINE
;
;
RT EQU 16 ;REGISTER TYPE
PT EQU RT+1 ;PSEUDO OPERATION
PENDIF EQU 5 ;PSEUDO OPERATOR 'ENDIF'
OBASE EQU PT+1
O1 EQU OBASE+1 ;FIRST OPERATOR
O15 EQU OBASE+15;LAST OPERATOR
;
; MAIN STATEMENT PROCESSING LOOP
XRA A
STA PASS ;SET TO PASS 0 INITIALLY
CALL INISY ;INITIALIZE THE SYMBOL TABLE
RESTART: ;PASS LOOP GOES FROM 0 TO 1
CALL INITS ;INITIALIZE THE SCANNER
CALL SETUP ;SET UP THE INPUT FILE
LXI H,0
SHLD SYLAB ;ASSUME NO STARTING LABEL
SHLD FPC
SHLD ASPC
SHLD EPC ;END PC
;
SCNEXT: ;SCAN THE NEXT INPUT ITEM
CALL SCAN
SCN0: LDA TOKEN
CPI NUMB ;SKIP LEADING NUMBERS FROM LINE EDITORS
JZ SCNEXT
CPI SPECL ;MAY BE PROCESSOR TECH'S COMMENT
JNZ SCN1
; SPECIAL CHARACTER, CHECK FOR *
LDA ACCUM
CPI '*'
JNZ CHEND ;END OF LINE IF NOT *
; * FOUND, NO PRECEDING LABEL ALLOWED
CALL SETLA
JNZ STERR ;ERROR IF LABEL
JMP CHEN1 ;SCAN THE COMMENT OTHERWISE
;
SCN1: ;NOT NUMBER OR SPECIAL CHARACTER, CHECK FOR IDENTIFIER
CPI IDEN
JNZ STERR ;ERROR IF NOT
;
; IDENTIFIER FOUND, MAY BE LABEL, OPCODE, OR MACRO
CALL BGET ;BINARY SEARCH FIXED DATA
JZ CHKPT ;CHECK FOR PSEUDO OR REAL OPERATOR
;
; BINARY SEARCH WAS UNSUCCESSFUL, CHECK FOR MACRO
CALL LOOKUP
CALL FOUND
JNZ LFOUN ;NZ FLAG SET IF FOUND
;
; NOT FOUND, ENTER IT
CALL ENTER ;THIS MUST BE PASS 0
LDA PASS
ORA A
CNZ ERRP ;PHASE ERROR IF NOT
JMP SETSY ;SET SYLAB
;
; ITEM WAS FOUND, CHECK FOR MACRO
LFOUN: CALL GETTY
CPI MACT
JNZ SETSY
;
; MACRO DEFINITION FOUND, EXPAND MACRO
CALL ERRN ;NOT CURRENTLY IMPLEMENTED
JMP CHEN1 ;SCANS TO END OF CURRENT LINE
;
SETSY: ;LABEL FOUND - IS IT THE ONLY ONE?
LHLD SYLAB
MOV A,L
ORA H
CNZ ERRL ;LABEL ERROR IF NOT
LHLD SYADR ;ADDRESS OF SYMBOL
SHLD SYLAB ;MARK AS LABEL FOUND
;
; LABEL FOUND, SCAN OPTIONAL ':'
CALL SCAN
LDA TOKEN
CPI SPECL
JNZ SCN0 ;SKIP NEXT SCAN IF NOT SPECIAL
LDA ACCUM
CPI ':'
JNZ SCN0
JMP SCNEXT ;TO IGNORE ':'
;
; BINARY SEARCH FOUND SYMBOL, CHECK FOR PSEUDO OR REAL OP
CHKPT: CPI PT ;PSEUDO OPCODE?
JNZ CHKOT
;
; PSEUDO OPCODE FOUND, BRANCH TO CASES
MOV E,B ;B HAS PARTICULAR OPERATOR NUMBER
MVI D,0 ;DOUBLE PRECISION VALUE TO D,E
DCX D ;BIASED BY +1
LXI H,PTTAB ;BASE OF JUMP TABLE
DAD D
DAD D
MOV E,M
INX H
MOV H,M
MOV L,E
PCHL ;JUMP INTO TABLE
;
PTTAB: ;PSEUDO OPCODE JUMP TABLE
DW SDB ;DB
DW SDS ;DS
DW SDW ;DW
DW SEND ;END
DW SENDIF ;ENDIF
DW SENDM ;ENDM
DW SEQU ;EQU
DW SIF ;IF
DW SMACRO ;MACRO
DW SORG ;ORG
DW SSET ;SET
DW STITLE ;TITLE
;
SDB:
CALL FILAB ;SET LABEL FOR THIS LINE TO ASPC
SDB0:
CALL SCAN ;PAST DB TO NEXT ITEM
LDA TOKEN ;LOOK FOR LONG STRING
CPI STRNG
JNZ SDBC ;SKIP IF NOT STRING
LDA ACCLEN
DCR A ;LENGTH 1 STRING?
JZ SDBC
; LENGTH 0,2,... STRING
MOV B,A
INR B
INR B ;BECOMES 1,3,... FOR 0,2,... LENGTHS
LXI H,ACCUM ;ADDRESS CHARACTERS IN STRING
SDB1: DCR B ;COUNT DOWN TO ZERO
JZ SDB2 ;SCAN DELIMITER AT END OF STRING
PUSH B ;SAVE COUNT
MOV B,M ;GET CHARACTER
INX H
PUSH H ;SAVE ACCUM POINTER
CALL FILHB ;SEND TO HEX FILE
POP H
POP B
JMP SDB1
SDB2: CALL SCAN ;TO THE DELIMITER
JMP SDB3
;
; NOT A LONG STRING
SDBC: CALL OPAND ;COMPUTE OPERAND
LHLD EVALUE ;VALUE TO H,L
MOV A,H
ORA A ;HIGH ORDER MUST BE ZERO
CNZ ERRD ;DATA ERROR
MOV B,L ;GET LOW BYTE
CALL FILHB
SDB3: ;END OF ITEM - UPDATE ASPC
CALL SETAS ;SET ASPC TO FPC
CALL DELIM
CPI ','
JZ SDB0 ;FOR ANOTHER ITEM
JMP CHEND ;CHECK END OF LINE SYNTAX
;
SDS:
CALL FILAB ;HANDLE LABEL IF IT OCCURRED
CALL PADD ;PRINT ADDRESS
CALL EXP16 ;SCAN AND GET 16BIT OPERAND
XCHG ;TO D,E
LHLD ASPC ;CURRENT PSEUDO PC
DAD D ;+EXPRESSION
SHLD ASPC
SHLD FPC ;NEXT TO FILL
JMP CHEND
;
SDW:
CALL FILAB ;HANDLE OPTIONAL LABEL
SDW0:
CALL EXP16 ;GET 16BIT OPERAND
PUSH H ;SAVE A COPY
MOV B,L ;LOW BYTE FIRST
CALL FILHB ;SEND LOW BYTE
POP H ;RECLAIM A COPY
MOV B,H ;HIGH BYTE NEXT
CALL FILHB ;SEND HIGH BYTE
CALL SETAS ;SET ASPC=FPC
CALL DELIM ;CHECK DELIMITER SYNTAX
CPI ','
JZ SDW0 ;GET MORE DATA
JMP CHEND
;
SEND:
CALL FILAB
CALL PADD ;WRITE LAST LOC
LDA PBUFF
CPI ' '
JNZ CHEND
CALL EXP16 ;GET EXPRESSION IF IT'S THERE
LDA PBUFF
CPI ' '
JNZ SEND0
SHLD EPC ;EXPRESSION FOUND, STORE IT FOR LATER
SEND0: MVI A,' '
STA PBUFF ;CLEAR ERROR, IF IT OCCURRED
CALL SCAN ;CLEAR CR
LDA TOKEN
CPI SPECL
JNZ STERR
LDA ACCUM
CPI LF
JNZ STERR
JMP ENDAS ;END OF ASSEMBLER
;
SENDIF:
JMP POEND
;
SENDM:
CALL ERRN
JMP POEND
;
SEQU:
CALL SETLA
JZ STERR ;MUST BE A LABEL
LHLD ASPC ;HOLD TEMP ASPC
PUSH H ;IN STACK
CALL EXP16 ;GET 16BIT OPERAND
SHLD ASPC ;VALUE OF EXPRESSION
CALL FILAB
CALL PADDR ;COMPUTED VALUE
LXI H,PBUFF+6 ;SPACE AFTER VALUE
MVI M,'='
POP H ;REAL ASPC
SHLD ASPC ;CHANGE BACK
JMP CHEND
;
SIF:
CALL FILAB ;IN CASE OF LABEL
CALL EXP16 ;GET IF EXPRESSION
LDA PBUFF
CPI ' '
JNZ CHEND ;SKIP IF ERROR
MOV A,L ;GET LSB
RAR
JC CHEND ;TRUE IF CARRY BIT SET
;
; SKIP TO EOF OR ENDIF
SIF0: CALL SCAN
LDA TOKEN
CPI SPECL
JNZ SIF1
LDA ACCUM
CPI EOF
MVI A,'B' ;BALANCE ERROR
CZ PERR
JZ ENDAS
JMP SIF0 ;FOR ANOTHER
SIF1: ;NOT A SPECIAL CHARACTER
CPI IDEN
JNZ SIF0 ;NOT AN IDENTIFIER
CALL BGET ;LOOK FOR ENDIF
JNZ SIF0 ;NOT FOUND
CPI PT ;PSEUDO OP?
JNZ SIF0
MOV A,B ;GET OPERATOR NUMBER
CPI PENDIF ;ENDIF?
JNZ SIF0 ;GET ANOTHER TOKEN
JMP POEND ;OK, CHECK END OF LINE
;
SMACRO:
CALL ERRN
JMP CHEND
;
SORG:
CALL EXP16
LDA PBUFF
CPI ' '
JNZ CHEND ;SKIP ORG IF ERROR
SHLD ASPC ;CHANGE PC
SHLD FPC ;CHANGE NEXT TO FILL
CALL FILAB ;IN CASE OF LABEL
CALL PADD
JMP CHEND
;
SSET:
CALL SETLA
JZ STERR ;MUST BE LABELLED
;
CALL GETTY
CPI SETT
CNZ ERRL ;LABEL ERROR
MVI A,SETT
CALL SETTY ;REPLACE TYPE WITH 'SET'
CALL EXP16 ;GET THE EXPRESSION
PUSH H ;SAVE IT
CALL SETLA ;RE-ADDRESS LABEL
POP H ;RECLAIM IT
CALL SETVAL
LXI H,0
SHLD SYLAB ;PREVENT LABEL PROCESSING
JMP CHEND
;
;
STITLE:
CALL ERRN ;NOT IMPLEMENTED
;
POEND: ;PSEUDO OPERATOR END - SCAN TO NEXT TOKEN
CALL SCAN
JMP CHEND
;
; NOT A PSEUDO OPCODE, CHECK FOR REAL OPCODE
CHKOT: SUI O1 ;BASE OF OPCODES
CPI O15 ;PAST LAST OPCODE?
JNC STERR ;STATEMENT ERROR IF SO
;
; FOUND OPCODE, COMPUTE INDEX INTO TABLE AND JUMP TO CASE
MOV E,A
MVI D,0
LXI H,OPTAB
DAD D
DAD D
MOV E,M
INX H
MOV H,M
MOV L,E
PCHL ;JUMP TO CASE
;
OPTAB: ;OPCODE CATEGORIES
DW SSIMP ;SIMPLE
DW SLXI ;LXI
DW SDAD ;DAD
DW SPUSH ;PUSH/POP
DW SJMP ;JMP/CALL
DW SMOV ;MOV
DW SMVI ;MVI
DW SACCI ;ACCUM IMMEDIATE
DW SLDAX ;LDAX/STAX
DW SLHLD ;LHLD/SHLD/LDA/STA
DW SACCR ;ACCUM-REGISTER
DW SINC ;INC/DCR
DW SINX ;INX/DCX
DW SRST ;RESTART
DW SIN ;IN/OUT
;
SSIMP: ;SIMPLE OPERATION CODES
CALL FILHB ;SEND HEX VALUE TO MACHINE CODE FILE
CALL SCAN ;TO NEXT TOKEN
JMP INCPC
;
SLXI: ;LXI H,16B
CALL SHDREG ;SCAN DOUBLE PRECISION REGISTER
CALL CHCOM ;CHECK FOR COMMA FOLLOWING REGISTER
CALL SETADR ;SCAN AND EMIT DOUBLE PRECISION OPERAND
JMP INCPC
;
SDAD: ;DAD B
CALL SHDREG ;SCAN AND EMIT DOUBLE PRECISION REGISTER
JMP INCPC
;
SPUSH: ;PUSH B POP D
CALL SHREG ;SCAN SINGLE PRECISION REGISTER TO A
CPI 111000B ;MAY BE PSW
JZ SPU0
; NOT PSW, MUST BE B,D, OR H
ANI 001000B ;LOW BIT MUST BE 0
CNZ ERRR ;REGISTER ERROR IF NOT
SPU0: MOV A,C ;RECALL REGISTER AND MASK IN CASE OF ERROR
ANI 110000B
ORA B ;MASK IN OPCODE FOR PUSH OR POP
JMP FILINC ;FILL HEX VALUE AND INCREMENT PC
;
SJMP: ;JMP 16B/ CALL 16B
CALL FILHB ;EMIT JMP OR CALL OPCODE
CALL SETADR ;EMIT 16BIT OPERAND
JMP INCPC
;
SMOV: ;MOV A,B
CALL SHREG
ORA B ;MASK IN OPCODE
MOV B,A ;SAVE IN B TEMPORARILY
CALL CHCOM ;MUST BE COMMA SEPARATOR
CALL EXP3 ;VALUE MUST BE 0-7
ORA B ;MASK IN OPCODE
JMP FILINC
;
SMVI: ;MVI A,8B
CALL SHREG
ORA B ;MASK IN OPCODE
CALL FILHEX ;EMIT OPCODE
CALL CHCOM ;SCAN COMMA
CALL SETBYTE ;EMIT 8BIT VALUE
JMP INCPC
;
SACCI: ;ADI 8B
CALL FILHB ;EMIT IMMEDIATE OPCODE
CALL SETBYTE ;EMIT 8BIT OPERAND
JMP INCPC
;
SLDAX: ;LDAX B/STAX D
CALL SHREG
ANI 101000B ;MUST BE B OR D
CNZ ERRR ;REGISTER ERROR IF NOT
MOV A,C ;RECOVER REGISTER NUMBER
ANI 010000B ;CHANGE TO B OR D IF ERROR
ORA B ;MASK IN OPCODE
JMP FILINC ;EMIT OPCODE
;
SLHLD: ;LHLD 16B/ SHLD 16B/ LDA 16B/ STA 16B
CALL FILHB ;EMIT OPCODE
CALL SETADR ;EMIT OPERAND
JMP INCPC
;
SACCR: ;ADD B
CALL EXP3 ;RIGHT ADJUSTED 3BIT VALUE FOR REGISTER
ORA B ;MASK IN OPCODE
JMP FILINC
;
SINC: ;INR B/DCR D
CALL SHREG ;GET REGISTER
ORA B
JMP FILINC
;
SINX: ;INX H/DCX B
CALL SHREG
ANI 001000B ;MUST BE B D M OR SP
CNZ ERRR ;REGISTER ERROR IF NOT
MOV A,C ;RECOVER REGISTER
ANI 110000B ;IN CASE OF ERROR
ORA B ;MASK IN OPCODE
JMP FILINC
;
SRST: ;RESTART 4
CALL SHREG ;VALUE IS 0-7
ORA B ;OPCODE MASKED
JMP FILINC
;
SIN: ;IN 8B/OUT 8B
CALL FILHB ;EMIT OPCODE
CALL SETBYTE ;EMIT 8BIT OPERAND
JMP INCPC
;
FILINC: ;FILL HEX VALUE FROM A BEFORE INCREMENTING PC
CALL FILHEX
;
INCPC: ;CHANGE ASSEMBLER'S PSEUDO PROGRAM COUNTER
CALL FILAB ;SET ANY LABELS WHICH OCCUR ON THE LINE
CALL SETAS ;ASPC=FPC
JMP CHEND ;END OF LINE SCAN
;
;
; UTILITY SUBROUTINES FOR OPERATION CODES
;
DELIM: ;CHECK DELIMITER SYNTAX FOR DATA STATEMENTS
LDA TOKEN
CPI SPECL
CNZ ERRD
LDA ACCUM
CPI ','
RZ
CPI ';'
RZ
CPI CR
CNZ ERRD
RET
;
EXP16: ;GET 16BIT VALUE TO H,L
PUSH B
CALL SCAN ;START SCANNING OPERAND FIELD
CALL OPAND
LHLD EVALUE ;VALUE TO H,L
POP B
RET
;
EXP8: ;GET 8BIT VALUE TO REG A
CALL EXP16
MOV A,H
ORA A
CNZ ERRV ;VALUE ERROR IF HIGH BYTE NOT ZERO
MOV A,L
RET
;
EXP3: ;GET 3BIT VALUE TO REG A
CALL EXP8
CPI 8
CNC ERRV ;VALUE ERROR IF >=8
ANI 111B ;REDUCE IF ERROR OCCURS
RET
;
SHREG: ;GET 3BIT VALUE AND SHIFT LEFT BY 3
CALL EXP3
RAL
RAL
RAL
ANI 111000B
MOV C,A ;COPY TO C
RET
;
SHDREG: ;GET DOUBLE REGISTER TO A
CALL SHREG
ANI 001000B ;CHECK FOR A,C,E, OR L
CNZ ERRR ;REGISTER ERROR
MOV A,C ;RECOVER REGISTER
ANI 110000B ;FIX IT IF ERROR OCCURRED
ORA B ;MASK OPCODE
JMP FILHEX ;EMIT IT
;
SETBYTE: ;EMIT 16BIT OPERAND
CALL EXP8
JMP FILHEX
;
SETADR: ;EMIT 16BIT OPERAND
CALL EXP16
JMP FILADR
;
CHCOM: ;CHECK FOR COMMA FOLLOWING EXPRESSION
PUSH PSW
PUSH B
LDA TOKEN
CPI SPECL
JNZ COMER
; SPECIAL CHARACTER, CHECK FOR COMMA
LDA ACCUM
CPI ','
JZ COMRET ;RETURN IF COMMA FOUND
COMER: ;COMMA ERROR
MVI A,'C'
CALL PERR
COMRET:
POP B
POP PSW
RET
;
CHEND: ;END OF LINE CHECK
CALL FILAB ;IN CASE OF A LABEL
LDA TOKEN
CPI SPECL
JNZ STERR ;MUST BE A SPECIAL CHARACTER
LDA ACCUM
CPI CR ;CARRIAGE RETURN
JNZ CHEN0
; CARRIAGE RETURN FOUND, SCAN PICKS UP LF AND PUSHES LINE
CALL SCAN
JMP SCNEXT
;
CHEN0: ;NOT CR, CHECK FOR COMMENT
CPI ';'
JNZ CHEN2
CALL FILAB ;IN CASE LABELLED EMPTY LINE
; CLEAR COMMENT TO END OF LINE
CHEN1: CALL SCAN
LDA TOKEN
CPI SPECL
JNZ CHEN1
LDA ACCUM
CPI LF
JZ SCNEXT
CPI EOF
JZ ENDAS ;END OF ASSEMBLY IF EOF
CPI '!'
JZ SCNEXT ;LOGICAL END OF LINE
JMP CHEN1 ;NONE OF THE ABOVE
;
; NOT CR OR LF, MAY BE LOGICAL END OF LINE
CHEN2: CPI '!'
JZ SCNEXT
CPI EOF
JZ ENDAS
;
; STATEMENT ERROR IN OPERAND FIELD
STERR: MVI A,'S'
CALL PERR
JMP CHEN1 ;TO DUMP LINE
;
DIFF: ;COMPUTE DE-HL TO HL
MOV A,E
SUB L
MOV L,A
MOV A,D
SBB H
MOV H,A
RET
;
ENDAS: ;END OF ASSEMBLY FOR THIS PASS
LXI H,PASS
MOV A,M
INR M ;PASS NUMBER INCREMENTED
ORA A
JZ RESTART
CALL SCAN ;TO CLEAR LAST LINE FEED
CALL PADD ;WRITE LAST ADDRESS
LXI H,PBUFF+5
MVI M,CR ;SET TO CR FOR END OF MESSAGE
LXI H,PBUFF+1
CALL PCON ;PRINT LAST ADDRESS
;
; COMPUTE REMAINING SPACE
LHLD SYTOP
XCHG
LHLD SYBAS
CALL DIFF ;DIFFERENCE TO H,L
PUSH H ;SYTOP-SYBAS TO STACK
LHLD SYMAX
XCHG
LHLD SYBAS
CALL DIFF ;SYMAX-SYBAS TO H,L
MOV E,H
MVI D,0 ;DIVIDED BY 256
POP H ;SYTOP-SYBAS TO H,L
CALL DIVF ;RESULT TO DE
XCHG
CALL PADDR ;PRINT H,L TO PBUFF
LXI H,PBUFF+5 ;MESSAGE
LXI D,EMSG ;END MESSAGE
ENDA0: LDAX D
ORA A ;ZERO?
JZ ENDA1
MOV M,A
INX H
INX D
JMP ENDA0
;
EMSG: DB 'H USE FACTOR',CR,0
;
ENDA1: LXI H,PBUFF+2 ;BEGINNING OF RATIO
CALL PCON
LHLD EPC
SHLD FPC ;END PROGRAM COUNTER
JMP EOR
;
; UTILITY SUBROUTINES
COMDH: ;COMPARE D,E WITH H,L FOR EQUALITY (NZ FLAG IF NOT EQUAL)
MOV A,D
CMP H
RNZ
MOV A,E
CMP L
RET
;
SETAS: ;ASPC=FPC
LHLD FPC
SHLD ASPC
RET
;
SETLA: ;SYADR=SYLAB, FOLLOWED BY CHECK FOR ZERO
LHLD SYLAB
SHLD SYADR
CALL FOUND
RET
;
FILAB: ;FILL LABEL VALUE WITH CURRENT ASPC, IF LABEL FOUND
CALL SETLA
RZ ;RETURN IF NO LABEL DETECTED
;
; LABEL FOUND, MUST BE DEFINED ON PASS-1
LXI H,0
SHLD SYLAB ;TO MARK NEXT STATEMENT WITH NO LABEL
LDA PASS
ORA A
JNZ FIL1
;
; PASS 0
CALL GETTY
PUSH PSW ;SAVE A COPY OF TYPE
ANI 111B ;CHECK FOR UNDEFINED
CNZ ERRL ;LABEL ERROR
POP PSW ;RESTORE TYPE
ORI PLABT ;SET TO LABEL TYPE
CALL SETTY ;SET TYPE FIELD
LHLD ASPC ;GET CURRENT PC
CALL SETVAL ;PLACE INTO VALUE FIELD
RET
;
FIL1: ;CHECK FOR DEFINED VALUE
CALL GETTY
ANI 111B
CZ ERRP ;PHASE ERROR
; GET VALUE AND COMPARE WITH ASPC
CALL GETVAL ;TO H,L
XCHG
LHLD ASPC
CALL COMDH
CNZ ERRP ;PHASE ERROR IF NOT THE SAME
RET
;
FILHEX: ;WRITE HEX BYTE IN REGISTER A TO MACHINE CODE FILE IF PASS-1
MOV B,A
FILHB: LDA PASS
ORA A
MOV A,B
JZ FILHI
;
; PASS - 1, WRITE HEX AND PRINT DATA
PUSH B ;SAVE A COPY
CALL DHEX ;INTO MACHINE CODE FILE
; MAY BE COMPLETELY EMPTY LINE, SO CHECK ADDRESS
LDA PBUFF+1
CPI ' '
LHLD ASPC
CZ PADDR ;PRINT ADDRESS FIELD
;
LDA NBP
CPI NBMAX ;TRUNCATE CODE IF TOO MUCH ON THIS LINE
POP B ;RECALL HEX DIGIT
JNC FILHI
; ROOM FOR DIGIT ON THIS LINE
MOV A,B
CALL WHEXB ;WRITE HEX BYTE TO PRINT LINE
FILHI: LHLD FPC
INX H
SHLD FPC ;READY FOR NEXT BYTE
RET
;
FILADR: ;EMIT DOUBLE PRECISION VALUE FROM H,L
PUSH H ;SAVE A COPY
MOV B,L
CALL FILHB ;LOW BYTE EMITTED
POP H ;RECOVER A COPY OF H,L
MOV B,H
JMP FILHB ;EMIT HIGH BYTE AND RETURN
;
; UTILITY FUNCTIONS FOR PRINTING HEX ADDRESSES AND DATA
CHEX: ;CONVERT TO HEX
ADI '0'
CPI '0'+10
RC
ADI 'A'-'0'-10
RET
;
WHEXN: ;WRITE HEX NIBBLE
CALL CHEX ;CONVERT TO ASCII FROM HEX
LXI H,NBP
MOV E,M ;NEXT POSITION TO PRINT
MVI D,0 ;DOUBLE PRECISION
INR M ;NBP=NBP+1
LXI H,PBUFF
DAD D
MOV M,A ;STORE IN PRINT BUFFER
RET
;
WHEXB: ;WRITE HEX BYTE TO PRINT BUFFER
PUSH PSW
RAR
RAR
RAR
RAR
ANI 0FH ;HIGH ORDER NIBBLE NORMALIZE IN A
CALL WHEXN ;WRITE IT
POP PSW
ANI 0FH
JMP WHEXN ;WRITE AND RETURN
;
PADD: LHLD ASPC
PADDR: ;PRINT ADDRESS FIELD OF PRINT LINE FROM H,L
XCHG
LXI H,NBP ;INITIALIZE NEXT TO FILL
PUSH H ;SAVE A COPY OF NBP'S ADDRESS
MVI M,1
MOV A,D ;PRINT HIGH BYTE
PUSH D ;SAVE A COPY
CALL WHEXB
POP D
MOV A,E
CALL WHEXB
POP H ;ADDRESSING NBP
INR M ;SKIP A SPACE AFTER ADDRESS FIELD
RET
;
ERRR: ;EMIT REGISTER ERROR
PUSH PSW
PUSH B
MVI A,'R'
CALL PERR
POP B
POP PSW
RET
;
ERRV: ;EMIT VALUE ERROR
PUSH PSW
PUSH H
MVI A,'V'
CALL PERR
POP H
POP PSW
RET
;
ERRD: PUSH PSW
MVI A,'D' ;DATA ERROR
JMP ERR
;
ERRP: PUSH PSW
MVI A,'P'
JMP ERR
;
ERRL: PUSH PSW
MVI A,'L' ;LABEL ERROR
JMP ERR
;
ERRN: PUSH PSW
MVI A,'N' ;NOT IMPLEMENTED
;
ERR:
CALL PERR
POP PSW
RET
;
SYLAB: DS 2 ;ADDRESS OF LINE LABEL
EPC: DS 2 ;END PC VALUE
NBP: DS 1 ;NEXT BYTE POSITION TO WRITE FOR MACHINE CODE
END


6055
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/BDOS30.ASM Normal file
View File

File diff suppressed because it is too large Load Diff

2807
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CCP3.ASM Normal file
View File

File diff suppressed because it is too large Load Diff

16
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/COMLIT.LIT Normal file
View File

@@ -0,0 +1,16 @@
declare
lit literally 'literally',
dcl lit 'declare',
true lit '0ffh',
false lit '0',
boolean lit 'byte',
forever lit 'while true',
cr lit '13',
lf lit '10',
tab lit '9',
ctrlc lit '3',
ff lit '12',
page$len$offset lit '1ch',
nopage$mode$offset lit '2Ch',
sectorlen lit '128';

903
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CONBDOS.ASM Normal file
View File

@@ -0,0 +1,903 @@
title 'CP/M Bdos Interface, Bdos, Version 3.0 Nov, 1982'
;*****************************************************************
;*****************************************************************
;** **
;** B a s i c D i s k O p e r a t i n g S y s t e m **
;** **
;** C o n s o l e P o r t i o n **
;** **
;*****************************************************************
;*****************************************************************
;
; November 1982
;
;
; Console handlers
;
conin:
;read console character to A
lxi h,kbchar! mov a,m! mvi m,0! ora a! rnz
;no previous keyboard character ready
jmp coninf ;get character externally
;ret
;
conech:
LXI H,STA$RET! PUSH H
CONECH0:
;read character with echo
call conin! call echoc! JC CONECH1 ;echo character?
;character must be echoed before return
push psw! mov c,a! call tabout! pop psw
RET
CONECH1:
CALL TEST$CTLS$MODE! RNZ
CPI CTLS! JNZ CONECH2
CALL CONBRK2! JMP CONECH0
CONECH2:
CPI CTLQ! JZ CONECH0
CPI CTLP! JZ CONECH0
RET
;
echoc:
;echo character if graphic
;cr, lf, tab, or backspace
cpi cr! rz ;carriage return?
cpi lf! rz ;line feed?
cpi tab! rz ;tab?
cpi ctlh! rz ;backspace?
cpi ' '! ret ;carry set if not graphic
;
CONSTX:
LDA KBCHAR! ORA A! JNZ CONB1
CALL CONSTF! ANI 1! RET
;
if BANKED
SET$CTLS$MODE:
;SET CTLS STATUS OR INPUT FLAG FOR QUEUE MANAGER
LXI H,QFLAG! MVI M,40H! XTHL! PCHL
endif
;
TEST$CTLS$MODE:
;RETURN WITH Z FLAG RESET IF CTL-S CTL-Q CHECKING DISABLED
MOV B,A! LDA CONMODE! ANI 2! MOV A,B! RET
;
conbrk: ;check for character ready
CALL TEST$CTLS$MODE! JNZ CONSTX
lda kbchar! ora a! jnz CONBRK1 ;skip if active kbchar
;no active kbchar, check external break
;DOES BIOS HAVE TYPE AHEAD?
if BANKED
LDA TYPE$AHEAD! INR A! JZ CONSTX ;YES
endif
;CONBRKX CALLED BY CONOUT
CONBRKX:
;HAS CTL-S INTERCEPT BEEN DISABLED?
CALL TEST$CTLS$MODE! RNZ ;YES
;DOES KBCHAR CONTAIN CTL-S?
LDA KBCHAR! CPI CTLS! JZ CONBRK1 ;YES
if BANKED
CALL SET$CTLS$MODE
endif
;IS A CHARACTER READY FOR INPUT?
call constf
if BANKED
POP H! MVI M,0
endif
ani 1! rz ;NO
;character ready, read it
if BANKED
CALL SET$CTLS$MODE
endif
call coninf
if BANKED
POP H! MVI M,0
endif
CONBRK1:
cpi ctls! jnz conb0 ;check stop screen function
;DOES KBCHAR CONTAIN A CTL-S?
LXI H,KBCHAR! CMP M! JNZ CONBRK2 ;NO
MVI M,0 ; KBCHAR = 0
;found ctls, read next character
CONBRK2:
if BANKED
CALL SET$CTLS$MODE
endif
call coninf ;to A
if BANKED
POP H! MVI M,0
endif
cpi ctlc! JNZ CONBRK3
LDA CONMODE! ANI 08H! JZ REBOOTX
XRA A
CONBRK3:
SUI CTLQ! RZ ; RETURN WITH A = ZERO IF CTLQ
INR A! CALL CONB3! JMP CONBRK2
conb0:
LXI H,KBCHAR
MOV B,A
;IS CONMODE(1) TRUE?
LDA CONMODE! RAR! JNC $+7 ;NO
;DOES KBCHAR = CTLC?
MVI A,CTLC! CMP M! RZ ;YES - RETURN
MOV A,B
CPI CTLQ! JZ CONB2
CPI CTLP! JZ CONB2
;character in accum, save it
MOV M,A
conb1:
;return with true set in accumulator
mvi a,1! ret
CONB2:
XRA A! MOV M,A! RET
CONB3:
CZ TOGGLE$LISTCP
MVI C,7! CNZ CONOUTF
RET
;
TOGGLE$LISTCP:
; IS PRINTER ECHO DISABLED?
LDA CONMODE! ANI 14H! JNZ TOGGLE$L1 ;YES
LXI H,LISTCP! MVI A,1! XRA M! ANI 1
MOV M,A! RET
TOGGLE$L1:
XRA A! RET
;
QCONOUTF:
;DOES FX = INPUT?
LDA FX! DCR A! JZ CONOUTF ;YES
;IS ESCAPE SEQUENCE DECODING IN EFFECT?
MOV A,B! ANI 8! JNZ SCONOUTF ;YES
JMP CONOUTF
;
conout:
;compute character position/write console char from C
;compcol = true if computing column position
lda compcol! ora a! jnz compout
;write the character, then compute the column
;write console character from C
;B ~= 0 -> ESCAPE SEQUENCE DECODING
LDA CONMODE! ANI 14H! MOV B,A
push b
;CALL CONBRKX FOR OUTPUT FUNCTIONS ONLY
LDA FX! DCR A! CNZ CONBRKX
pop b! push b ;recall/save character
call QCONOUTF ;externally, to console
pop b
;SKIP ECHO WHEN CONMODE & 14H ~= 0
MOV A,B! ORA A! JNZ COMPOUT
push b ;recall/save character
;may be copying to the list device
lda listcp! ora a! cnz listf ;to printer, if so
pop b ;recall the character
compout:
mov a,c ;recall the character
;and compute column position
lxi h,column ;A = char, HL = .column
cpi rubout! rz ;no column change if nulls
inr m ;column = column + 1
cpi ' '! rnc ;return if graphic
;not graphic, reset column position
dcr m ;column = column - 1
mov a,m! ora a! rz ;return if at zero
;not at zero, may be backspace or end line
mov a,c ;character back to A
cpi ctlh! jnz notbacksp
;backspace character
dcr m ;column = column - 1
ret
notbacksp:
;not a backspace character, eol?
cpi cr! rnz ;return if not
;end of line, column = 0
mvi m,0 ;column = 0
ret
;
ctlout:
;send C character with possible preceding up-arrow
mov a,c! call echoc ;cy if not graphic (or special case)
jnc tabout ;skip if graphic, tab, cr, lf, or ctlh
;send preceding up arrow
push psw! mvi c,ctl! call conout ;up arrow
pop psw! ori 40h ;becomes graphic letter
mov c,a ;ready to print
if BANKED
call chk$column! rz
endif
;(drop through to tabout)
;
tabout:
;IS FX AN INPUT FUNCTION?
LDA FX! DCR A! JZ TABOUT1 ;YES - ALWAYS EXPAND TABS FOR ECHO
;HAS TAB EXPANSION BEEN DISABLED OR
;ESCAPE SEQUENCE DECODING BEEN ENABLED?
LDA CONMODE! ANI 14H! JNZ CONOUT ;YES
TABOUT1:
;expand tabs to console
mov a,c! cpi tab! jnz conout ;direct to conout if not
;tab encountered, move to next tab position
tab0:
if BANKED
lda fx! cpi 1! jnz tab1
call chk$column! rz
tab1:
endif
mvi c,' '! call conout ;another blank
lda column! ani 111b ;column mod 8 = 0 ?
jnz tab0 ;back for another if not
ret
;
;
backup:
;back-up one screen position
call pctlh
if BANKED
lda comchr! cpi ctla! rz
endif
mvi c,' '! call conoutf
; (drop through to pctlh) ;
pctlh:
;send ctlh to console without affecting column count
mvi c,ctlh! jmp conoutf
;ret
;
crlfp:
;print #, cr, lf for ctlx, ctlu, ctlr functions
;then move to strtcol (starting column)
mvi c,'#'! call conout
call crlf
;column = 0, move to position strtcol
crlfp0:
lda column! lxi h,strtcol
cmp m! rnc ;stop when column reaches strtcol
mvi c,' '! call conout ;print blank
jmp crlfp0
;;
;
crlf:
;carriage return line feed sequence
mvi c,cr! call conout! mvi c,lf! jmp conout
;ret
;
print:
;print message until M(BC) = '$'
LXI H,OUTDELIM
ldax b! CMP M! rz ;stop on $
;more to print
inx b! push b! mov c,a ;char to C
call tabout ;another character printed
pop b! jmp print
;
QCONIN:
if BANKED
lhld apos! mov a,m! sta ctla$sw
endif
;IS BUFFER ADDRESS = 0?
LHLD CONBUFFADD! MOV A,L! ORA H! JZ CONIN ;YES
;IS CHARACTER IN BUFFER < 5?
if BANKED
call qconinx ; mov a,m with bank 1 switched in
else
MOV A,M
endif
INX H
ORA A! JNZ QCONIN1 ; NO
LXI H,0
QCONIN1:
SHLD CONBUFFADD! SHLD CONBUFFLEN! RNZ ; NO
JMP CONIN
if BANKED
chk$column:
lda conwidth! mov e,a! lda column! cmp e! ret
;
expand:
xchg! lhld apos! xchg
expand1:
ldax d! ora a! rz
inx d! inx h! mov m,a! inr b! jmp expand1
;
copy$xbuff:
mov a,b! ora a! rz
push b! mov c,b! push h! xchg! inx d
lxi h,xbuff
call move
mvi m,0! shld xpos
pop h! pop b! ret
;
copy$cbuff:
lda ccpflgs+1! ral! rnc
lxi h,xbuff! lxi d,cbuff! inr c! jnz copy$cbuff1
xchg! mov a,b! ora a! rz
sta cbuff$len
push d! lxi b,copy$cbuff2! push b
mov b,a
copy$cbuff1:
inr b! mov c,b! jmp move
copy$cbuff2:
pop h! dcx h! mvi m,0! ret
;
save$col:
lda column! sta save$column! ret
;
clear$right:
lda column! lxi h,ctla$column! cmp m! rnc
mvi c,20h! call conout! jmp clear$right
;
reverse:
lda save$column! lxi h,column! cmp m! rnc
mvi c,ctlh! call conout! jmp reverse
;
chk$buffer$size:
push b! push h
lhld apos! mvi e,0
cbs1:
mov a,m! ora a! jz cbs2
inr e! inx h! jmp cbs1
cbs2:
mov a,b! add e! cmp c
push a! mvi c,7! cnc conoutf
pop a! pop h! pop b! rc
pop d! pop d! jmp readnx
;
refresh:
lda ctla$sw! ora a! rz
lda comchr! cpi ctla! rz
cpi ctlf! rz
cpi ctlw! rz
refresh0:
push h! push b
call save$col
lhld apos
refresh1:
mov a,m! ora a! jz refresh2
mov c,a! call chk$column! jc refresh05
mov a,e! sta column! jmp refresh2
refresh05:
push h! call ctlout
pop h! inx h! jmp refresh1
refresh2:
lda column! sta new$ctla$col
refresh3:
call clear$right
call reverse
lda new$ctla$col! sta ctla$column
pop b! pop h! ret
;
init$apos:
lxi h,aposi! shld apos
xra a! sta ctla$sw
ret
;
init$xpos:
lxi h,xbuff! shld xpos! ret
;
set$ctla$column:
lxi h,ctla$sw! mov a,m! ora a! rnz
inr m! lda column! sta ctla$column! ret
;
readi:
call chk$column! cnc crlf
lda cbuff$len! mov b,a
mvi c,0! call copy$cbuff
else
readi:
MOV A,D! ORA E! JNZ READ
LHLD DMAAD! SHLD INFO
INX H! INX H! SHLD CONBUFFADD
endif
read: ;read to info address (max length, current length, buffer)
if BANKED
call init$xpos
call init$apos
readx:
call refresh
xra a! sta ctlw$sw
readx1:
endif
MVI A,1! STA FX
lda column! sta strtcol ;save start for ctl-x, ctl-h
lhld info! mov c,m! inx h! push h
XRA A! MOV B,A! STA SAVEPOS
CMP C! JNZ $+4
INR C
;B = current buffer length,
;C = maximum buffer length,
;HL= next to fill - 1
readnx:
;read next character, BC, HL active
push b! push h ;blen, cmax, HL saved
readn0:
if BANKED
lda ctlw$sw! ora a! cz qconin
nxtline:
sta comchr
else
CALL QCONIN ;next char in A
endif
;ani 7fh ;mask parity bit
pop h! pop b ;reactivate counters
cpi cr! jz readen ;end of line?
cpi lf! jz readen ;also end of line
if BANKED
cpi ctlf! jnz not$ctlf
do$ctlf:
call chk$column! dcr e! cmp e! jnc readnx
do$ctlf0:
xchg! lhld apos! mov a,m! ora a! jz ctlw$l15
inx h! shld apos! xchg! jmp notr
not$ctlf:
cpi ctlw! jnz not$ctlw
do$ctlw:
xchg! lhld apos! mov a,m! ora a! jz ctlw$l1
xchg! call chk$column! dcr e! cmp e! xchg! jc ctlw$l0
xchg! call refresh0! xchg! jmp ctlw$l13
ctlw$l0:
lhld apos! mov a,m
inx h! shld apos! jmp ctlw$l3
ctlw$l1:
lxi h,ctla$sw! mov a,m! mvi m,0
ora a! jz ctlw$l2
ctlw$l13:
lxi h,ctlw$sw! mvi m,0
ctlw$l15:
xchg! jmp readnx
ctlw$l2:
lda ctlw$sw! ora a! jnz ctlw$l25
mov a,b! ora a! jnz ctlw$l15
call init$xpos
ctlw$l25:
lhld xpos! mov a,m! ora a
sta ctlw$sw! jz ctlw$l15
inx h! shld xpos
ctlw$l3:
lxi h,ctlw$sw! mvi m,ctlw
xchg! jmp notr
not$ctlw:
cpi ctla! jnz not$ctla
do$ctla:
;do we have any characters to back over?
lda strtcol! mov d,a! lda column! cmp d
jz readnx
sta compcol ;COL > 0
mov a,b! ora a! jz linelen
;characters remain in buffer, backup one
dcr b ;remove one character
;compcol > 0 marks repeat as length compute
;backup one position in xbuff
push h
call set$ctla$column
pop d
lhld apos! dcx h
shld apos! ldax d! mov m,a! xchg! jmp linelen
not$ctla:
cpi ctlb! jnz not$ctlb
do$ctlb:
lda save$pos! cmp b! jnz ctlb$l0
mvi a,ctlw! sta ctla$sw
sta comchr! jmp do$ctlw
ctlb$l0:
xchg! lhld apos! inr b
ctlb$l1:
dcr b! lda save$pos! cmp b! jz ctlb$l2
dcx h! ldax d! mov m,a! dcx d! jmp ctlb$l1
ctlb$l2:
shld apos
push b! push d
call set$ctla$column
ctlb$l3:
lda column! mov b,a
lda strtcol! cmp b! jz read$n0
mvi c,ctlh! call conout! jmp ctlb$l3
not$ctlb:
cpi ctlk! jnz not$ctlk
xchg! lxi h,aposi! shld apos
xchg! call refresh
jmp readnx
not$ctlk:
cpi ctlg! jnz not$ctlg
lda ctla$sw! ora a! jz readnx
jmp do$ctlf0
not$ctlg:
endif
cpi ctlh! jnz noth ;backspace?
LDA CTLH$ACT! INR A! JZ DO$RUBOUT
DO$CTLH:
;do we have any characters to back over?
LDA STRTCOL! MOV D,A! LDA COLUMN! CMP D
jz readnx
STA COMPCOL ;COL > 0
MOV A,B! ORA A! JZ $+4
;characters remain in buffer, backup one
dcr b ;remove one character
;compcol > 0 marks repeat as length compute
jmp linelen ;uses same code as repeat
noth:
;not a backspace
cpi rubout! jnz notrub ;rubout char?
LDA RUBOUT$ACT! INR A! JZ DO$CTLH
DO$RUBOUT:
if BANKED
mvi a,rubout! sta comchr
lda ctla$sw! ora a! jnz do$ctlh
endif
;rubout encountered, rubout if possible
mov a,b! ora a! jz readnx ;skip if len=0
;buffer has characters, resend last char
mov a,m! dcr b! dcx h ;A = last char
;blen=blen-1, next to fill - 1 decremented
jmp rdech1 ;act like this is an echo
notrub:
;not a rubout character, check end line
cpi ctle! jnz note ;physical end line?
;yes, save active counters and force eol
push b! MOV A,B! STA SAVE$POS
push h
if BANKED
lda ctla$sw! ora a! cnz clear$right
endif
call crlf
if BANKED
call refresh
endif
xra a! sta strtcol ;start position = 00
jmp readn0 ;for another character
note:
;not end of line, list toggle?
cpi ctlp! jnz notp ;skip if not ctlp
;list toggle - change parity
push h ;save next to fill - 1
PUSH B
XRA A! CALL CONB3
POP B
pop h! jmp readnx ;for another char
notp:
;not a ctlp, line delete?
cpi ctlx! jnz notx
pop h ;discard start position
;loop while column > strtcol
backx:
lda strtcol! lxi h,column
if BANKED
cmp m! jc backx1
lhld apos! mov a,m! ora a! jnz readx
jmp read
backx1:
else
cmp m! jnc read ;start again
endif
dcr m ;column = column - 1
call backup ;one position
jmp backx
notx:
;not a control x, control u?
;not control-X, control-U?
cpi ctlu! jnz notu ;skip if not
if BANKED
xthl! call copy$xbuff! xthl
endif
;delete line (ctlu)
do$ctlu:
call crlfp ;physical eol
pop h ;discard starting position
jmp read ;to start all over
notu:
;not line delete, repeat line?
cpi ctlr! jnz notr
XRA A! STA SAVEPOS
if BANKED
xchg! call init$apos! xchg
mov a,b! ora a! jz do$ctlu
xchg! lhld apos! inr b
ctlr$l1:
dcr b! jz ctlr$l2
dcx h! ldax d! mov m,a! dcx d
jmp ctlr$l1
ctlr$l2:
shld apos! push b! push d
call crlfp! mvi a,ctlw! sta ctlw$sw
sta ctla$sw! jmp readn0
endif
linelen:
;repeat line, or compute line len (ctlh)
;if compcol > 0
push b! call crlfp ;save line length
pop b! pop h! push h! push b
;bcur, cmax active, beginning buff at HL
rep0:
mov a,b! ora a! jz rep1 ;count len to 00
inx h! mov c,m ;next to print
DCR B
POP D! PUSH D! MOV A,D! SUB B! MOV D,A
push b! push h ;count length down
LDA SAVEPOS! CMP D! CC CTLOUT
pop h! pop b ;recall remaining count
jmp rep0 ;for the next character
rep1:
;end of repeat, recall lengths
;original BC still remains pushed
push h ;save next to fill
lda compcol! ora a ;>0 if computing length
jz readn0 ;for another char if so
;column position computed for ctlh
lxi h,column! sub m ;diff > 0
sta compcol ;count down below
;move back compcol-column spaces
backsp:
;move back one more space
call backup ;one space
lxi h,compcol! dcr m
jnz backsp
if BANKED
call refresh
endif
jmp readn0 ;for next character
notr:
;not a ctlr, place into buffer
;IS BUFFER FULL?
PUSH A
MOV A,B! CMP C! JC RDECH0 ;NO
;DISCARD CHARACTER AND RING BELL
POP A! PUSH B! PUSH H
MVI C,7! CALL CONOUTF! JMP READN0
RDECH0:
if BANKED
lda comchr! cpi ctlg! jz rdech05
lda ctla$sw! ora a! cnz chk$buffer$size
rdech05:
endif
POP A
inx h! mov m,a ;character filled to mem
inr b ;blen = blen + 1
rdech1:
;look for a random control character
push b! push h ;active values saved
mov c,a ;ready to print
if BANKED
call save$col
endif
call ctlout ;may be up-arrow C
pop h! pop b
if BANKED
lda comchr! cpi ctlg! jz do$ctlh
cpi rubout! jz rdech2
call refresh
rdech2:
endif
LDA CONMODE! ANI 08H! JNZ NOTC
mov a,m ;recall char
cpi ctlc ;set flags for reboot test
mov a,b ;move length to A
jnz notc ;skip if not a control c
cpi 1 ;control C, must be length 1
jz REBOOTX ;reboot if blen = 1
;length not one, so skip reboot
notc:
;not reboot, are we at end of buffer?
if BANKED
cmp c! jnc buffer$full
else
jmp readnx ;go for another if not
endif
if BANKED
push b! push h
call chk$column! jc readn0
lda ctla$sw! ora a! jz do$new$line
lda comchr! cpi ctlw! jz back$one
cpi ctlf! jz back$one
do$newline:
mvi a,ctle! jmp nxtline
back$one:
;back up to previous character
pop h! pop b
dcr b! xchg
lhld apos! dcx h! shld apos
ldax d! mov m,a! xchg! dcx h
push b! push h! call reverse
;disable ctlb or ctlw
xra a! sta ctlw$sw! jmp readn0
buffer$full:
xra a! sta ctlw$sw! jmp readnx
endif
readen:
;end of read operation, store blen
if BANKED
call expand
endif
pop h! mov m,b ;M(current len) = B
if BANKED
push b
call copy$xbuff
pop b
mvi c,0ffh! call copy$cbuff
endif
LXI H,0! SHLD CONBUFFADD
mvi c,cr! jmp conout ;return carriage
;ret
;
func1 equ CONECH
;return console character with echo
;
func2: equ tabout
;write console character with tab expansion
;
func3:
;return reader character
call readerf
jmp sta$ret
;
;func4: equated to punchf
;write punch character
;
;func5: equated to listf
;write list character
;write to list device
;
func6:
;direct console i/o - read if 0ffh
mov a,c! inr a! jz dirinp ;0ffh => 00h, means input mode
inr a! JZ DIRSTAT ;0feh => direct STATUS function
INR A! JZ DIRINP1 ;0fdh => direct input, no status
JMP CONOUTF
DIRSTAT:
;0feH in C for status
CALL CONSTX! JNZ LRET$EQ$FF! JMP STA$RET
dirinp:
CALL CONSTX ;status check
ora a! RZ ;skip, return 00 if not ready
;character is ready, get it
dirinp1:
call CONIN ;to A
jmp sta$ret
;
func7:
call auxinstf
jmp sta$ret
;
func8:
call auxoutstf
jmp sta$ret
;
func9:
;write line until $ encountered
xchg ;was lhld info
mov c,l! mov b,h ;BC=string address
jmp print ;out to console
func10 equ readi
;read a buffered console line
func11:
;IS CONMODE(1) TRUE?
LDA CONMODE! RAR! JNC NORMAL$STATUS ;NO
;CTL-C ONLY STATUS CHECK
if BANKED
LXI H,QFLAG! MVI M,80H! PUSH H
endif
LXI H,CTLC$STAT$RET! PUSH H
;DOES KBCHAR = CTL-C?
LDA KBCHAR! CPI CTLC! JZ CONB1 ;YES
;IS THERE A READY CHARACTER?
CALL CONSTF! ORA A! RZ ;NO
;IS THE READY CHARACTER A CTL-C?
CALL CONINF! CPI CTLC! JZ CONB0 ;YES
STA KBCHAR! XRA A! RET
CTLC$STAT$RET:
if BANKED
CALL STA$RET
POP H! MVI M,0! RET
else
JMP STA$RET
endif
NORMAL$STATUS:
;check console status
call conbrk
;(drop through to sta$ret)
sta$ret:
;store the A register to aret
sta aret
func$ret: ;
ret ;jmp goback (pop stack for non cp/m functions)
;
setlret1:
;set lret = 1
mvi a,1! jmp sta$ret ;
;
FUNC109: ;GET/SET CONSOLE MODE
;DOES DE = 0FFFFH?
MOV A,D! ANA E! INR A
LHLD CONMODE! JZ STHL$RET ;YES - RETURN CONSOLE MODE
XCHG! SHLD CONMODE! RET ;NO - SET CONSOLE MODE
;
FUNC110: ;GET/SET FUNCTION 9 DELIMITER
LXI H,OUT$DELIM
;DOES DE = 0FFFFH?
MOV A,D! ANA E! INR A
MOV A,M! JZ STA$RET ;YES - RETURN DELIMITER
MOV M,E! RET ;NO - SET DELIMITER
;
FUNC111: ;PRINT BLOCK TO CONSOLE
FUNC112: ;LIST BLOCK
XCHG! MOV E,M! INX H! MOV D,M! INX H
MOV C,M! INX H! MOV B,M! XCHG
;HL = ADDR OF STRING
;BC = LENGTH OF STRING
BLK$OUT:
MOV A,B! ORA C! RZ
PUSH B! PUSH H! MOV C,M
LDA FX! CPI 111! JZ BLK$OUT1
CALL LISTF! JMP BLK$OUT2
BLK$OUT1:
CALL TABOUT
BLK$OUT2:
POP H! INX H! POP B! DCX B
JMP BLK$OUT
SCONOUTF EQU CONOUTF
;
; data areas
;
compcol:db 0 ;true if computing column position
strtcol:db 0 ;starting column position after read
if not BANKED
kbchar: db 0 ;initial key char = 00
endif
SAVEPOS:DB 0 ;POSITION IN BUFFER CORRESPONDING TO
;BEGINNING OF LINE
if BANKED
comchr: db 0
cbuff$len: db 0
cbuff: ds 256
db 0
xbuff: db 0
ds 354
aposi: db 0
xpos: dw 0
apos: dw 0
ctla$sw: db 0
ctlw$sw: db 0
save$column: db 0
ctla$column: db 0
new$ctla$col: db 0
endif
; end of BDOS Console module


9
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/COPYRT.LIT Normal file
View File

@@ -0,0 +1,9 @@
/*
Copyright (C) 1982
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
*/


836
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/COPYSYS.ASM Normal file
View File

@@ -0,0 +1,836 @@
title 'Copysys - updated sysgen program 6/82'
; System generation program
VERS equ 30 ;version x.x for CP/M x.x
;
;**********************************************************
;* *
;* *
;* Copysys source code *
;* *
;* *
;**********************************************************
;
FALSE equ 0
TRUE equ not FALSE
;
;
NSECTS equ 26 ;no. of sectors
NTRKS equ 2 ;no. of systems tracks
NDISKS equ 4 ;no. of disks drives
SECSIZ equ 128 ;size of sector
LOG2SEC equ 7 ;LOG2 128
SKEW equ 2 ;skew sector factor
;
FCB equ 005Ch ;location of FCB
FCBCR equ FCB+32 ;current record location
TPA equ 0100h ;Transient Program Area
LOADP equ 1000h ;LOAD Point for system
BDOS equ 05h ;DOS entry point
BOOT equ 00h ;reboot for system
CONI equ 1h ;console input function
CONO equ 2h ;console output function
SELD equ 14 ;select a disk
OPENF equ 15 ;disk open function
CLOSEF equ 16 ;open a file
DWRITF equ 21 ;Write func
MAKEF equ 22 ;mae a file
DELTEF equ 19 ;delete a file
DREADF equ 20 ;disk read function
DRBIOS equ 50 ;Direct BIOS call function
EIGHTY equ 080h ;value of 80
CTLC equ 'C'-'@' ;ConTroL C
Y equ 89 ;ASCII value of Y
;
MAXTRY equ 01 ;maximum number of tries
CR equ 0Dh ;Carriage Return
LF equ 0Ah ;Line Feed
STACKSIZE equ 016h ;size of local stack
;
WBOOT equ 01 ;address of warm boot
;
SELDSK equ 9 ;Bios func #9 SELect DiSK
SETTRK equ 10 ;BIOS func #10 SET TRacK
SETSEC equ 11 ;BIOS func #11 SET SECtor
SETDMA equ 12 ;BIOS func #12 SET DMA address
READF equ 13 ;BIOS func #13 READ selected sector
WRITF equ 14 ;BIOS func #14 WRITe selected sector
;
org TPA ;Transient Program Area
jmp START
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0
db 0,0,0
db 'COPYRIGHT 1982, '
db 'DIGITAL RESEARCH'
db '151282'
db 0,0,0,0
db '654321'
;
; Translate table-sector numbers are translated here to decrease
; the systen tie for missed sectors when slow controllers are
; involved. Translate takes place according to the "SKEW" factor
; set above.
;
OST: db NTRKS ;operating system tracks
SPT: db NSECTS ;sectors per track
TRAN:
TRELT set 1
TRBASE set 1
rept NSECTS
db TRELT ;generate first/next sector
TRELT set TRELT+SKEW
if TRELT gt NSECTS
TRBASE set TRBASE+1
TRELT set TRBASE
endif
endm
;
; Now leave space for extensions to translate table
;
if NSECTS lt 64
rept 64-NSECTS
db 0
endm
endif
;
; Utility subroutines
;
MLTBY3:
;multiply the contents of regE to get jmp address
mov a,e ;Acc = E
sui 1
mov e,a ;get ready for multiply
add e
add e
mov e,a
ret ;back at it
;
SEL:
sta TEMP
lda V3FLG
cpi TRUE
lda TEMP
jnz SEL2
;
sta CREG ;CREG = selected register
lxi h,0000h
shld EREG ;for first time
mvi a,SELDSK
sta BIOSFC ;store it in func space
mvi c,DRBIOS
lxi d,BIOSPB
jmp BDOS
SEL2:
mov c,a
lhld WBOOT
lxi d,SELDSK
call MLTBY3
dad d
pchl
;
TRK:
; Set up track
sta TEMP
lda V3FLG
cpi TRUE
lda TEMP
jnz TRK2
;
mvi a,00h
sta BREG ;zero out B register
mov a,c ;Acc = track #
sta CREG ;set up PB
mvi a,SETTRK ;settrk func #
sta BIOSFC
mvi c,DRBIOS
lxi d,BIOSPB
jmp BDOS
TRK2:
lhld WBOOT
lxi d,SETTRK
call MLTBY3
dad d
pchl ;gone to set track
;
SEC:
; Set up sector number
sta TEMP
lda V3FLG
cpi TRUE
lda TEMP
jnz SEC2
;
mvi a,00h
sta BREG ;zero out BREG
mov a,c ; Acc = C
sta CREG ;CREG = sector #
mvi a,SETSEC
sta BIOSFC ;set up bios call
mvi c,DRBIOS
lxi d,BIOSPB
jmp BDOS
SEC2:
lhld WBOOT
lxi d,SETSEC
call MLTBY3
dad d
pchl
;
DMA:
; Set DMA address to value of BC
sta TEMP
lda V3FLG
cpi TRUE
lda TEMP
jnz DMA2
;
mov a,b ;
sta BREG ;
mov a,c ;Set up the BC
sta CREG ;register pair
mvi a,SETDMA ;
sta BIOSFC ;set up bios #
mvi c,DRBIOS
lxi d,BIOSPB
jmp BDOS
DMA2:
lhld WBOOT
lxi d,SETDMA
call MLTBY3
dad d
pchl
;
READ:
; Perform read operation
sta TEMP
lda V3FLG
cpi TRUE
lda TEMP
jnz READ2
;
mvi a,READF
sta BIOSFC
mvi c,DRBIOS
lxi d,BIOSPB
jmp BDOS
READ2:
lhld WBOOT
lxi d,READF
call MLTBY3
dad d
pchl
;
WRITE:
; Perform write operation
sta TEMP
lda V3FLG
cpi TRUE
lda TEMP
jnz WRITE2
;
mvi a,WRITF
sta BIOSFC ;set up bios #
mvi c,DRBIOS
lxi d,BIOSPB
jmp BDOS
WRITE2:
lhld WBOOT
lxi d,WRITF
call MLTBY3
dad d
pchl
;
MULTSEC:
; Multiply the sector # in rA by the sector size
mov l,a
mvi h,0 ;sector in hl
rept LOG2SEC
dad h
endm
ret ;with HL - sector*sectorsize
;
GETCHAR:
; Read console character to rA
mvi c,CONI
call BDOS
; Convert to upper case
cpi 'A' or 20h
rc
cpi ('Z' or 20h)+1
rnc
ani 05Fh
ret
;
PUTCHAR:
; Write character from rA to console
mov e,a
mvi c,CONO
call BDOS
ret
;
CRLF:
; Send Carriage Return, Line Feed
mvi a,CR
call PUTCHAR
mvi a,LF
call PUTCHAR
ret
;
CRMSG:
; Print message addressed by the HL until zero with leading CRLF
push d
call CRLF
pop d ;drop through to OUTMSG
OUTMSG:
mvi c,9
jmp BDOS
;
SELCT:
; Select disk given by rA
mvi c,0Eh
jmp BDOS
;
DWRITE:
; Write for file copy
mvi c,DWRITF
jmp BDOS
;
DREAD:
; Disk read function
mvi c,DREADF
jmp BDOS
;
OPEN:
; File open function
mvi c,OPENF
jmp BDOS
;
CLOSE:
mvi c,CLOSEF
jmp BDOS
;
MAKE:
mvi c,MAKEF
jmp BDOS
;
DELETE:
mvi c,DELTEF
jmp BDOS
;
;
;
DSTDMA:
mvi c,26
jmp BDOS
;
SOURCE:
lxi d,GETPRM ;ask user for source drive
call CRMSG
call GETCHAR ;obtain response
cpi CR ;is it CR?
jz DFLTDR ;skip if CR only
cpi CTLC ;isit ^C?
jz REBOOT
;
sui 'A' ;normalize drive #
cpi NDISKS ;valid drive?
jc GETC ;skip to GETC if so
;
; Invalid drive
call BADDISK ;tell user bad drive
jmp SOURCE ;try again
;
GETC:
; Select disk given by Acc.
adi 'A'
sta GDISK ;store source disk
sui 'A'
mov e,a ;move disk into E for select func
call SEL ;select the disk
jmp GETVER
;
DFLTDR:
mvi c,25 ;func 25 for current disk
call BDOS ;get curdsk
adi 'A'
sta GDISK
call CRLF
lxi d,VERGET
call OUTMSG
jmp VERCR
;
GETVER:
; Getsys set r/w to read and get the system
call CRLF
lxi d,VERGET ;verify source disk
call OUTMSG
VERCR: call GETCHAR
cpi CR
jnz REBOOT ;jmp only if not verified
call CRLF
ret
;
DESTIN:
lxi d,PUTPRM ;address of message
call CRMSG ;print it
call GETCHAR ;get answer
cpi CR
jz REBOOT ;all done
sui 'A'
cpi NDISKS ;valid disk
jc PUTC
;
; Invalid drive
call BADDISK ;tell user bad drive
jmp PUTSYS ;to try again
;
PUTC:
; Set disk fron rA
adi 'A'
sta PDISK ;message sent
sui 'A'
mov e,a ;disk # in E
call SEL ;select destination drive
; Put system, set r/w to write
lxi d,VERPUT ;verify dest prmpt
call CRMSG ;print it out
call GETCHAR ;retrieve answer
cpi CR
jnz REBOOT ;exit to system if error
call CRLF
ret
;
;
GETPUT:
; Get or put CP/M (rw = 0 for read, 1 for write)
; disk is already selected
lxi h,LOADP ;load point in RAM for DMA address
shld DMADDR
;
;
;
;
; Clear track 00
mvi a,-1 ;
sta TRACK
;
RWTRK:
; Read or write next track
lxi h,TRACK
inr m ;track = track+1
lda OST ;# of OS tracks
cmp m ;=track # ?
jz ENDRW ;end of read/write
;
; Otherwise not done
mov c,m ;track number
call TRK ;set to track
mvi a,-1 ;counts 0,1,2,...,25
sta SECTOR
;
RWSEC:
; Read or write a sector
lda SPT ;sectors per track
lxi h,SECTOR
inr m ;set to next sector
cmp m ;A=26 and M=0,1,..,25
jz ENDTRK
;
; Read or write sector to or from current DMA address
lxi h,SECTOR
mov e,m ;sector number
mvi d,0 ;to DE
lxi h,TRAN
mov b,m ;tran(0) in B
dad d ;sector translated
mov c,m ;value to C ready for select
push b ;save tran(0)
call SEC
pop b ;recall tran(0),tran(sector)
mov a,c ;tran(sector)
sub b ;--tran(sector)
call MULTSEC ;*sector size
xchg ;to DE
lhld DMADDR ;base DMA
dad d
mov b,h
mov c,l ;to set BC for SEC call
call DMA ;dma address set from BC
xra a
sta RETRY ;to set zero retries
;
TRYSEC:
; Try to read or write current sector
lda RETRY
cpi MAXTRY
jc TRYOK
;
; Past MAXTRY, message and ignore
lxi d,ERRMSG
call OUTMSG
call GETCHAR
cpi CR
jnz REBOOT
;
; Typed a CR, ok to ignore
call CRLF
jmp RWSEC
;
TRYOK:
; Ok to tyr read write
inr a
sta RETRY
lda RW
ora a
jz TRYREAD
;
; Must be write
call WRITE
jmp CHKRW
TRYREAD:
call READ
CHKRW:
ora a
jz RWSEC ;zero flag if read/write ok
;
;Error, retry operation
jmp TRYSEC
;
; End of track
ENDTRK:
lda SPT ;sectors per track
call MULTSEC ;*secsize
xchg ; to DE
lhld DMADDR ;base dma for this track
dad d ;+spt*secsize
shld DMADDR ;ready for next track
jmp RWTRK ;for another track
;
ENDRW:
; End of read or write
ret
;
;*******************
;*
;* MAIN ROUTINE
;*
;*
;*******************
;
START:
lxi sp,STACK
lxi d,SIGNON
call OUTMSG
;
;get version number to check compatability
mvi c,12 ;version check
call BDOS
mov a,l ;version in Acc
cpi 30h ;version 3 or newer?
jc OLDRVR ;
mvi a,TRUE
sta V3FLG ;
jmp FCBCHK
OLDRVR:
mvi a,FALSE
sta V3FLG
;
; Check for default file liad instead of get
FCBCHK: lda FCB+1 ;blank if no file
cpi ' '
jz GETSYS ;skip to system message
lxi d,FCB ;try to open it
call OPEN
inr a ;255 becomes 00
jnz RDOK
;
; File not present
lxi d,NOFILE
call CRMSG
jmp REBOOT
;
;file present
RDOK:
xra a
sta FCBCR ;current record = 0
lxi h,LOADP
RDINP:
push h
mov b,h
mov c,l
call DMA ;DMA address set
lxi d,FCB ;ready fr read
call DREAD
pop h ;recall
ora a ;00 if read ok
jnz PUTSYS ;assume eof if not
; More to read continue
lxi d,SECSIZ
dad d ;HL is new load address
jmp RDINP
;
GETSYS:
call SOURCE ;find out source drive
;
xra a ;zero out a
sta RW ;RW = 0 to signify read
call GETPUT ;get or read system
lxi d,DONE ;end message of get or read func
call OUTMSG ;print it out
;
; Put the system
PUTSYS:
call DESTIN ;get dest drive
;
lxi h,RW ;load address
mvi m,1
call GETPUT ;to put system back on disk
lxi d,DONE
call OUTMSG ;print out end prompt
;
; FILE COPY FOR CPM.SYS
;
CPYCPM:
; Prompt the user for the source of CP/M3.SYS
;
lxi d,CPYMSG ;print copys prompt
call CRMSG ;print it
call GETCHAR ;obtain reply
cpi Y ;is it yes?
jnz REBOOT ;if not exit
;else
;
;
mvi c,13 ;func # for reset
call BDOS ;
inr a
lxi d,ERRMSG
cz FINIS
;
call SOURCE ;get source disk for CPM3.SYS
CNTNUE:
lda GDISK ;Acc = source disk
sui 'A'
mvi d,00h
mov e,a ;DE = selected disk
call SELCT
; now copy the FCBs
mvi c,36 ;for copy
lxi d,SFCB ;source file
lxi h,DFCB ;destination file
MFCB:
ldax d
inx d ;ready next
mov m,a
inx h ;ready next dest
dcr c ;decrement coun
jnz MFCB
;
lda GDISK ;Acc = source disk
sui 40h ;correct disk
lxi h,SFCB
mov m,a ;SFCB has source disk #
lda PDISK ;get the dest. disk
lxi h,DFCB ;
sui 040h ;normalize disk
mov m,a
;
xra a ;zero out a
sta DFCBCR ;current rec = 0
;
; Source and destination fcb's ready
;
lxi d,SFCB ;
call OPEN ;open the file
lxi d,NOFILE ;error messg
inr a ;255 becomes 0
cz FINIS ;done if no file
;
; Source file is present and open
lxi d,LOADP ;get DMA address
xchg ;move address to HL regs
shld BEGIN ;save for begin of write
;
lda BEGIN ;get low byte of
mov l,a ;DMA address into L
lda BEGIN+1 ;
mov h,a ;into H also
COPY1:
xchg ;DE = address of DMA
call DSTDMA ;
;
lxi d,SFCB ;
call DREAD ;read next record
ora a ;end of file?
jnz EOF ;skip write if so
;
lda CRNREC
inr a ;bump it
sta CRNREC
;
lda BEGIN
mov l,a
lda BEGIN+1
mov h,a
lxi d,EIGHTY
dad d ;add eighty to begin address
shld BEGIN
jmp COPY1 ;loop until EOF
;
EOF:
lxi d,DONE
call OUTMSG
;
COPY2:
call DESTIN ;get destination drive for CPM3.SYS
lxi d,DFCB ;set up dest FCB
xchg
lda PDISK
sui 040h ;normalize disk
mov m,a ;correct disk for dest
xchg ;DE = DFCB
call DELETE ;delete file if there
;
lxi d,DFCB ;
call MAKE ;make a new one
lxi d,NODIR
inr a ;check directory space
cz FINIS ;end if none
;
lxi d,LOADP
xchg
shld BEGIN
;
lda BEGIN
mov l,a
lda BEGIN+1
mov h,a
LOOP2:
xchg
call DSTDMA
lxi d,DFCB
call DWRITE
lxi d,FSPACE
ora a
cnz FINIS
lda CRNREC
dcr a
sta CRNREC
cpi 0
jz FNLMSG
lda BEGIN
mov l,a
lda BEGIN+1
mov h,a
lxi d,EIGHTY
dad d
shld BEGIN
jmp LOOP2
; Copy operation complete
FNLMSG:
lxi d,DFCB
mvi c,CLOSEF
call BDOS
;
lxi d,DONE
;
FINIS:
; Write message given by DE, reboot
call OUTMSG
;
REBOOT:
mvi c,13
call BDOS
call CRLF
jmp BOOT
;
BADDISK:
lxi d,QDISK
call CRMSG
ret
;****************************
;*
;*
;* DATA STRUCTURES
;*
;*
;****************************
;
BIOSPB:
; BIOS Parameter Block
BIOSFC: db 0 ;BIOS function number
AREG: db 0 ;A register contents
CREG: db 0 ;C register contents
BREG: db 0 ;B register contents
EREG: db 0 ;E register contents
DREG: db 0 ;D register contents
HLREG: dw 0 ;HL register contents
;
SFCB:
DR: ds 1
F1F8: db 'CPM3 '
T1T3: db 'SYS'
EXT: db 0
CS: db 0
RS: db 0
RCC: db 0
D0D15: ds 16
CCR: db 0
R0R2: ds 3
;
DFCB: ds 36
DFCBCR equ DFCB+32
;
;
V3FLG: db 0 ;flag for version #
TEMP: db 0
SDISK: ds 1 ;selected disk
BEGIN: dw 0
DFLAG: db 0
TRACK: ds 1 ;current track
CRNREC: db 0 ;current rec count
SECTOR: ds 1 ;current sector
RW: ds 1 ;read if 0 write if 1
DMADDR: ds 2 ;current DMA address
RETRY: ds 1 ;number of tries on this sector
SIGNON: db 'CP/M 3 COPYSYS - Version '
db VERS/10+'0','.',VERS mod 10 +'0'
db '$'
GETPRM: db 'Source drive name (or return for default) $'
VERGET: db 'Source on '
GDISK: ds 1
db ' then type return $'
PUTPRM: db 'Destination drive name (or return to reboot) $'
VERPUT: db 'Destination on '
PDISK: ds 1
db ' then type return $'
CPYMSG: db 'Do you wish to copy CPM3.SYS? $'
DONE: db 'Function complete$'
;
; Error messages......
;
QDISK: db 'ERROR: Invalid drive name (Use A, B, C, or D)$'
NOFILE: db 'ERROR: No source file on disk.$'
NODIR: db 'ERROR: No directory space.$'
FSPACE: db 'ERROR: Out of data space.$'
WRPROT: db 'ERROR: Write protected?$'
ERRMSG: db 'ERROR: Possible incompatible disk format.'
db CR,LF,' Type return to ignore.$'
CLSERR: db 'ERROR: Close operation failed.$'
;
ds STACKSIZE * 3
STACK:
end


107
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPM3ASM1.SUB Normal file
View File

@@ -0,0 +1,107 @@
;
; COPYSYS Generation
;
device conout=crt
vax $$as\sd mason.cpm30.sources\ar
vax copysys.asm $$stran
device conout=crt,lpt
mac copysys
xref copysys
zero
hexcom copysys
device conout=crt
vax $$as\sd mason.cpm30.listing\ar
vax copysys.xrf $$stran
device conout=crt,lpt
era *.prn
<y
era *.hex
<y
era *.sym
<y
;
; DUMP Generation
;
device conout=crt
vax $$as\sd mason.cpm30.sources\ar
vax dump.asm $$stran
device conout=crt,lpt
mac dump
xref dump
zero
hexcom dump
device conout=crt
vax $$as\sd mason.cpm30.listing\ar
vax dump.xrf $$stran
device conout=crt,lpt
era *.prn
<y
era *.hex
<y
era *.sym
<y
;
; HEXCOM Generation
;
device conout=crt
vax $$as\sd mason.cpm30.sources\ar
vax hexcom.asm $$stran
device conout=crt,lpt
mac hexcom
xref hexcom
zero
hexcom hexcom
device conout=crt
vax $$as\sd mason.cpm30.listing\ar
vax hexcom.xrf $$stran
device conout=crt,lpt
era *.prn
<y
era *.hex
<y
era *.sym
<y
;
; PATCH Generation
;
device conout=crt
vax $$as\sd mason.cpm30.sources\ar
vax patch.asm $$stran
device conout=crt,lpt
mac patch
xref patch
zero
hexcom patch
device conout=crt
vax $$as\sd mason.cpm30.listing\ar
vax patch.xrf $$stran
device conout=crt,lpt
era *.prn
<y
era *.hex
<y
era *.sym
<y
;
; SAVE Generation
;
device conout=crt
vax $$as\sd mason.cpm30.sources\ar
vax save.asm $$stran
device conout=crt,lpt
rmac save
link save.rsx=save[op]
gencom save [null]
xref save
device conout=crt
vax $$as\sd mason.cpm30.listing\ar
vax save.xrf $$stran
device conout=crt,lpt
era *.prn
<y
era *.hex
<y
era *.sym
<y
cpm3asm2


114
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPM3ASM2.SUB Normal file
View File

@@ -0,0 +1,114 @@
;
; BDOS3 Generation
;
device conout=crt
vax $$as\sd mason.cpm30.sources\ar
vax cpmbdos1.asm $$stran
vax conbdos.asm $$stran
vax bdos30.asm $$stran
device conout=crt,lpt
pip cpmbdosx.asm=cpmbdos1.asm,conbdos.asm,bdos30.asm
rmac cpmbdosx
link bdos3=cpmbdosx[os,$$sz]
xref cpmbdosx
device conout=crt
vax $$as\sd mason.cpm30.listing\ar
vax cpmbdosx.xrf $$stran
device conout=crt,lpt
era *.prn
<y
era cpmbdosx.rel
<y
era *.sym
<y
era *.xrf
<y
;
; BNKBDOS3 Generation
;
device conout=crt
vax $$as\sd mason.cpm30.sources\ar
vax bdos30.asm $$stran
device conout=crt,lpt
pip cpmbdos.asm=cpmbdos2.asm,conbdos.asm,bdos30.asm
rmac cpmbdos
link bnkbdos3=cpmbdos[os,$$sz]
xref cpmbdos
device conout=crt
vax $$as\sd mason.cpm30.listing\ar
vax cpmbdos.xrf $$stran
device conout=crt,lpt
era *.prn
<y
era cpmbdos.rel
era *.sym
<y
era *.xrf
<y
;
; CCP Generation
;
device conout=crt
vax $$as\sd mason.cpm30.sources\ar
vax ccp3.asm $$sanr
vax loader3.asm $$sanr
device conout=crt,lpt
;phase errors intended for checking CCP3.ASM and DATE.ASM equates
RMAC LOADER3
xref loader3
LINK LOADER3[OP]
;phase errors intended for checking LOADER.ASM equates
mac ccp3
;the fill instruction below is not essential
;the addresses depend on the loader and ccp origins
;and size, they
;should be changed if the loader RSX module grows
;the d display of 380-400h should reveal 1Ahs at the
;end of the bit map and in front of the 42eH CCP origin
;DATE must be origined in the LOADER patch area
mac date
SID LOADER3.PRL
<M200,500,100
<d380,400
<f400,1000,0
<eccp3.hex
<edate.hex
<wccp.com,100,d80
<g0
rmac ccp3
xref ccp3
device conout=crt
vax $$as\sd mason.cpm30.listing\ar
vax loader3.xrf $$sanr
vax ccp3.xrf $$sanr
device conout=crt,lpt
era *.hex
<y
era *.prn
<y
era ccp3.rel
era *.sym
<y
era *.xrf
<y
;
; CPMLDR Generation
;
device conout=crt
vax $$as\sd mason.cpm30.sources\ar
vax cpmldr.asm $$stran
device conout=crt,lpt
rmac cpmldr
xref cpmldr
device conout=crt
vax $$as\sd mason.cpm30.listing\ar
vax cpmldr.xrf $$stran
device conout=crt,lpt
era *.prn
<y
era *.sym
<y
era *.xrf
<y
cpm3asm3


62
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPM3ASM3.SUB Normal file
View File

@@ -0,0 +1,62 @@
;
; RESBDOS3 GENERATION
;
device conout=crt
vax $$as\sd mason.cpm30.sources\ar
vax resbdos.asm $$stran
device conout=crt,lpt
rmac resbdos
xref resbdos
link resbdos3=resbdos[os,$$sz]
device conout=crt
vax $$as\sd mason.cpm30.listing\ar
vax resbdos.xrf $$stran
device conout=crt,lpt
era *.prn
<y
era resbdos.rel
era *.sym
<y
era *.xrf
<y
;
; SID Generation
;
device conout=crt
vax $$as\sd mason.cpm30.sources\ar
vax prs0mov.asm $$stran
vax prs1asm.asm $$stran
vax prs2mon.asm $$stran
device conout=crt,lpt
mac prs1asm
mac prs2mon
xref prs1asm
xref prs2mon
ren prs1asm0.hex = prs1asm.hex
ren prs2mon0.hex = prs2mon.hex
mac prs1asm $$pz-s+r
mac prs2mon $$pz-s+r
ren prs1asm1.hex = prs1asm.hex
ren prs2mon1.hex = prs2mon.hex
mac prs0mov
xref prs0mov
copy relprsid.hex = prs1asm0.hex[i],prs2mon0.hex,prs1asm1.hex[i],prs2mon1.hex
genmod relprsid.hex relprsid.com
sid relprsid.com
<rprs0mov.hex
<wsid.com,100,1fff
<g0
device conout=crt
vax $$as\sd mason.cpm30.listing\ar
vax prs0mov.xrf $$stran
vax prs1asm.xrf $$starn
vax prs2mon.xrf $$Stran
device counout=crt,lpt
era *.prn
<y
era *.hex
<y
era *.sym
<y
cpm3pli1


69
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPM3PLI1.SUB Normal file
View File

@@ -0,0 +1,69 @@
; compile and link initdir
; needs
; diomod.dcl
; plibios.dcl
; mcd80d.rel
; assemble plibios3
device conout=crt
vax $$as\sd mason.cpm30.sources\ar
vax plibios3.asm $$stran
vax plidio.asm $$stran
vax initdir.pli $$stran
device conout=crt,lpt
rmac plibios3
xref plibios3
; assemble plidio
rmac plidio
xref plidio
; compile initdir
rmac mcd80d
xref mcd80d
pli initdir $$dl
link initdir=mcd80d,initdir,plidio,plibios3[a]
; finished building initdir
device conout=crt
vax $$as\sd mason.cpm30.listing\ar
vax plibios3.xrf $$stran
vax plidio.xrf $$stran
vax initdir.prn $$stran
vax mcd80d.xrf $$stranf
device conout=crt,lpt
era initdir.prn
era initdir.sym
era initdir.xrf
era plibios3.prn
era plibios3.sym
era plibios3.xrf
era plidio.prn
era plidio.sym
era plidio.xrf
;
; submit to assemble, link and gencom DIRLBL
device conout=crt
vax $$as\sd mason.cpm30.sources\ar
vax dirlbl.asm $$stran
device conout=crt,lpt
rmac dirlbl
xref dirlbl
link dirlbl[op,a]
era dirlbl.rsx
ren dirlbl.rsx=dirlbl.prl
gencom set.com dirlbl.rsx
device conout=crt
vax $$as\sd mason.cpm30.listing\ar
vax dirlbl.xrf $$stran
device conout=crt,lpt
era dirlbl.prn
era dirlbl.sym
era dirlbl.xrf
;
; Finish DIRLBL.RSX
;
gencom put.com put.rsx
gencom submit.com sub.rsx
gencom get.com get.rsx
;
;
era *.xrf
<y


27
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPM3PLM0.SUB Normal file
View File

@@ -0,0 +1,27 @@
; CPM 3 PLM PROGRAM GENERATION SUBMIT #0
;
; MCD MODULE GENERATIONS
;
stat con:=tty:
vax $$as\sd mason.cpm30.sources\ar
vax mcd80a.asm $$stran
vax mcd80f.asm $$stran
stat con:=uc1:
seteof mcd80a.asm
seteof mcd80f.asm
seteof parse.asm
is14
asm80 mcd80a.asm debug
asm80 mcd80f.asm debug
asm80 parse.asm debug
cpm
stat con:=tty:
vax $$as\sd mason.cpm30.listing\ar
vax mcd80a.lst $$stran
vax mcd80f.lst $$stran
vax parse.lst $$stran
stat con:=uc1:
era *.lst
;
; CALL CPM3PLM1
SUB CPM3PLM1

103
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPM3PLM1.SUB Normal file
View File

@@ -0,0 +1,103 @@
stat con:=tty:
vax $$as\sd mason.cpm30.sources\ar
vax gencpm.plm $$stran
vax datmod.asm $$stran
vax getdef.plm $$stran
vax setbuf.plm $$stran
vax crdef.plm $$stran
vax ldrlwr.asm $$stran
vax $$as\sd mason.cpm30.listing\ar
stat con:=uc1:
seteof gencpm.plm
seteof datmod.asm
seteof getdef.plm
seteof setbuf.plm
seteof crdef.plm
seteof ldrlwr.asm
is14
plm80 gencpm.plm debug optimize
plm80 getdef.plm debug optimize
plm80 setbuf.plm debug optimize
plm80 crdef.plm debug optimize
asm80 datmod.asm debug
asm80 ldrlwr.asm debug
asm80 mcd80f.asm
link mcd80f.obj,gencpm.obj,setbuf.obj,getdef.obj,crdef.obj,ldrlwr.obj,datmod.obj,plm80.lib to gencpm.mod
locate gencpm.mod code(0100H) stacksize(100)
era gencpm.mod
cpm
zero
objcpm gencpm
stat con:=tty:
vax gencpm.lst $$stran
vax datmod.lst $$stran
vax getdef.lst $$stran
vax setbuf.lst $$stran
vax crdef.lst $$stran
vax ldrlwr.lst $$stran
vax gencpm.sym $$stran
vax gencpm.lin $$stran
stat con:=uc1:
era gencpm
era gencpm.obj
era setbuf.obj
era getdef.obj
era crdef.obj
era ldrlwr.obj
era datmod.obj
era *.lst
era *.sym
era *.lin
stat con:=tty:
vax $$as\sd mason.cpm30.sources\ar
vax help.plm $$stran
seteof help.plm
is14
plm80 help.plm debug optimize
link mcd80a.obj,help.obj,plm80.lib to help.mod
locate help.mod code(0100H) stacksize(100)
era help.mod
cpm
zero
objcpm help
stat con:=tty:
vax $$as\sd mason.cpm30.listing\ar
vax help.lst $$stran
vax help.sym $$stran
vax help.lin $$stran
stat con:=uc1:
era help
era help.obj
era *.lst
era *.sym
era *.lin
stat con:=tty:
vax $$as\sd mason.cpm30.sources\ar
vax pip.plm $$stran
vax inpout.asm $$stran
stat con:=uc1:
seteof pip.plm
seteof inpout.asm
is14
asm80 inpout.asm debug
plm80 pip.plm debug optimize
link mcd80f.obj,inpout.obj,pip.obj,plm80.lib to pip.mod
locate pip.mod code(0100H) stacksize(100)
era pip.mod
cpm
zero
objcpm pip
stat con:=tty:
vax $$as\sd mason.cpm30.listing\ar
vax pip.lst $$stran
vax inpout.lst $$stran
vax pip.sym $$stran
vax pip.lin $$stran
stat con:=uc1:
era pip.obj
era inpout.obj
era *.lst
era *.sym
era *.lin
SUB CPM3PLM2


109
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPM3PLM2.SUB Normal file
View File

@@ -0,0 +1,109 @@
; CPM 3 PLM PROGRAM GENERATION SUBMIT #2
;
; ERASE GENERATION
;
stat con:=tty:
vax $$as\sd mason.cpm30.sources\ar
vax erase.plm $$stran
stat con:=uc1:
seteof erase.plm
is14
plm80 erase.plm pagewidth(100) debug optimize
link mcd80a.obj,erase.obj,parse.obj,plm80.lib to erase.mod
locate erase.mod code(0100H) stacksize(100)
era erase.mod
cpm
zero
objcpm erase
stat con:=tty:
vax $$as\sd mason.cpm30.listing\ar
vax erase.lst $$stran
vax erase.sym $$stran
vax erase.lin $$stran
stat con:=uc1:
era erase.obj
era *.lst
era *.sym
era *.lin
;
; TYPE GENERATION
;
stat con:=tty:
vax $$as\sd mason.cpm30.sources\ar
vax type.plm $$stran
stat con:=uc1:
seteof type.plm
is14
plm80 type.plm pagewidth(100) debug optimize
link mcd80a.obj,type.obj,parse.obj,plm80.lib to type.mod
locate type.mod code(0100H) stacksize(100)
era type.mod
cpm
zero
objcpm type
era type.obj
stat con:=tty:
vax $$as\sd mason.cpm30.listing\ar
vax type.lst $$stran
vax type.sym $$stran
vax type.lin $$stran
stat con:=uc1:
era *.sym
era *.lst
era *.lin
;
; RENAME GENERATION
;
stat con:=tty:
vax $$as\sd mason.cpm30.sources\ar
vax rename.plm $$stran
stat con:=uc1:
seteof rename.plm
is14
plm80 rename.plm pagewidth(100) debug optimize
link mcd80a.obj,rename.obj,parse.obj,plm80.lib to rename.mod
locate rename.mod code(0100H) stacksize(100)
era rename.mod
cpm
zero
objcpm rename
stat con:=tty:
vax $$as\sd mason.cpm30.listing\ar
vax rename.lst $$stran
vax rename.sym $$stran
vax rename.lin $$stran
stat con:=uc1:
era rename.obj
era *.lin
era *.lst
era *.sym
;
; SETDEF GENERATION
;
stat con:=tty:
vax $$as\sd mason.cpm30.sources\ar
vax setdef.plm $$stran
stat con:=uc1:
seteof setdef.plm
is14
plm80 setdef.plm pagewidth(132) debug optimize
link mcd80a.obj,setdef.obj,plm80.lib to setdef.mod
locate setdef.mod code(0100H) stacksize(100)
era setdef.mod
cpm
zero
objcpm setdef
stat con:=tty:
vax $$as\sd mason.cpm30.listing\ar
vax setdef.lst $$stran
vax setdef.sym $$stran
vax setdef.lin $$stran
stat con:=uc1:
era setdef.obj
era *.lst
era *.lin
era *.sym
;
; CALL CPM3PLM3
SUB CPM3PLM3


30
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPM3PLM3.SUB Normal file
View File

@@ -0,0 +1,30 @@
;
; DATE Generation
;
stat con:=tty:
vax $$as\sd mason.cpm30.sources\ar
vax date.plm $$stran
stat con:=uc1:
seteof date.plm
is14
plm80 date.plm pagewidth(100) debug optimize
link mcd80a.obj,date.obj,plm80.lib to date.mod
locate date.mod code(0100H) stacksize(100)
era date.mod
cpm
zero
objcpm date
era date
era date.obj
stat con:=tty:
vax $$as\sd mason.cpm30.listing\ar
vax date.lst $$stran
stat con:=uc1:
era *.lst
era *.lin
era *.sym
;
; Call Next Submit
;
sub cpm3plm4


114
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPM3PLM4.SUB Normal file
View File

@@ -0,0 +1,114 @@
;
; ED Generation
;
stat con:=tty:
vax $$as\sd mason.cpm30.sources\ar
vax ed.plm $$stran
vax copyrt.lit $$stran
stat con:=uc1:
seteof ed.plm
seteof copyrt.lit
is14
plm80 ed.plm optimize debug
link mcd80a.obj,ed.obj,plm80.lib to ed.mod
locate ed.mod code(0100h) stacksize(100) map print(ed.tra)
cpm
zero
objcpm ed
era ed
era ed.obj
stat con:=tty:
vax $$as\sd mason.cpm30.listing\ar
vax ed.lst $$stran
vax ed.sym $$stran
vax ed.lin $$stran
stat con:=uc1:
era *.lst
era *.sym
era *.lin
;
; GENCOM, SET, SHOW Generation
;
stat con:=tty:
vax $$as\sd mason.cpm30.sources\ar
vax gencom.plm $$stran
vax show.plm $$stran
vax set.plm $$stran
vax sopt.inc $$stran
vax sopt.dcl $$stran
stat con:=uc1:
seteof gencom.plm
seteof show.plm
seteof set.plm
seteof sopt.inc
seteof sopt.dcl
era gencom
era show
era set
era gencom.obj
era set.obj
era show.obj
;
; Compile GENCOM
;
is14
PLM80 GENCOM.PLM debug optimize PAGEWIDTH(132)
link mcd80a.obj,parse.obj,GENCOM.obj,plm80.lib to gencom.mod
locate gencom.mod code(0100H) stacksize(100) map print(gencom.tra)
cpm
zero
objcpm gencom
era gencom
era gencom.obj
;
; Compile SHOW
;
is14
PLM80 show.PLM debug optimize PAGEWIDTH(132)
link mcd80a.obj,show.obj,plm80.lib to show.mod
locate show.mod code(0100H) stacksize(100) map print(show.tra)
cpm
zero
objcpm show
era show
era show.obj
;
; Compile SET
;
is14
PLM80 set.PLM debug optimize PAGEWIDTH(132)
link mcd80a.obj,parse.obj,set.obj,plm80.lib to set.mod
locate set.mod code(0100H) stacksize(100) map print(set.tra)
cpm
zero
objcpm set
era set
era set.obj
;
; Print out GENCOM,SET,SHOW Modules
;
stat con:=tty:
vax $$as\sd mason.cpm30.listing
vax gencom.lst $$stran
vax gencom.sym $$stran
vax gencom.lin $$stran
vax set.lst $$stran
vax set.sym $$stran
vax set.lin $$stran
vax show.lst $$stran
vax show.sym $$stran
vax show.lin $$stran
stat con:=uc1:
era set.mod
era set.lin
era set.tra
era show.mod
era show.lin
era show.tra
era gencom.mod
era gencom.lin
era gencom.tra
;
; chain next one
sub cpm3plm5


45
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPM3PLM5.SUB Normal file
View File

@@ -0,0 +1,45 @@
;
; GET Generation
;
stat con:=tty:
vax $$as\sd mason.cpm30.sources\ar
vax get.plm $$stran
;************ !!!!! NOTE !!!!! **************
;GETRSX.ASM IS CONDITIONALLY ASSEMBLED
;SET submit equ false
;********************************************
stat con:=uc1:
seteof get.plm
is14
asm80 getf.asm debug
plm80 get.plm xref pagewidth(100) debug optimize
link mcd80a.obj,get.obj,parse.obj,getf.obj,plm80.lib to get.mod
locate get.mod code(0100H) stacksize(100)
era get.mod
cpm
zero
objcpm get
rmac getrsx
xref getrsx
link getrsx[op]
era get.rsx
ren get.rsx=getrsx.prl
stat con:=tty:
vax $$as\sd mason.cpm30.listing\ar
vax get.lst $$stran
vax get.sym $$stran
vax get.lin $$stran
vax getrsx.prn $$stran
vax getrsx.sym $$stran
stat con:=uc1:
era get
era get.obj
era *.lst
era *.sym
era *.lin
era *.prn
;
; Call next generation
;
sub cpm3plm6


102
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPM3PLM6.SUB Normal file
View File

@@ -0,0 +1,102 @@
; PUT Generation
stat con:=tty:
vax $$as\sd mason.cpm30.sources
vax put.plm $$stran
vax putf.asm $$stran
vax putrsx.asm $$stran
stat con:=uc1:
seteof put.plm
is14
asm80 putf.asm debug
plm80 put.plm xref pagewidth(100) debug optimize
link mcd80a.obj,put.obj,parse.obj,putf.obj,plm80.lib to put.mod
locate put.mod code(0100H) stacksize(100)
era put.mod
cpm
zero
objcpm put
era put
era put.obj
rmac putrsx
xref putrsx
stat con:=tty:
vax $$as\sd mason.cpm30.listing\ar
vax putf.sym $$stran
vax put.lst $$stran
vax put.sym $$stran
vax put.lin $$stran
vax putrsx.prn $$Stran
vax putrsx.sym $$stran
stat con:=uc1:
link putrsx[op]
era put.rsx
ren put.rsx=putrsx.prl
era put
era put.obj
era *.lst
era *.sym
era *.lin
era *.prn
;
stat con:=tty:
vax $$as\sd mason.cpm30.sources\ar
vax submit.plm $$stran
vax getf.asm $$stran
vax getrsx.asm $$stran
stat con:=uc1:
seteof submit.plm
seteof copyrt.lit
is14
asm80 getf.asm debug
plm80 submit.plm xref pagewidth(100) debug optimize
link mcd80a.obj,submit.obj,parse.obj,getf.obj,plm80.lib to submit.mod
locate submit.mod code(0100H) stacksize(100)
era submit.mod
cpm
zero
objcpm submit
rmac subrsx
xref subrsx
stat con:=tty:
vax $$as\sd mason.cpm30.listing\ar
vax submit.lst $$stran
vax submit.sym $$stran
vax submit.lin $$stran
vax getf.sym $$stran
vax getf.lst $$stran
stat con:=uc1:
link subrsx[op]
era sub.rsx
ren sub.rsx=subrsx.prl
era submit
era submit.obj
era *.lst
era *.sym
era *.lin
; DEVICE GENERATION
stat con:=tty:
vax $$as\sd mason.cpm30.sources\ar
vax device.plm $$stran
stat con:=uc1:
seteof device.plm
is14
plm80 device.plm pagewidth(100) debug optimize
link mcd80a.obj,device.obj,plm80.lib to device.mod
locate device.mod code(0100H) stacksize(100)
era device.mod
cpm
zero
objcpm device
stat con:=tty:
vax $$as\sd mason.cpm30.listing\ar
vax device.lst $$stran
vax device.lin $$stran
vax device.sym $$stran
stat con:=uc1:
era device.obj
era device
era *.lst
era *.sym
era *.lin
sub cpm3plm7


62
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPM3PLM7.SUB Normal file
View File

@@ -0,0 +1,62 @@
stat con:=tty:
vax $$as\sd mason.cpm30.sources\ar
vax main.plm $$stran
vax timest.plm $$stran
vax dpb80.plm $$stran
vax disp.plm $$stran
vax main80.plm $$stran
vax scan.plm $$stran
vax util.plm $$stran
vax search.plm $$stran
vax sort.plm $$stran
vax mon.plm $$stran
vax copyrt.lit $$stran
vax comlit.lit $$stran
vax finfo.lit $$stran
vax vers.lit $$stran
vax format.lit $$stran
vax xfcb.lit $$stran
vax dpb.lit $$stran
vax scan.lit $$stran
vax fcb.lit $$stran
vax search.lit $$starn
stat con:=uc1:
seteof main.plm
seteof timest.plm
seteof dpb80.plm
seteof disp.plm
seteof main80.plm
seteof scan.plm
seteof util.plm
seteof search.plm
seteof sort.plm
seteof mon.plm
seteof copyrt.lit
seteof comlit.lit
seteof finfo.lit
seteof vers.lit
seteof format.lit
seteof xfcb.lit
seteof dpb.lit
seteof scan.lit
seteof fcb.lit
seteof search.lit
is14
plm80 main80.plm debug pagewidth(130) optimize object(main80)
plm80 scan.plm debug pagewidth(130) optimize object(scan)
plm80 search.plm debug pagewidth(130) optimize object(search)
plm80 sort.plm debug pagewidth(130) optimize object(sort)
plm80 disp.plm debug pagewidth(130) optimize object(disp)
plm80 dpb80.plm debug pagewidth(130) optimize object(dpb80)
plm80 util.plm debug pagewidth(130) optimize object(util)
plm80 timest.plm debug pagewidth(130) optimize object(timest)
link mcd80a.obj,main80,scan,search,sort,disp,util,dpb80,timest,plm80.lib to dir.lnk
locate dir.lnk code(0100H) stacksize(50)
era dir.lnk
cpm
zero
objcpm dir
;
; next one
sub cpm3plm8


59
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPM3PLM8.SUB Normal file
View File

@@ -0,0 +1,59 @@
stat con:=tty:
vax $$as\sd mason.cpm30.listing\ar
vax main.lst $$stran
vax main.sym $$stran
vax main.lin $$stran
vax timest.lst $$stran
vax timest.sym $$stran
vax timest.lin $$stran
vax dpb80.lst $$stran
vax dpb80.sym $$stran
vax dpb80.lin $$stran
vax disp.lst $$stran
vax disp.sym $$stran
vax disp.lin $$stran
vax main80.lst $$stran
vax main80.sym $$stran
vax main80.lin $$stran
vax scan.lst $$stran
vax scan.sym $$stran
vax scan.lin $$stran
vax util.lst $$stran
vax util.sym $$stran
vax util.lin $$stran
vax search.lst $$stran
vax search.sym $$stran
vax search.lin $$stran
vax sort.lst $$stran
vax sort.sym $$stran
vax sort.lin $$stran
vax mon.lst $$stran
vax mon.sym $$stran
vax mon.lin $$stran
stat con:=uc1:
era *.lst
era *.sym
era *.lin
era *.hex
era *.prn
era main.obj
era main
era timest.obj
era timest
era dpb80.obj
era dpb80
era disp.obj
era disp
era main80.obj
era main80
era scan.obj
era scan
era util.obj
era util
era search.obj
era search
era sort.obj
era sort
era mon.obj
era mon


710
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPMBDOS1.ASM Normal file
View File

@@ -0,0 +1,710 @@
title 'CP/M BDOS Interface, BDOS, Version 3.0 Dec, 1982'
;*****************************************************************
;*****************************************************************
;** **
;** B a s i c D i s k O p e r a t i n g S y s t e m **
;** **
;** I n t e r f a c e M o d u l e **
;** **
;*****************************************************************
;*****************************************************************
;
; Copyright (c) 1978, 1979, 1980, 1981, 1982
; Digital Research
; Box 579, Pacific Grove
; California
;
; December 1982
;
on equ 0ffffh
off equ 00000h
MPM equ off
BANKED equ off
;
; equates for non graphic characters
;
ctla equ 01h ; control a
ctlb equ 02h ; control b
ctlc equ 03h ; control c
ctle equ 05h ; physical eol
ctlf equ 06h ; control f
ctlg equ 07h ; control g
ctlh equ 08h ; backspace
ctlk equ 0bh ; control k
ctlp equ 10h ; prnt toggle
ctlq equ 11h ; start screen
ctlr equ 12h ; repeat line
ctls equ 13h ; stop screen
ctlu equ 15h ; line delete
ctlw equ 17h ; control w
ctlx equ 18h ; =ctl-u
ctlz equ 1ah ; end of file
rubout equ 7fh ; char delete
tab equ 09h ; tab char
cr equ 0dh ; carriage return
lf equ 0ah ; line feed
ctl equ 5eh ; up arrow
org 0000h
base equ $
; Base page definitions
bnkbdos$pg equ base+0fc00h
resbdos$pg equ base+0fd00h
scb$pg equ base+0fb00h
bios$pg equ base+0ff00h
; Bios equates
bios equ bios$pg
bootf equ bios$pg ; 00. cold boot function
if BANKED
wbootf equ scb$pg+68h ; 01. warm boot function
constf equ scb$pg+6eh ; 02. console status function
coninf equ scb$pg+74h ; 03. console input function
conoutf equ scb$pg+7ah ; 04. console output function
listf equ scb$pg+80h ; 05. list output function
else
wbootf equ bios$pg+3 ; 01. warm boot function
constf equ bios$pg+6 ; 02. console status function
coninf equ bios$pg+9 ; 03. console input function
conoutf equ bios$pg+12 ; 04. console output function
listf equ bios$pg+15 ; 05. list output function
endif
punchf equ bios$pg+18 ; 06. punch output function
readerf equ bios$pg+21 ; 07. reader input function
homef equ bios$pg+24 ; 08. disk home function
seldskf equ bios$pg+27 ; 09. select disk function
settrkf equ bios$pg+30 ; 10. set track function
setsecf equ bios$pg+33 ; 11. set sector function
setdmaf equ bios$pg+36 ; 12. set dma function
readf equ bios$pg+39 ; 13. read disk function
writef equ bios$pg+42 ; 14. write disk function
liststf equ bios$pg+45 ; 15. list status function
sectran equ bios$pg+48 ; 16. sector translate
conoutstf equ bios$pg+51 ; 17. console output status function
auxinstf equ bios$pg+54 ; 18. aux input status function
auxoutstf equ bios$pg+57 ; 19. aux output status function
devtblf equ bios$pg+60 ; 20. retunr device table address fx
devinitf equ bios$pg+63 ; 21. initialize device function
drvtblf equ bios$pg+66 ; 22. return drive table address
multiof equ bios$pg+69 ; 23. multiple i/o function
flushf equ bios$pg+72 ; 24. flush function
movef equ bios$pg+75 ; 25. memory move function
timef equ bios$pg+78 ; 26. system get/set time function
selmemf equ bios$pg+81 ; 27. select memory function
setbnkf equ bios$pg+84 ; 28. set dma bank function
xmovef equ bios$pg+87 ; 29. extended move function
if BANKED
; System Control Block equates
olog equ scb$pg+090h
rlog equ scb$pg+092h
SCB equ scb$pg+09ch
; Expansion Area - 6 bytes
hashl equ scb$pg+09ch
hash equ scb$pg+09dh
version equ scb$pg+0a1h
; Utilities Section - 8 bytes
util$flgs equ scb$pg+0a2h
dspl$flgs equ scb$pg+0a6h
; CLP Section - 4 bytes
clp$flgs equ scb$pg+0aah
clp$errcde equ scb$pg+0ach
; CCP Section - 8 bytes
ccp$comlen equ scb$pg+0aeh
ccp$curdrv equ scb$pg+0afh
ccp$curusr equ scb$pg+0b0h
ccp$conbuff equ scb$pg+0b1h
ccp$flgs equ scb$pg+0b3h
; Device I/O Section - 32 bytes
conwidth equ scb$pg+0b6h
column equ scb$pg+0b7h
conpage equ scb$pg+0b8h
conline equ scb$pg+0b9h
conbuffadd equ scb$pg+0bah
conbufflen equ scb$pg+0bch
conin$rflg equ scb$pg+0beh
conout$rflg equ scb$pg+0c0h
auxin$rflg equ scb$pg+0c2h
auxout$rflg equ scb$pg+0c4h
lstout$rflg equ scb$pg+0c6h
page$mode equ scb$pg+0c8h
pm$default equ scb$pg+0c9h
ctlh$act equ scb$pg+0cah
rubout$act equ scb$pg+0cbh
type$ahead equ scb$pg+0cch
contran equ scb$pg+0cdh
conmode equ scb$pg+0cfh
outdelim equ scb$pg+0d3h
listcp equ scb$pg+0d4h
qflag equ scb$pg+0d5h
; BDOS Section - 42 bytes
scbadd equ scb$pg+0d6h
dmaad equ scb$pg+0d8h
olddsk equ scb$pg+0dah
info equ scb$pg+0dbh
resel equ scb$pg+0ddh
relog equ scb$pg+0deh
fx equ scb$pg+0dfh
usrcode equ scb$pg+0e0h
dcnt equ scb$pg+0e1h
;searcha equ scb$pg+0e3h
searchl equ scb$pg+0e5h
multcnt equ scb$pg+0e6h
errormode equ scb$pg+0e7h
searchchain equ scb$pg+0e8h
temp$drive equ scb$pg+0ech
errdrv equ scb$pg+0edh
media$flag equ scb$pg+0f0h
bdos$flags equ scb$pg+0f3h
stamp equ scb$pg+0f4h
commonbase equ scb$pg+0f9h
error equ scb$pg+0fbh ;jmp error$sub
bdosadd equ scb$pg+0feh
; Resbdos equates
resbdos equ resbdos$pg
move$out equ resbdos$pg+9 ; a=bank #, hl=dest, de=srce
move$tpa equ resbdos$pg+0ch ; a=bank #, hl=dest, de=srce
srch$hash equ resbdos$pg+0fh ; a=bank #, hl=hash table addr
hashmx equ resbdos$pg+12h ; max hash search dcnt
rd$dir$flag equ resbdos$pg+14h ; directory read flag
make$xfcb equ resbdos$pg+15h ; make function flag
find$xfcb equ resbdos$pg+16h ; search function flag
xdcnt equ resbdos$pg+17h ; dcnt save for empty fcb,
; user 0 fcb, or xfcb
xdmaad equ resbdos$pg+19h ; resbdos dma copy area addr
curdma equ resbdos$pg+1bh ; current dma
copy$cr$only equ resbdos$pg+1dh ; dont restore fcb flag
user$info equ resbdos$pg+1eh ; user fcb address
kbchar equ resbdos$pg+20h ; conbdos look ahead char
qconinx equ resbdos$pg+21h ; qconin mov a,m routine
ELSE
move$out equ movef
move$tpa equ movef
ENDIF
;
serial: db '654321'
;
; Enter here from the user's program with function number in c,
; and information address in d,e
;
bdose: ; Arrive here from user programs
xchg! shld info! xchg ; info=de, de=info
mov a,c! sta fx! cpi 14! jc bdose2
lxi h,0! shld dircnt ; dircnt,multnum = 0
lda olddsk! sta seldsk ; Set seldsk
if BANKED
dcr a! sta copy$cr$init
ENDIF
; If mult$cnt ~= 1 then read or write commands
; are handled by the shell
lda mult$cnt! dcr a! jz bdose2
lxi h,mult$fxs
bdose1:
mov a,m! ora a! jz bdose2
cmp c! jz shell
inx h! jmp bdose1
bdose2:
mov a,e! sta linfo ; linfo = low(info) - don't equ
lxi h,0! shld aret ; Return value defaults to 0000
shld resel ; resel,relog = 0
; Save user's stack pointer, set to local stack
dad sp! shld entsp ; entsp = stackptr
if not BANKED
lxi sp,lstack ; local stack setup
ENDIF
lxi h,goback ; Return here after all functions
push h ; jmp goback equivalent to ret
mov a,c! cpi nfuncs! jnc high$fxs ; Skip if invalid #
mov c,e ; possible output character to c
lxi h,functab! jmp bdos$jmp
; look for functions 98 ->
high$fxs:
cpi 128! jnc test$152
sui 98! jc lret$eq$ff ; Skip if function < 98
cpi nfuncs2! jnc lret$eq$ff
lxi h,functab2
bdos$jmp:
mov e,a! mvi d,0 ; de=func, hl=.ciotab
dad d! dad d! mov e,m! inx h! mov d,m ; de=functab(func)
lhld info ; info in de for later xchg
xchg! pchl ; dispatched
; CAUTION: In banked systems only,
; error$sub is referenced indirectly by the SCB ERROR
; field in RESBDOS as (0fc7ch). This value is converted
; to the actual address of error$sub by GENSYS. If the offset
; of error$sub is changed, the SCB ERROR value must also
; be changed.
;
; error subroutine
;
error$sub:
mvi b,0! push b! dcr c
lxi h,errtbl! dad b! dad b
mov e,m! inx h! mov d,m! xchg
call errflg
pop b! lda error$mode! ora a! rnz
jmp reboote
mult$fxs: db 20,21,33,34,40,0
if BANKED
db 'COPYRIGHT (C) 1982,'
db ' DIGITAL RESEARCH '
db '151282'
else
db 'COPR. ''82 DRI 151282'
; 31 level stack
dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h
dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h
dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h
dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h
lstack:
endif
; dispatch table for functions
functab:
dw rebootx1, func1, func2, func3
dw punchf, listf, func6, func7
dw func8, func9, func10, func11
diskf equ ($-functab)/2 ; disk funcs
dw func12,func13,func14,func15
dw func16,func17,func18,func19
dw func20,func21,func22,func23
dw func24,func25,func26,func27
dw func28,func29,func30,func31
dw func32,func33,func34,func35
dw func36,func37,func38,func39
dw func40,lret$eq$ff,func42,func43
dw func44,func45,func46,func47
dw func48,func49,func50
nfuncs equ ($-functab)/2
functab2:
dw func98,func99
dw func100,func101,func102,func103
dw func104,func105,func106,func107
dw func108,func109,func110,func111
dw func112
nfuncs2 equ ($-functab2)/2
errtbl:
dw permsg
dw rodmsg
dw rofmsg
dw selmsg
dw 0
dw 0
dw passmsg
dw fxstsmsg
dw wildmsg
test$152:
cpi 152! rnz
;
; PARSE version 3.0b Oct 08 1982 - Doug Huskey
;
;
; DE->.(.filename,.fcb)
;
; filename = [d:]file[.type][;password]
;
; fcb assignments
;
; 0 => drive, 0 = default, 1 = A, 2 = B, ...
; 1-8 => file, converted to upper case,
; padded with blanks (left justified)
; 9-11 => type, converted to upper case,
; padded with blanks (left justified)
; 12-15 => set to zero
; 16-23 => password, converted to upper case,
; padded with blanks
; 24-25 => 0000h
; 26 => length of password (0 - 8)
;
; Upon return, HL is set to FFFFH if DE locates
; an invalid file name;
; otherwise, HL is set to 0000H if the delimiter
; following the file name is a 00H (NULL)
; or a 0DH (CR);
; otherwise, HL is set to the address of the delimiter
; following the file name.
;
lxi h,sthl$ret
push h
lhld info
mov e,m ;get first parameter
inx h
mov d,m
push d ;save .filename
inx h
mov e,m ;get second parameter
inx h
mov d,m
pop h ;DE=.fcb HL=.filename
xchg
parse0:
push h ;save .fcb
xra a
mov m,a ;clear drive byte
inx h
lxi b,20h*256+11
call pad ;pad name and type w/ blanks
lxi b,4
call pad ;EXT, S1, S2, RC = 0
lxi b,20h*256+8
call pad ;pad password field w/ blanks
lxi b,12
call pad ;zero 2nd 1/2 of map, cr, r0 - r2
;
; skip spaces
;
call skps
;
; check for drive
;
ldax d
cpi ':' ;is this a drive?
dcx d
pop h
push h ;HL = .fcb
jnz parse$name
;
; Parse the drive-spec
;
parsedrv:
call delim
jz parse$ok
sui 'A'
jc perror1
cpi 16
jnc perror1
inx d
inx d ;past the ':'
inr a ;set drive relative to 1
mov m,a ;store the drive in FCB(0)
;
; Parse the file-name
;
parse$name:
inx h ;HL = .fcb(1)
call delim
jz parse$ok
lxi b,7*256
parse6: ldax d ;get a character
cpi '.' ;file-type next?
jz parse$type ;branch to file-type processing
cpi ';'
jz parse$pw
call gfc ;process one character
jnz parse6 ;loop if not end of name
jmp parse$ok
;
; Parse the file-type
;
parse$type:
inx d ;advance past dot
pop h
push h ;HL =.fcb
lxi b,9
dad b ;HL =.fcb(9)
lxi b,2*256
parse8: ldax d
cpi ';'
jz parsepw
call gfc ;process one character
jnz parse8 ;loop if not end of type
;
parse$ok:
pop b
push d
call skps ;skip trailing blanks and tabs
dcx d
call delim ;is next nonblank char a delim?
pop h
rnz ;no
lxi h,0
ora a
rz ;return zero if delim = 0
cpi cr
rz ;return zero if delim = cr
xchg
ret
;
; handle parser error
;
perror:
pop b ;throw away return addr
perror1:
pop b
lxi h,0ffffh
ret
;
; Parse the password
;
parsepw:
inx d
pop h
push h
lxi b,16
dad b
lxi b,7*256+1
parsepw1:
call gfc
jnz parsepw1
mvi a,7
sub b
pop h
push h
lxi b,26
dad b
mov m,a
ldax d ;delimiter in A
jmp parse$ok
;
; get next character of name, type or password
;
gfc: call delim ;check for end of filename
rz ;return if so
cpi ' ' ;check for control characters
inx d
jc perror ;error if control characters encountered
inr b ;error if too big for field
dcr b
jm perror
inr c
dcr c
jnz gfc1
cpi '*' ;trap "match rest of field" character
jz setmatch
gfc1: mov m,a ;put character in fcb
inx h
dcr b ;decrement field size counter
ora a ;clear zero flag
ret
;;
setmatch:
mvi m,'?' ;set match one character
inx h
dcr b
jp setmatch
ret
;
; check for delimiter
;
; entry: A = character
; exit: z = set if char is a delimiter
;
delimiters: db cr,tab,' .,:;[]=<>|',0
delim: ldax d ;get character
push h
lxi h,delimiters
delim1: cmp m ;is char in table
jz delim2
inr m
dcr m ;end of table? (0)
inx h
jnz delim1
ora a ;reset zero flag
delim2: pop h
rz
;
; not a delimiter, convert to upper case
;
cpi 'a'
rc
cpi 'z'+1
jnc delim3
ani 05fh
delim3: ani 07fh
ret ;return with zero set if so
;
; pad with blanks or zeros
;
pad: mov m,b
inx h
dcr c
jnz pad
ret
;
; skip blanks and tabs
;
skps: ldax d
inx d
cpi ' ' ;skip spaces & tabs
jz skps
cpi tab
jz skps
ret
;
; end of PARSE
;
errflg:
; report error to console, message address in hl
push h! call crlf ; stack mssg address, new line
lda adrive! adi 'A'! sta dskerr ; current disk name
lxi b,dskmsg
if BANKED
call zprint ; the error message
else
call print
endif
pop b
if BANKED
lda bdos$flags! ral! jnc zprint
call zprint ; error message tail
lda fx! mvi b,30h
lxi h,pr$fx1
cpi 100! jc errflg1
mvi m,31h! inx h! sui 100
errflg1:
sui 10! jc errflg2
inr b! jmp errflg1
errflg2:
mov m,b! inx h! adi 3ah! mov m,a
inx h! mvi m,20h
lxi h,pr$fcb! mvi m,0
lda resel! ora a! jz errflg3
mvi m,20h! push d
lhld info! inx h! xchg! lxi h,pr$fcb1
mvi c,8! call move! mvi m,'.'! inx h
mvi c,3! call move! pop d
errflg3:
call crlf
lxi b,pr$fx! jmp zprint
zprint:
ldax b! ora a! rz
push b! mov c,a
call tabout
pop b! inx b! jmp zprint
pr$fx: db 'BDOS Function = '
pr$fx1: db ' '
pr$fcb: db ' File = '
pr$fcb1:ds 12
db 0
else
jmp print
endif
reboote:
lxi h,0fffdh! jmp rebootx0 ; BDOS error
rebootx:
lxi h,0fffeh ; CTL-C error
rebootx0:
shld clp$errcde
rebootx1:
jmp wbootf
entsp: ds 2 ; entry stack pointer
shell:
lxi h,0! dad sp! shld shell$sp
if not BANKED
lxi sp,shell$stk
endif
lxi h,shell$rtn! push h
call save$rr! call save$dma
lda mult$cnt
mult$io:
push a! sta mult$num! call cbdos
ora a! jnz shell$err
lda fx! cpi 33! cnc incr$rr
call adv$dma
pop a! dcr a! jnz mult$io
mov h,a! mov l,a! ret
shell$sp: dw 0
dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h
shell$stk: ; shell has 5 level stack
hold$dma: dw 0
cbdos:
lda fx! mov c,a
cbdos1:
lhld info! xchg! jmp bdose2
adv$dma:
lhld dmaad! lxi d,80h! dad d! jmp reset$dma1
save$dma:
lhld dmaad! shld hold$dma! ret
reset$dma:
lhld hold$dma
reset$dma1:
shld dmaad! jmp setdma
shell$err:
pop b! inr a! rz
lda mult$cnt! sub b! mov h,a! ret
shell$rtn:
push h! lda fx! cpi 33! cnc reset$rr
call reset$dma
pop d! lhld shell$sp! sphl! xchg
mov a,l! mov b,h! ret
page


1571
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPMLDR.ASM Normal file
View File

File diff suppressed because it is too large Load Diff

422
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CPMOVE.ASM Normal file
View File

@@ -0,0 +1,422 @@
TITLE 'CP/M VERSION 2.2 SYSTEM RELOCATOR - 2/80'
; CPM RELOCATOR PROGRAM, INCLUDED WITH THE MODULE TO PERFORM
; THE MOVE FROM 900H TO THE DESTINATION ADDRESS
;
; COPYRIGHT (C) 1979
; DIGITAL RESEARCH
; BOX 579, PACIFIC GROVE CALIFORNIA
; 93950
;
ORG 100H
JMP PASTCOPY
COPY: DB 'COPYRIGHT (C) DIGITAL RESEARCH, 1979 '
PASTCOPY:
BIOSWK EQU 03H ;THREE PAGES FOR BIOS WORKSPACE
STACK EQU 800H
MODSIZ EQU 801H ;MODULE SIZE IS STORED HERE
VERSION EQU 22 ;CPM VERSION NUMBER
BOOTSIZ EQU 100H ;SIZE OF THE COLD START LOADER
; (MAY HAVE FIRST 80H BYTES = 00H)
BDOSL EQU 0800H ;RELATIVE LOCATION OF BDOS
BIOS EQU 1600H ;RELATIVE LOCATION OF BIOS
;
BOOT EQU 0000H ;REBOOT LOCATION
BDOS EQU 0005H
PRNT EQU 9 ;PRINT BUFFER FUNCTION
FCB EQU 5CH ;DEFAULT FCB
MODULE EQU 900H ;MODULE ADDRESS
;
CR EQU 0DH
LF EQU 0AH
LXI SP,STACK
;
; MAY BE MEMORY SIZE SPECIFIED IN COMMAND
LXI D,FCB+1
LDAX D
CPI ' '
JZ FINDTOP
CPI '?' ;WAS * SPECIFIED?
JZ FINDTOP
;
; MUST BE MEMORY SIZE SPECIFICATION
LXI H,0
CLOOP: ;CONVERT TO DECIMAL
LDAX D
INX D
CPI ' '
JZ ECON
ORA A
JZ ECON
; MUST BE DECIMAL DIGIT
SUI '0'
CPI 10
JNC CERROR
; DECIMAL DIGIT IS IN A
DAD H ;*2
PUSH H
DAD H ;*4
DAD H ;*8
POP B ;*2 IN B,C
DAD B ;*10 IN H,L
MOV C,A
MVI B,0
DAD B ;*10+X
JMP CLOOP
ECON: ;END OF CONVERSION, CHECK FOR PROPER RANGE
MOV A,H
ORA A
JNZ CERROR
MOV A,L
CPI 16
JC CERROR
MVI L,0
MOV H,A
DAD H ;SHL 1
DAD H ;SHL 2 FOR KILOBYTES
; H,L HAVE TOP OF MEMORY+1
JMP SETASC
;
CERROR:
LXI D,CONMSG
CALL PRINT
JMP BOOT
CONMSG: DB CR,LF,'INVALID MEMORY SIZE$'
;
;
; FIND END OF MEMORY
FINDTOP:
LXI H,0
FINDM: INR H ;TO NEXT PAGE
JZ MSIZED ;CAN OVERFLOW ON 64K SYSTEMS
MOV A,M
CMA
MOV M,A
CMP M
CMA
MOV M,A ;BITS INVERTED FOR RAM OPERATIONAL TEST
JZ FINDM
; BITS DIDN'T CHANGE, MUST BE END OF MEMORY
; ALIGN ON EVEN BOUNDARY
MSIZED: MOV A,H
ANI 1111$1100B ;EVEN 1K BOUNDARY
MOV H,A
SETASC: ;SET ASCII VALUE OF MEMORY SIZE
PUSH H ;SAVE FOR LATER
; **** SERIALIZATION ****
LHLD BDOS+1
SHLD SER1
; **** SERIALIZATION ****
POP H
PUSH H
MOV A,H
RRC
RRC
ANI 11$1111B ;FOR 1K COUNTS
JNZ NOT64 ;MAY BE 64 K MEM SIZE
MVI A,64 ;SET TO LITERAL IF SO
NOT64: MOV B,A ;READY FOR COUNT DOWN
LXI H,AMEM
MVI A,'0'
MOV M,A
INX H
MOV M,A ;BOTH ARE SET TO ASCII 0
ASC0: LXI H,AMEM+1 ;ADDRESS OF ASCII EQUIVALENT
INR M
MOV A,M
CPI '9'+1
JC ASC1
MVI M,'0'
DCX H
INR M
ASC1: DCR B ;COUNT DOWN BY KILOBYTES
JNZ ASC0
LXI D,MEMSG
CALL PRINT ;MEMORY SIZE MESSAGE
;
LXI H,MODSIZ
MOV C,M
INX H
MOV B,M ;B,C CONTAINS MODULE SIZE
PUSH B ;MODULE SIZE STACKED ON MEM SIZE
;
; TRY TO FIND THE ASCII STRING 'K CP/M VER X.X' TO SET SIZE
LXI H,MODULE
; B,C CONTAINS MODULE LENGTH
SLOOP: ;SEARCH LOOP
LXI D,AMSG
MOV A,B
ORA C
JZ ESEAR ;END OF SEARCH
DCX B ;COUNT SEARCH LENGTH DOWN
PUSH B
MVI C,LAMSG ;LENGTH OF SEARCH MESSAGE
PUSH H ;SAVE BASE ADDRESS OF SEARCH
CHLOOP: ;CHARACTER LOOP, MATCH ON CONTENTS OF D,E AND H,L
LDAX D
CMP M
JNZ NOMATCH
INX D ;TO NEXT SEARCH CHARACTER
INX H ;TO NEXT MATCH CHARACTER
DCR C ;COUNT LENGTH DOWN
JZ FSEAR ;FOUND SEARCH STRING
JMP CHLOOP
;
; **** SERIALIZATION ****
DB LXI ;CONFUSE DISASSEMBLER
BADSER: ;BAD SERIAL NUMBER, LOOP TO CONFUSE ICE-80
XRA A
BADSER0:
DCR A
JNZ BADSER0
;
LXI H,DI OR (HLT SHL 8)
SHLD PRHLT
LXI H,PRJMP
MVI M,CALL ;CHANGE JMP BDOS TO CALL
LXI D,SYNCMSG-5
LXI H,5
DAD D ;TO CONFUSE SEARCHES ON ADDRESSES
XCHG
JMP PRINT
; **** SERIALIZATION ****
;
NOMATCH:
;NOT FOUND AT THIS ADDRESS, LOOK AT NEXT ADDRESS
POP H
INX H
POP B ;RECALL MODULE LENGTH
JMP SLOOP
;
FSEAR:
;FOUND STRING, SET MEMORY SIZE
POP H ;START ADDRESS OF STRING BEING MATCHED
POP B ;CLEAR B,C WHICH WAS STACKED
DCX H
LXI D,AMEM+1
LDAX D
MOV M,A
DCX H
DCX D
LDAX D
MOV M,A
; END OF FILL
;
ESEAR: ;END OF SEARCH
; **** SERIALIZATION ****
; CHECK FOR LEAST SIGNIFICANT BYTE OF 06 IN SER1
LXI B,SER1
LDAX B
CPI 6
MVI A,0
JNZ SETJMP ;BAD SERIALIZATION IF NOT 06
STAX B ;STORE 00 TO LEAST SIGNIFICANT BYTE
; **** SERIALIZATION ****
POP B ;RECOVER MODULE LENGTH
POP H ;H,L CONTAINS END OF MEMORY
PUSH B ;SAVE LENGTH FOR RELOCATION BELOW
MOV A,B
ADI BIOSWK ;ADD BIOS WORK SPACE TO MODULE LENGTH
MOV B,A
MOV A,L
SUB C ;COMPUTE MEMTOP-MODULE SIZE
MOV L,A
MOV A,H
SBB B
MOV H,A
; H,L CONTAINS THE BASE OF THE RELOCATION AREA
SHLD RELBAS ;SAVE THE RELOCATION BASE
XCHG ;MODULE BASE TO D,E
LXI H,MODULE;READY FOR THE MOVE
POP B ;RECOVER ACTUAL MODULE LENGTH
PUSH B ;SAVE FOR RELOCATION
LDA FCB+17 ;CHECK FOR NO MOVE CONDITION
CPI ' '
JZ MOVE
; SECOND PARAMETER SPECIFIED, LEAVE THE DATA AT 'MODULE'
DAD B ;MOVE H,L TO BIT MAP POSITION
JMP RELOC
;
; **** SERIALIZATION ****
SETJMP: LXI H,BADSER ;BAD SERIALIZATION
SHLD JMPSER+1 ;FILL JUMP INSTRUCTION
JMP JMPSER ;EVENTUAL JUMP TO MESSAGE
; **** SERIALIZATION ****
;
MOVE:
MOV A,B ;BC=0?
ORA C
JZ RELOC
DCX B ;COUNT MODULE SIZE DOWN TO ZERO
MOV A,M ;GET NEXT ABSOLUTE LOCATION
STAX D ;PLACE IT INTO THE RELOC AREA
INX D
INX H
JMP MOVE
;
RELOC: ;STORAGE MOVED, READY FOR RELOCATION
; HL ADDRESSES BEGINNING OF THE BIT MAP FOR RELOCATION
POP B ;RECALL MODULE LENGTH
PUSH H ;SAVE BIT MAP BASE IN STACK
LHLD RELBAS
XCHG
LXI H,BOOTSIZ
DAD D ;TO FIND BIAS VALUE
; REGISTER H CONTAINS BIAS VALUE
;
; RELOCATE AT 'MODULE' IF SECOND PARAMETER GIVEN
LDA FCB+17
CPI ' '
JZ REL0
;
; IMAGE NOT MOVED, ADJUST VALUES AT 'MODULE'
LXI D,MODULE
REL0: MOV A,B ;BC=0?
ORA C
JZ ENDREL
; **** SERIALIZATION ****
JMP PASTSYNC
SYNCMSG:
DB CR,LF,'SYNCRONIZATION ERROR$'
PASTSYNC:
; **** SERIALIZATION ****
;
; NOT END OF THE RELOCATION, MAY BE INTO NEXT BYTE OF BIT MAP
DCX B ;COUNT LENGTH DOWN
MOV A,E
ANI 111B ;0 CAUSES FETCH OF NEXT BYTE
JNZ REL1
; FETCH BIT MAP FROM STACKED ADDRESS
XTHL
MOV A,M ;NEXT 8 BITS OF MAP
INX H
XTHL ;BASE ADDRESS GOES BACK TO STACK
MOV L,A ;L HOLDS THE MAP AS WE PROCESS 8 LOCATIONS
REL1: MOV A,L
RAL ;CY SET TO 1 IF RELOCATION NECESSARY
MOV L,A ;BACK TO L FOR NEXT TIME AROUND
JNC REL2 ;SKIP RELOCATION IF CY=0
;
; CURRENT ADDRESS REQUIRES RELOCATION
LDAX D
ADD H ;APPLY BIAS IN H
STAX D
JMP REL2
;
REL2: INX D ;TO NEXT ADDRESS
JMP REL0 ;FOR ANOTHER BYTE TO RELOCATE
;
ENDREL: ;END OF RELOCATION
POP D ;CLEAR STACKED ADDRESS
; **** SERIALIZATION ****
LXI D,MODULE+BDOSL+BOOTSIZ ;ADDRESSING NEW SERIAL NUMBER
LHLD SER1 ;ADDRESSING HOST SERIAL NUMBER
MVI C,6 ;LENGTH OF SERIAL NUMBER
CHKSER: LDAX D
CMP M
JNZ SETJMP
INX H
INX D
DCR C
JNZ CHKSER
; **** SERIALIZATION ****
;
LDA FCB+17
CPI ' '
JZ TRANSFER
; DON'T GO TO THE LOADED PROGRAM, LEAVE IN MEMORY
; MAY HAVE TO MOVE THE PROGRAM IMAGE DOWN 1/2 PAGE
MVI B,128 ;CHECK FOR 128 ZEROES
LXI H,MODULE
TR0: MOV A,M
ORA A
JNZ TREND
INX H
DCR B
JNZ TR0
;
; ALL ZERO FIRST 1/2 PAGE, MOVE DOWN 80H BYTES
XCHG ;NEXT TO GET IN D,E
LHLD MODSIZ
LXI B,-128
DAD B ;NUMBER OF BYTES TO MOVE IN H,L
MOV B,H
MOV C,L ;TRANSFERRED TO B,C
LXI H,MODULE;DESTINATION IN H,L
TRMOV: MOV A,B
ORA C ;ALL MOVED?
JZ TREND
DCX B
LDAX D
MOV M,A ;ONE BYTE TRANSFERRED
INX D
INX H
JMP TRMOV
;
;
; **** SERIALIZATION ****
DB LXI
JMPSER: JMP JMPSER ;ADDRESS FIELD FILLED-IN
; **** SERIALIZATION ****
;
TREND: ;SET ASCII MEMORY IMAGE SIZE
LXI H,MODSIZ
MOV C,M
INX H
MOV B,M
LXI H,MODULE;B,C MODULE SIZE, H,L BASE
DAD B
MOV B,H ;B CONTAINS NUMBER OF PAGES TO SAVE+1
LXI H,SAVMEM;ASCII MEMORY SIZE
MVI A,'0'
MOV M,A
INX H
MOV M,A
; '00' STORED INTO MESSAGE
TRCOMP:
DCR B
JZ TRC1
LXI H,SAVMEM+1 ;ADDRESSING LEAST DIGIT
INR M
MOV A,M
CPI '9'+1
JC TRCOMP
MVI M,'0'
DCX H
INR M
JMP TRCOMP
; FILL CPMXX.COM FROM SAVMEM
TRC1: LHLD AMEM
SHLD SAVM0
; MESSAGE SET, PRINT IT AND REBOOT
LXI D,RELOK
CALL PRINT
JMP BOOT
RELOK: DB CR,LF,'READY FOR "SYSGEN" OR'
DB CR,LF,'"SAVE '
SAVMEM: DB '00 CPM'
SAVM0: DB '00.COM"$'
;
TRANSFER:
; GO TO THE RELOCATED MEMORY IMAGE
LXI D,BOOTSIZ+BIOS ;MODULE
LHLD RELBAS ;RECALL BASE OF RELOC AREA
DAD D ;INDEX TO 'BOOT' ENTRY POINT
PCHL ;GO TO RELOCATED PROGRAM
;
; **** SERIALIZATION ****
PRINT:
MVI C,PRNT
PRJMP: JMP BDOS
PRHLT:
;
; DATA AREAS
SER1: DS 2 ;SERIAL NUMBER ADDRESS FOR HOST
RELBAS: DS 2 ;RELOCATION BASE
MEMSG: DB CR,LF,'CONSTRUCTING '
AMEM: DB '00'
AMSG: DB 'k CP/M vers '
DB VERSION/10+'0','.',VERSION MOD 10 +'0'
LAMSG EQU $-AMSG ;LENGTH OF MESSAGE
DB '$' ;TERMINATOR FOR MESSAGE
END


202
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/CRDEF.PLM Normal file
View File

@@ -0,0 +1,202 @@
$title('GENCPM Token File Creator')
create$defaults:
do;
/*
Copyright (C) 1982
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
*/
/*
Revised:
20 Sept 82 by Bruce Skidmore
*/
declare true literally '0FFH';
declare false literally '0';
declare forever literally 'while true';
declare boolean literally 'byte';
declare cr literally '0dh';
declare lf literally '0ah';
declare tab literally '09h';
/*
D a t a S t r u c t u r e s
*/
declare data$fcb (36) byte external;
declare obuf (128) byte at (.memory);
declare hexASCII (16) byte external;
declare symtbl (20) structure(
token(8) byte,
len byte,
flags byte,
qptr byte,
ptr address) external;
/*
B D O S P r o c e d u r e & F u n c t i o n C a l l s
*/
delete$file:
procedure (fcb$address) external;
declare fcb$address address;
end delete$file;
create$file:
procedure (fcb$address) external;
declare fcb$address address;
end create$file;
close$file:
procedure (fcb$address) external;
declare fcb$address address;
end close$file;
write$record:
procedure (fcb$address) external;
declare fcb$address address;
end write$record;
set$DMA$address:
procedure (DMA$address) external;
declare DMA$address address;
end set$DMA$address;
/*
M a i n C R T D E F P r o c e d u r e
*/
crtdef:
procedure public;
declare (flags,symbol$done,i,j,obuf$index,inc) byte;
declare val$adr address;
declare val based val$adr byte;
inc$obuf$index:
procedure;
if obuf$index = 7fh then
do;
call write$record(.data$fcb);
do obuf$index = 0 to 7fh;
obuf(obuf$index) = 1ah;
end;
obuf$index = 0;
end;
else
obuf$index = obuf$index + 1;
end inc$obuf$index;
emit$ascii$hex:
procedure(dig);
declare dig byte;
call inc$obuf$index;
obuf(obuf$index) = hexASCII(shr(dig,4));
call inc$obuf$index;
obuf(obuf$index) = hexASCII(dig and 0fh);
end emit$ascii$hex;
call set$dma$address(.obuf);
call delete$file(.data$fcb);
call create$file(.data$fcb);
obuf$index = 0ffh;
do i = 0 to 21;
symbol$done = false;
flags = symtbl(i).flags;
inc = 0;
do while (inc < 16) and (not symbol$done);
do j = 0 to 7;
call inc$obuf$index;
obuf(obuf$index) = symtbl(i).token(j);
end;
if (flags and 8) = 0 then
symbol$done = true;
else
do;
if (flags and 10h) <> 0 then
obuf(obuf$index) = 'A' + inc;
else
do;
if inc < 10 then
do;
obuf(obuf$index) = '0' + inc;
end;
else
do;
obuf(obuf$index) = 'A' + inc - 10;
end;
end;
end;
call inc$obuf$index;
obuf(obuf$index) = ' ';
call inc$obuf$index;
obuf(obuf$index) = '=';
call inc$obuf$index;
obuf(obuf$index) = ' ';
val$adr = symtbl(i).ptr + (inc * symtbl(i).len);
if (flags and 1) <> 0 then
do;
call inc$obuf$index;
obuf(obuf$index) = 'A' + val;
end;
else
do;
if (flags and 2) <> 0 then
do;
call inc$obuf$index;
if val then
obuf(obuf$index) = 'Y';
else
obuf(obuf$index) = 'N';
end;
else
do;
call emit$ascii$hex(val);
if (flags and 18h) = 8 then
do;
call inc$obuf$index;
obuf(obuf$index) = ',';
val$adr = val$adr + 1;
call emit$ascii$hex(val);
call inc$obuf$index;
obuf(obuf$index) = ',';
val$adr = val$adr + 1;
call emit$ascii$hex(val);
end;
end;
end;
call inc$obuf$index;
obuf(obuf$index) = cr;
call inc$obuf$index;
obuf(obuf$index) = lf;
inc = inc + 1;
end;
end;
if obuf$index <= 7fh then
call write$record(.data$fcb);
call close$file(.data$fcb);
end crtdef;
end create$defaults;


7
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/DATE.ASM Normal file
View File

@@ -0,0 +1,7 @@
org 368h
db ' 151282 '
db ' COPYR ''82 DRI '


581
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/DATE.PLM Normal file
View File

@@ -0,0 +1,581 @@
$title ('CP/M V3.0 Date and Time')
tod:
do;
/*
Revised:
14 Sept 81 by Thomas Rolander
Modifications:
Date: September 2,1982
Programmer: Thomas J. Mason
Changes:
The 'P' option was changed to the 'C'ontinuous option.
Also added is the 'S'et option to let the user set either
the time or the date.
Date: October 31,1982
Programmer: Bruce K. Skidmore
Changes:
Added Function 50 call to signal Time Set and Time Get.
*/
declare PLM label public;
mon1:
procedure (func,info) external;
declare func byte;
declare info address;
end mon1;
mon2:
procedure (func,info) byte external;
declare func byte;
declare info address;
end mon2;
mon2a:
procedure (func,info) address external;
declare func byte;
declare info address;
end mon2a;
declare xdos literally 'mon2a';
declare fcb (1) byte external;
declare fcb16 (1) byte external;
declare tbuff (1) byte external;
RETURN$VERSION$FUNC:
procedure address;
return MON2A(12,0);
end RETURN$VERSION$FUNC;
read$console:
procedure byte;
return mon2 (1,0);
end read$console;
write$console:
procedure (char);
declare char byte;
call mon1 (2,char);
end write$console;
print$buffer:
procedure (buffer$address);
declare buffer$address address;
call mon1 (9,buffer$address);
end print$buffer;
READ$CONSOLE$BUFFER:
procedure (BUFF$ADR);
declare BUFF$ADR address;
call MON1(10,BUFF$ADR);
end READ$CONSOLE$BUFFER;
check$console$status:
procedure byte;
return mon2 (11,0);
end check$console$status;
terminate:
procedure;
call mon1 (0,0);
end terminate;
crlf:
procedure;
call write$console (0dh);
call write$console (0ah);
end crlf;
/*****************************************************
Time & Date ASCII Conversion Code
*****************************************************/
declare BUFFER$ADR structure (
MAX$CHARS byte,
NUMB$OF$CHARS byte,
CONSOLE$BUFFER(21) byte)
initial(21,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0);
declare tod$adr address;
declare tod based tod$adr structure (
opcode byte,
date address,
hrs byte,
min byte,
sec byte,
ASCII (21) byte );
declare string$adr address;
declare string based string$adr (1) byte;
declare index byte;
declare lit literally 'literally',
forever lit 'while 1',
word lit 'address';
/* - - - - - - - - - - - - - - - - - - - - - - */
emitchar:
procedure(c);
declare c byte;
string(index := index + 1) = c;
end emitchar;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
emitn:
procedure(a);
declare a address;
declare c based a byte;
do while c <> '$';
string(index := index + 1) = c;
a = a + 1;
end;
end emitn;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
emit$bcd:
procedure(b);
declare b byte;
call emitchar('0'+b);
end emit$bcd;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
emit$bcd$pair:
procedure(b);
declare b byte;
call emit$bcd(shr(b,4));
call emit$bcd(b and 0fh);
end emit$bcd$pair;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
emit$colon:
procedure(b);
declare b byte;
call emit$bcd$pair(b);
call emitchar(':');
end emit$colon;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
emit$bin$pair:
procedure(b);
declare b byte;
call emit$bcd(b/10);
call emit$bcd(b mod 10);
end emit$bin$pair;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
emit$slant:
procedure(b);
declare b byte;
call emit$bin$pair(b);
call emitchar('/');
end emit$slant;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
declare chr byte;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
gnc:
procedure;
/* get next command byte */
if chr = 0 then return;
if index = 20 then
do;
chr = 0;
return;
end;
chr = string(index := index + 1);
end gnc;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
deblank:
procedure;
do while chr = ' ';
call gnc;
end;
end deblank;
numeric:
procedure byte;
/* test for numeric */
return (chr - '0') < 10;
end numeric;
scan$numeric:
procedure(lb,ub) byte;
declare (lb,ub) byte;
declare b byte;
b = 0;
call deblank;
if not numeric then go to error;
do while numeric;
if (b and 1110$0000b) <> 0 then go to error;
b = shl(b,3) + shl(b,1); /* b = b * 10 */
if carry then go to error;
b = b + (chr - '0');
if carry then go to error;
call gnc;
end;
if (b < lb) or (b > ub) then go to error;
return b;
end scan$numeric;
scan$delimiter:
procedure(d,lb,ub) byte;
declare (d,lb,ub) byte;
call deblank;
if chr <> d then go to error;
call gnc;
return scan$numeric(lb,ub);
end scan$delimiter;
declare base$year lit '78', /* base year for computations */
base$day lit '0', /* starting day for base$year 0..6 */
month$size (*) byte data
/* jan feb mar apr may jun jul aug sep oct nov dec */
( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),
month$days (*) word data
/* jan feb mar apr may jun jul aug sep oct nov dec */
( 000,031,059,090,120,151,181,212,243,273,304,334);
leap$days:
procedure(y,m) byte;
declare (y,m) byte;
/* compute days accumulated by leap years */
declare yp byte;
yp = shr(y,2); /* yp = y/4 */
if (y and 11b) = 0 and month$days(m) < 59 then
/* y not 00, y mod 4 = 0, before march, so not leap yr */
return yp - 1;
/* otherwise, yp is the number of accumulated leap days */
return yp;
end leap$days;
declare word$value word;
get$next$digit:
procedure byte;
/* get next lsd from word$value */
declare lsd byte;
lsd = word$value mod 10;
word$value = word$value / 10;
return lsd;
end get$next$digit;
bcd:
procedure (val) byte;
declare val byte;
return shl((val/10),4) + val mod 10;
end bcd;
declare (month, day, year, hrs, min, sec) byte;
set$date:
procedure;
declare (i, leap$flag) byte; /* temporaries */
month = scan$numeric(1,12) - 1;
/* may be feb 29 */
if (leap$flag := month = 1) then i = 29;
else i = month$size(month);
day = scan$delimiter('/',1,i);
year = scan$delimiter('/',base$year,99);
/* ensure that feb 29 is in a leap year */
if leap$flag and day = 29 and (year and 11b) <> 0 then
/* feb 29 of non-leap year */ go to error;
/* compute total days */
tod.date = month$days(month)
+ 365 * (year - base$year)
+ day
- leap$days(base$year,0)
+ leap$days(year,month);
end SET$DATE;
SET$TIME:
procedure;
tod.hrs = bcd (scan$numeric(0,23));
tod.min = bcd (scan$delimiter(':',0,59));
if tod.opcode = 2
then
/* date, hours and minutes only */
do;
if chr = ':'
then i = scan$delimiter (':',0,59);
tod.sec = 0;
end;
/* include seconds */
else tod.sec = bcd (scan$delimiter(':',0,59));
end set$time;
bcd$pair:
procedure(a,b) byte;
declare (a,b) byte;
return shl(a,4) or b;
end bcd$pair;
compute$year:
procedure;
/* compute year from number of days in word$value */
declare year$length word;
year = base$year;
do forever;
year$length = 365;
if (year and 11b) = 0 then /* leap year */
year$length = 366;
if word$value <= year$length then
return;
word$value = word$value - year$length;
year = year + 1;
end;
end compute$year;
declare week$day byte, /* day of week 0 ... 6 */
day$list (*) byte data ('Sun$Mon$Tue$Wed$Thu$Fri$Sat$'),
leap$bias byte; /* bias for feb 29 */
compute$month:
procedure;
month = 12;
do while month > 0;
if (month := month - 1) < 2 then /* jan or feb */
leapbias = 0;
if month$days(month) + leap$bias < word$value then return;
end;
end compute$month;
declare date$test byte, /* true if testing date */
test$value word; /* sequential date value under test */
get$date$time:
procedure;
/* get date and time */
hrs = tod.hrs;
min = tod.min;
sec = tod.sec;
word$value = tod.date;
/* word$value contains total number of days */
week$day = (word$value + base$day - 1) mod 7;
call compute$year;
/* year has been set, word$value is remainder */
leap$bias = 0;
if (year and 11b) = 0 and word$value > 59 then
/* after feb 29 on leap year */ leap$bias = 1;
call compute$month;
day = word$value - (month$days(month) + leap$bias);
month = month + 1;
end get$date$time;
emit$date$time:
procedure;
call emitn(.day$list(shl(week$day,2)));
call emitchar(' ');
call emit$slant(month);
call emit$slant(day);
call emit$bin$pair(year);
call emitchar(' ');
call emit$colon(hrs);
call emit$colon(min);
call emit$bcd$pair(sec);
end emit$date$time;
tod$ASCII:
procedure (parameter);
declare parameter address;
declare ret address;
ret = 0;
tod$adr = parameter;
string$adr = .tod.ASCII;
if tod.opcode = 0 then
do;
call get$date$time;
index = -1;
call emit$date$time;
end;
else
do;
if (tod.opcode = 1) or
(tod.opcode = 2) then
do;
chr = string(index:=0);
call set$date;
call set$time;
ret = .string(index);
end;
else
do;
go to error;
end;
end;
end tod$ASCII;
/********************************************************
********************************************************/
declare lcltod structure (
opcode byte,
date address,
hrs byte,
min byte,
sec byte,
ASCII (21) byte );
declare datapgadr address;
declare datapg based datapgadr address;
declare extrnl$todadr address;
declare extrnl$tod based extrnl$todadr structure (
date address,
hrs byte,
min byte,
sec byte );
declare i byte;
declare ret address;
display$tod:
procedure;
lcltod.opcode = 0; /* read tod */
call mon1(50,.(26,0,0,0,0,0,0,0)); /* BIOS TIME GET SIGNAL */
call move (5,.extrnl$tod.date,.lcltod.date);
call tod$ASCII (.lcltod);
call write$console (0dh);
do i = 0 to 20;
call write$console (lcltod.ASCII(i));
end;
end display$tod;
comp:
procedure (cnt,parmadr1,parmadr2) byte;
declare (i,cnt) byte;
declare (parmadr1,parmadr2) address;
declare parm1 based parmadr1 (5) byte;
declare parm2 based parmadr2 (5) byte;
do i = 0 to cnt-1;
if parm1(i) <> parm2(i)
then return 0;
end;
return 0ffh;
end comp;
/**************************************
Main Program
**************************************/
declare last$dseg$byte byte initial (0);
declare CURRENT$VERSION address initial (0);
declare CPM30 byte initial (030h);
declare MPM byte initial (01h);
PLM:
do;
CURRENT$VERSION = RETURN$VERSION$FUNC;
if (low(CURRENT$VERSION) >= CPM30) and (high(CURRENT$VERSION) <> MPM) then
do;
datapgadr = xdos (49,.(03ah,0));
extrnl$todadr = xdos(49,.(03ah,0)) + 58H;
if (FCB(1) = 'C') then
do while FCB(1) = 'C';
if comp(5,.extrnl$tod.date,.lcltod.date) = 0 then
call display$tod;
if check$console$status then
do;
ret = read$console;
fcb(1) = 0;
end;
end;
else
if (FCB(1) = ' ') then
do;
call display$tod;
end;
else
if (FCB(1) = 'S')
then do;
call crlf;
call print$buffer(.('Enter today''s date (MM/DD/YY): ','$'));
call move(21,.(000000000000000000000),.buffer$adr.console$buffer);
call read$console$buffer(.buffer$adr);
if buffer$adr.numb$of$chars > 0
then do;
call move(21,.buffer$adr.console$buffer,.lcltod.ASCII);
tod$adr = .lcltod;
string$adr = .tod.ASCII;
chr = string(index := 0);
call set$date;
call move(2,.lcltod.date,.extrnl$tod.date);
end; /* date initialization */
call crlf;
call print$buffer(.('Enter the time (HH:MM:SS): ','$'));
call move(21,.(000000000000000000000),.buffer$adr.console$buffer);
call read$console$buffer(.buffer$adr);
if buffer$adr.numb$of$chars > 0
then do;
call move(21,.buffer$adr.console$buffer,.lcltod.ASCII);
tod$adr = .lcltod;
string$adr = .tod.ASCII;
chr = string(index := 0);
call set$time;
call crlf;
call print$buffer(.('Press any key to set time ','$'));
ret = read$console;
call move(3,.lcltod.hrs,.extrnl$tod.hrs);
call mon1(50,.(26,0,0ffh,0,0,0,0,0,)); /* BIOS TIME SET SIGNAL */
end;
call crlf;
end;
else do;
call move (21,.tbuff(1),.lcltod.ASCII);
lcltod.opcode = 1;
call tod$ASCII (.lcltod);
call crlf;
call print$buffer (.('Strike key to set time','$'));
ret = read$console;
call move (5,.lcltod.date,.extrnl$tod.date);
call mon1(50,.(26,0,0ffh,0,0,0,0,0,)); /* BIOS TIME SET SIGNAL */
call crlf;
end;
call terminate;
end;
else
do;
call CRLF;
call PRINT$BUFFER(.('ERROR: Requires CP/M3.','$'));
call CRLF;
call TERMINATE;
end;
end;
error:
do;
call crlf;
call print$buffer (.('ERROR: Illegal time/date specification.','$'));
call terminate;
end;
end tod;

169
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/DATMOD.ASM Normal file
View File

@@ -0,0 +1,169 @@
$title ('GENCPM Data module')
name datmod
; Copyright (C) 1982
; Digital Research
; P.O. Box 579
; Pacific Grove, CA 93950
;
; Revised:
; 15 Nov 82 by Bruce Skidmore
;
cseg
public symtbl
;declare symtbl(16) structure(
; token(8) byte, /* question variable name */
; len byte, /* length of structure in array of structures */
; flags byte, /* type of variable */
; qptr byte, /* index into query array */
; ptr address); /* pointer to the associated data structure */
; flags definition:
; bit(3) = 1 then array of structures
; bit(4) = 1 then index is A-P else index is 0-F
; bit(2) = 1 then numeric variable
; bit(1) = 1 boolean variable legal values are Y or N
; bit(0) = 1 drive variable legal values are A-P
symtbl:
db 'PRTMSG ',1, 00000010B,0
dw prtmsg
db 'PAGWID ',1, 00000100B,1
dw conwid
db 'PAGLEN ',1, 00000100B,2
dw conpag
db 'BACKSPC ',1, 00000010B,3
dw bckspc
db 'RUBOUT ',1, 00000010B,4
dw rubout
db 'BOOTDRV ',1, 00000001B,5
dw bdrive
db 'MEMTOP ',1, 00000100B,6
dw memtop
db 'BNKSWT ',1, 00000010B,7
dw bnkswt
db 'COMBAS ',1, 00000100B,8
dw bnktop
db 'LERROR ',1, 00000010B,9
dw lerror
db 'NUMSEGS ',1, 00000100B,10
dw numseg
db 'MEMSEG00',5, 00001100B,11
dw memtbl+5
db 'HASHDRVA',1, 00011010B,27
dw hash
db 'ALTBNKSA',10,00011010B,43
dw record+3
db 'NDIRRECA',10,00011100B,59
dw record+4
db 'NDTARECA',10,00011100B,75
dw record+5
db 'ODIRDRVA',10,00011001B,91
dw record+6
db 'ODTADRVA',10,00011001B,107
dw record+7
db 'OVLYDIRA',10,00011010B,123
dw record+8
db 'OVLYDTAA',10,00011010B,139
dw record+9
db 'CRDATAF ',1,00000010B,155
dw crdatf
db 'DBLALV ',1,00000010B,156
dw dblalv
public lerror,prtmsg,bnkswt,memtop,bnktop
public bdrive,conpag,conwid,bckspc
public rubout,numseg,hash,memtbl,record
public crdatf,dblalv
lerror:
db 0ffh
prtmsg:
db 0ffh
bnkswt:
db 0ffh
memtop:
db 0ffh
bnktop:
db 0c0h
bdrive:
db 00h
conpag:
db 23
conwid:
db 79
bckspc:
db 0
rubout:
db 0ffh
numseg:
db 3
hash:
db 0ffh,0ffh,0ffh,0ffh
db 0ffh,0ffh,0ffh,0ffh
db 0ffh,0ffh,0ffh,0ffh
db 0ffh,0ffh,0ffh,0ffh
memtbl:
db 0,0,0,0,0
db 0,080h,00h,0,0
db 0,0c0h,02h,0,0
db 0,0c0h,03h,0,0
db 0,0c0h,04h,0,0
db 0,0c0h,05h,0,0
db 0,0c0h,06h,0,0
db 0,0c0h,07h,0,0
db 0,0c0h,08h,0,0
db 0,0c0h,09h,0,0
db 0,0c0h,0ah,0,0
db 0,0c0h,0bh,0,0
db 0,0c0h,0ch,0,0
db 0,0c0h,0dh,0,0
db 0,0c0h,0eh,0,0
db 0,0c0h,0fh,0,0
db 0,0c0h,10h,0,0
record:
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
dw 0
db 0,0,1,1,0,0,0ffh,0ffh
crdatf:
db 0
dblalv:
db 0ffh
public quest
quest:
ds 157
end


89
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/DDT0MOV.ASM Normal file
View File

@@ -0,0 +1,89 @@
; DDT RELOCATOR PROGRAM, INCLUDED WITH THE MODULE TO PERFORM
; THE MOVE FROM 200H TO THE DESTINATION ADDRESS
VERSION EQU 22 ;2.2
;
; COPYRIGHT (C) 1976, 1977, 1978, 1979, 1980
; DIGITAL RESEARCH
; BOX 579 PACIFIC GROVE
; CALIFORNIA 93950
;
ORG 100H
STACK EQU 200H
BDOS EQU 0005H
PRNT EQU 9 ;BDOS PRINT FUNCTION
MODULE EQU 200H ;MODULE ADDRESS
;
db 01h ;lxi instruction
ds 2 ;space for address
; LXI B,0 ;ADDRESS FIELD FILLED-IN WHEN MODULE BUILT
JMP START
DB 'COPYRIGHT (C) 1980, DIGITAL RESEARCH '
SIGNON: DB 'DDT VERS '
DB VERSION/10+'0','.'
DB VERSION MOD 10 + '0','$'
START: LXI SP,STACK
PUSH B
PUSH B
LXI D,SIGNON
MVI C,PRNT
CALL BDOS
POP B ;RECOVER LENGTH OF MOVE
LXI H,BDOS+2;ADDRESS FIELD OF JUMP TO BDOS (TOP MEMORY)
MOV A,M ;A HAS HIGH ORDER ADDRESS OF MEMORY TOP
DCR A ;PAGE DIRECTLY BELOW BDOS
SUB B ;A HAS HIGH ORDER ADDRESS OF RELOC AREA
MOV D,A
MVI E,0 ;D,E ADDRESSES BASE OF RELOC AREA
PUSH D ;SAVE FOR RELOCATION BELOW
;
LXI H,MODULE;READY FOR THE MOVE
MOVE: MOV A,B ;BC=0?
ORA C
JZ RELOC
DCX B ;COUNT MODULE SIZE DOWN TO ZERO
MOV A,M ;GET NEXT ABSOLUTE LOCATION
STAX D ;PLACE IT INTO THE RELOC AREA
INX D
INX H
JMP MOVE
;
RELOC: ;STORAGE MOVED, READY FOR RELOCATION
; HL ADDRESSES BEGINNING OF THE BIT MAP FOR RELOCATION
POP D ;RECALL BASE OF RELOCATION AREA
POP B ;RECALL MODULE LENGTH
PUSH H ;SAVE BIT MAP BASE IN STACK
MOV H,D ;RELOCATION BIAS IS IN D
;
REL0: MOV A,B ;BC=0?
ORA C
JZ ENDREL
;
; NOT END OF THE RELOCATION, MAY BE INTO NEXT BYTE OF BIT MAP
DCX B ;COUNT LENGTH DOWN
MOV A,E
ANI 111B ;0 CAUSES FETCH OF NEXT BYTE
JNZ REL1
; FETCH BIT MAP FROM STACKED ADDRESS
XTHL
MOV A,M ;NEXT 8 BITS OF MAP
INX H
XTHL ;BASE ADDRESS GOES BACK TO STACK
MOV L,A ;L HOLDS THE MAP AS WE PROCESS 8 LOCATIONS
REL1: MOV A,L
RAL ;CY SET TO 1 IF RELOCATION NECESSARY
MOV L,A ;BACK TO L FOR NEXT TIME AROUND
JNC REL2 ;SKIP RELOCATION IF CY=0
;
; CURRENT ADDRESS REQUIRES RELOCATION
LDAX D
ADD H ;APPLY BIAS IN H
STAX D
REL2: INX D ;TO NEXT ADDRESS
JMP REL0 ;FOR ANOTHER BYTE TO RELOCATE
;
ENDREL: ;END OF RELOCATION
POP D ;CLEAR STACKED ADDRESS
MVI L,0
PCHL ;GO TO RELOCATED PROGRAM
END


1070
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/DDT1ASM.ASM Normal file
View File

File diff suppressed because it is too large Load Diff

1646
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/DDT2MON.ASM Normal file
View File

File diff suppressed because it is too large Load Diff

389
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/DEBLOCK.ASM Normal file
View File

@@ -0,0 +1,389 @@
;*****************************************************
;* *
;* Sector Deblocking Algorithms for CP/M 2.0 *
;* *
;*****************************************************
;
; utility macro to compute sector mask
smask macro hblk
;; compute log2(hblk), return @x as result
;; (2 ** @x = hblk on return)
@y set hblk
@x set 0
;; count right shifts of @y until = 1
rept 8
if @y = 1
exitm
endif
;; @y is not 1, shift right one position
@y set @y shr 1
@x set @x + 1
endm
endm
;
;*****************************************************
;* *
;* CP/M to host disk constants *
;* *
;*****************************************************
blksiz equ 2048 ;CP/M allocation size
hstsiz equ 512 ;host disk sector size
hstspt equ 20 ;host disk sectors/trk
hstblk equ hstsiz/128 ;CP/M sects/host buff
cpmspt equ hstblk * hstspt ;CP/M sectors/track
secmsk equ hstblk-1 ;sector mask
smask hstblk ;compute sector mask
secshf equ @x ;log2(hstblk)
;
;*****************************************************
;* *
;* BDOS constants on entry to write *
;* *
;*****************************************************
wrall equ 0 ;write to allocated
wrdir equ 1 ;write to directory
wrual equ 2 ;write to unallocated
;
;*****************************************************
;* *
;* The BDOS entry points given below show the *
;* code which is relevant to deblocking only. *
;* *
;*****************************************************
;
; DISKDEF macro, or hand coded tables go here
dpbase equ $ ;disk param block base
;
boot:
wboot:
;enter here on system boot to initialize
xra a ;0 to accumulator
sta hstact ;host buffer inactive
sta unacnt ;clear unalloc count
ret
;
home:
;home the selected disk
home:
lda hstwrt ;check for pending write
ora a
jnz homed
sta hstact ;clear host active flag
homed:
ret
;
seldsk:
;select disk
mov a,c ;selected disk number
sta sekdsk ;seek disk number
mov l,a ;disk number to HL
mvi h,0
rept 4 ;multiply by 16
dad h
endm
lxi d,dpbase ;base of parm block
dad d ;hl=.dpb(curdsk)
ret
;
settrk:
;set track given by registers BC
mov h,b
mov l,c
shld sektrk ;track to seek
ret
;
setsec:
;set sector given by register c
mov a,c
sta seksec ;sector to seek
ret
;
setdma:
;set dma address given by BC
mov h,b
mov l,c
shld dmaadr
ret
;
sectran:
;translate sector number BC
mov h,b
mov l,c
ret
;
;*****************************************************
;* *
;* The READ entry point takes the place of *
;* the previous BIOS defintion for READ. *
;* *
;*****************************************************
read:
;read the selected CP/M sector
xra a
sta unacnt
mvi a,1
sta readop ;read operation
sta rsflag ;must read data
mvi a,wrual
sta wrtype ;treat as unalloc
jmp rwoper ;to perform the read
;
;*****************************************************
;* *
;* The WRITE entry point takes the place of *
;* the previous BIOS defintion for WRITE. *
;* *
;*****************************************************
write:
;write the selected CP/M sector
xra a ;0 to accumulator
sta readop ;not a read operation
mov a,c ;write type in c
sta wrtype
cpi wrual ;write unallocated?
jnz chkuna ;check for unalloc
;
; write to unallocated, set parameters
mvi a,blksiz/128 ;next unalloc recs
sta unacnt
lda sekdsk ;disk to seek
sta unadsk ;unadsk = sekdsk
lhld sektrk
shld unatrk ;unatrk = sectrk
lda seksec
sta unasec ;unasec = seksec
;
chkuna:
;check for write to unallocated sector
lda unacnt ;any unalloc remain?
ora a
jz alloc ;skip if not
;
; more unallocated records remain
dcr a ;unacnt = unacnt-1
sta unacnt
lda sekdsk ;same disk?
lxi h,unadsk
cmp m ;sekdsk = unadsk?
jnz alloc ;skip if not
;
; disks are the same
lxi h,unatrk
call sektrkcmp ;sektrk = unatrk?
jnz alloc ;skip if not
;
; tracks are the same
lda seksec ;same sector?
lxi h,unasec
cmp m ;seksec = unasec?
jnz alloc ;skip if not
;
; match, move to next sector for future ref
inr m ;unasec = unasec+1
mov a,m ;end of track?
cpi cpmspt ;count CP/M sectors
jc noovf ;skip if no overflow
;
; overflow to next track
mvi m,0 ;unasec = 0
lhld unatrk
inx h
shld unatrk ;unatrk = unatrk+1
;
noovf:
;match found, mark as unnecessary read
xra a ;0 to accumulator
sta rsflag ;rsflag = 0
jmp rwoper ;to perform the write
;
alloc:
;not an unallocated record, requires pre-read
xra a ;0 to accum
sta unacnt ;unacnt = 0
inr a ;1 to accum
sta rsflag ;rsflag = 1
;
;*****************************************************
;* *
;* Common code for READ and WRITE follows *
;* *
;*****************************************************
rwoper:
;enter here to perform the read/write
xra a ;zero to accum
sta erflag ;no errors (yet)
lda seksec ;compute host sector
rept secshf
ora a ;carry = 0
rar ;shift right
endm
sta sekhst ;host sector to seek
;
; active host sector?
lxi h,hstact ;host active flag
mov a,m
mvi m,1 ;always becomes 1
ora a ;was it already?
jz filhst ;fill host if not
;
; host buffer active, same as seek buffer?
lda sekdsk
lxi h,hstdsk ;same disk?
cmp m ;sekdsk = hstdsk?
jnz nomatch
;
; same disk, same track?
lxi h,hsttrk
call sektrkcmp ;sektrk = hsttrk?
jnz nomatch
;
; same disk, same track, same buffer?
lda sekhst
lxi h,hstsec ;sekhst = hstsec?
cmp m
jz match ;skip if match
;
nomatch:
;proper disk, but not correct sector
lda hstwrt ;host written?
ora a
cnz writehst ;clear host buff
;
filhst:
;may have to fill the host buffer
lda sekdsk
sta hstdsk
lhld sektrk
shld hsttrk
lda sekhst
sta hstsec
lda rsflag ;need to read?
ora a
cnz readhst ;yes, if 1
xra a ;0 to accum
sta hstwrt ;no pending write
;
match:
;copy data to or from buffer
lda seksec ;mask buffer number
ani secmsk ;least signif bits
mov l,a ;ready to shift
mvi h,0 ;double count
rept 7 ;shift left 7
dad h
endm
; hl has relative host buffer address
lxi d,hstbuf
dad d ;hl = host address
xchg ;now in DE
lhld dmaadr ;get/put CP/M data
mvi c,128 ;length of move
lda readop ;which way?
ora a
jnz rwmove ;skip if read
;
; write operation, mark and switch direction
mvi a,1
sta hstwrt ;hstwrt = 1
xchg ;source/dest swap
;
rwmove:
;C initially 128, DE is source, HL is dest
ldax d ;source character
inx d
mov m,a ;to dest
inx h
dcr c ;loop 128 times
jnz rwmove
;
; data has been moved to/from host buffer
lda wrtype ;write type
cpi wrdir ;to directory?
lda erflag ;in case of errors
rnz ;no further processing
;
; clear host buffer for directory write
ora a ;errors?
rnz ;skip if so
xra a ;0 to accum
sta hstwrt ;buffer written
call writehst
lda erflag
ret
;
;*****************************************************
;* *
;* Utility subroutine for 16-bit compare *
;* *
;*****************************************************
sektrkcmp:
;HL = .unatrk or .hsttrk, compare with sektrk
xchg
lxi h,sektrk
ldax d ;low byte compare
cmp m ;same?
rnz ;return if not
; low bytes equal, test high 1s
inx d
inx h
ldax d
cmp m ;sets flags
ret
;
;*****************************************************
;* *
;* WRITEHST performs the physical write to *
;* the host disk, READHST reads the physical *
;* disk. *
;* *
;*****************************************************
writehst:
;hstdsk = host disk #, hsttrk = host track #,
;hstsec = host sect #. write "hstsiz" bytes
;from hstbuf and return error flag in erflag.
;return erflag non-zero if error
ret
;
readhst:
;hstdsk = host disk #, hsttrk = host track #,
;hstsec = host sect #. read "hstsiz" bytes
;into hstbuf and return error flag in erflag.
ret
;
;*****************************************************
;* *
;* Unitialized RAM data areas *
;* *
;*****************************************************
;
sekdsk: ds 1 ;seek disk number
sektrk: ds 2 ;seek track number
seksec: ds 1 ;seek sector number
;
hstdsk: ds 1 ;host disk number
hsttrk: ds 2 ;host track number
hstsec: ds 1 ;host sector number
;
sekhst: ds 1 ;seek shr secshf
hstact: ds 1 ;host active flag
hstwrt: ds 1 ;host written flag
;
unacnt: ds 1 ;unalloc rec cnt
unadsk: ds 1 ;last unalloc disk
unatrk: ds 2 ;last unalloc track
unasec: ds 1 ;last unalloc sector
;
erflag: ds 1 ;error reporting
rsflag: ds 1 ;read sector flag
readop: ds 1 ;1 if read operation
wrtype: ds 1 ;write operation type
dmaadr: ds 2 ;last dma address
hstbuf: ds hstsiz ;host buffer
;
;*****************************************************
;* *
;* The ENDEF macro invocation goes here *
;* *
;*****************************************************
end


1334
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/DEVICE.PLM Normal file
View File

File diff suppressed because it is too large Load Diff

67
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/DIOMOD.DCL Normal file
View File

@@ -0,0 +1,67 @@
dcl
memptr entry returns (ptr),
memsiz entry returns (fixed(15)),
memwds entry returns (fixed(15)),
dfcb0 entry returns (ptr),
dfcb1 entry returns (ptr),
dbuff entry returns (ptr),
reboot entry,
rdcon entry returns (char(1)),
wrcon entry (char(1)),
rdrdr entry returns (char(1)),
wrpun entry (char(1)),
wrlst entry (char(1)),
coninp entry returns (char(1)),
conout entry (char(1)),
rdstat entry returns (bit(1)),
getio entry returns (bit(8)),
setio entry (bit(8)),
wrstr entry (ptr),
rdbuf entry (ptr),
break entry returns (bit(1)),
vers entry returns (bit(16)),
reset entry,
select entry (fixed(7)) returns (bit(16)),
open entry (ptr) returns (bit(16)),
close entry (ptr) returns (bit(16)),
sear entry (ptr) returns (bit(16)),
searn entry returns (bit(16)),
delete entry (ptr) returns (bit(16)),
rdseq entry (ptr) returns (bit(16)),
wrseq entry (ptr) returns (bit(16)),
make entry (ptr) returns (bit(16)),
rename entry (ptr) returns (bit(16)),
logvec entry returns (bit(16)),
curdsk entry returns (fixed(7)),
setdma entry (ptr),
allvec entry returns (ptr),
wpdisk entry,
rovec entry returns (bit(16)),
filatt entry (ptr),
getdpb entry returns (ptr),
getusr entry returns (fixed(7)),
setusr entry (fixed(7)),
rdran entry (ptr) returns (bit(16)),
wrran entry (ptr) returns (bit(16)),
filsiz entry (ptr),
setrec entry (ptr),
resdrv entry (bit(16)) returns (bit(16)),
wrranz entry (ptr) returns (bit(16)),
testwr entry (ptr) returns (bit(16)),
lock entry (ptr) returns (fixed(7)),
unlock entry (ptr) returns (fixed(7)),
multis entry (fixed(7)) returns (fixed(7)),
ermode entry (bit(1)),
freesp entry (fixed(7)) returns (bit(16)),
chain entry returns (bit(16)),
flush entry returns (fixed(7)),
setlbl entry (ptr) returns (bit(16)),
getlbl entry (fixed(7)) returns (bit(8)),
rdxfcb entry (ptr) returns (bit(16)),
wrxfcb entry (ptr) returns (bit(16)),
settod entry (ptr),
gettod entry (ptr),
dfpswd entry (ptr),
sgscb entry (ptr) returns(bit(8));


537
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/DIRLBL.ASM Normal file
View File

@@ -0,0 +1,537 @@
;Function 100 RSX (set/create directory label
; Only for Non banked systems
;
; Procedure:
; 1. If this BDOS call ~= f100 then go to NEXT
; 2. select the current disk for BIOS calls
; 3. search for current label
; 4. if no label then do
; a. find first empty dir slot
; b. if no empties then return error
; c. create dir label from user FCB in DE
; d. call update SFCB
; e. return
; 5. if password protected then ok = password()
; 6. if ~ok then return error
; 7. update label from user info
; 8. call update SFCB
; 9. return
;
; P. Balma
;
; RSX PREFIX
;
serial: db 0,0,0,0,0,0
jmp1: jmp ftest
NEXTj: db 0c3h ; next RSX or BDOS
NEXTa: db 0,0 ; next address
prev: dw 0 ; where from
remove: db 0ffh ; remove RSX at warm start
nbank: db 0FFh ; non banked RSX
rsxname: db 'DIRLBL '
space: dw 0
patch: db 0
;
;
ftest:
push a ;save user regs
mov a,c
cpi 64h ;compare BDOS func 100
jz func100
pop a ;some other BDOS call
goto$next:
lhld NEXTa ; go to next and don't return
pchl
; Set directory label
; de -> .fcb
; drive location
; name & type fields user's discretion
; extent field definition
; bit 1 (80h): enable passwords on drive
; bit 2 (40h): enable file access
; bit 3 (20h): enable file update stamping
; bit 4 (10h): enable file create stamping
; bit 8 (01h): assign new password to dir lbl
func100:
pop a
lxi h,0 ! dad sp ! shld ret$stack ; save user stack
lxi sp,loc$stack
xchg ! shld info ! xchg
mvi c,19h ! call goto$next ! sta curdsk ; get current disk
mvi c,1dh ! call goto$next ; is drive R/O ?
lda curdsk ! mov c,a ! call hlrotr
mov a,l ! ani 01h ! jnz read$only
lhld info ! call getexta ! push a ; if user tries to set time
ani 0111$0000b ! sta set$time ; stamps and no SFCB's...error
mov a,m ! ani 7fh ! mov m,a ; mask off password bit
ani 1 ! sta newpass ; but label can have password
mvi c,69h ! push d ! lxi d,stamp ; get time for possible
call goto$next ! pop d ; update later
mvi c,31h ! lxi d,SCBPB ! call goto$next; get BDOS current dma
shld curdma
lda curdsk ! call dsksel ; BIOS select and sets
; disk parameters
; Does dir lbl exist on drive?
call search ; return if found or
push h ! mvi b,0 ; successfully made
lxi d,20h ! lda nfcbs ! mov c,a ; Are there SFCB's in directory
main0: dad d ! mov a,m ! cpi 21h ! jz main1
inr b ! lda i ! inr a ! sta i ! cmp c
jnz main0
lda set$time ! ora a ! jnz no$SFCB ; no, but user wants to set
; time stamp
sta SFCB ; SFCB = false
main1: shld SFCB$addr ! mov a,b ! sta j ! lhld info
xchg ! pop h ! push h ! inx h ; HL => dir FCB, DE => user FCB
inx d ! mvi c,0ch ; prepare to move DE to HL
call move ! lda newpass ; find out if new password ?
ora a
cnz scramble ; scramble user pass & put in
; dFCB
lda SFCB ! inr a ! jnz mainx1 ; any SFCB's
main2: ; update time & date stamp
lda j ! mov b,a ! mvi a,2 ; j = FCB position from SFCB
sub b ; in 4 FCB sector (0,1,2), thus
; FCBx - 2
; FCBy - 1
; FCBz - 0
; SFCB
; So, 2-j gives FCB offset in
; SFCB
mvi b,0 ! mov c,a ! lhld SFCB$addr
inx h ! lxi d,0ah ! inr c
mainx0: dcr c ! jz mainx1
dad d ! jmp mainx0
mainx1: pop d ! push d ! push h ; HL => dFCB
xchg ! lxi d,18h ! dad d ; HL => dfcb(24) (TS field)
xchg ! pop h ! push d ; of DIR LABEL
; HL => Time/stamp pos in SFCB
lda NEW ! inr a ! jnz st0 ; did we create a new DL?
call stamper ! jmp st1 ; yes
st0: lxi d,4 ! dad d ; update time stamp
pop d ! push h ! xchg ! lxi d,4 ; DFCB position
dad d ! xchg ! pop h ! push d
st1: call stamper
pop h
mainr: pop h ! call getexta ! ori 1 ! mov m,a ; set lsb extent
call write$dir
xra a ! lxi h,0 !jmp goback ; no SFCB, so finished
no$SFCB:
mvi a,0ffh ! lxi h,0ffh ! jmp goback
read$only:
mvi a,0ffh ! lxi h,02ffh
goback: push h ! lhld aDIRBCB ! mvi m,0ffh ; tell BDOS not to use buffer
; contents
push a
mvi c,0dh ! call goto$next ; BDOS reset
lda curdsk ! mov e,a ! mvi c,0eh
call goto$next
lda curdsk ! call seldsk ; restore BDOS environment
pop a ! pop d
lhld ret$stack ! sphl ; restore user stack
xchg ; move error return to h
ret
dsksel: ; select disk and get parameters
call seldsk ; Bios select disk
call gethl ; DE = XLT addr
shld XLT ! xchg
lxi b,0ah ! dad b ; HL = addr DPB
call gethl
shld aDPB ! xchg
lxi b,4 ! dad b ; HL = addr DIR BCB
call gethl ! shld aDIRBCB
lxi b,0ah ! dad b ; Hl => DIR buffer
shld bufptr ; use BDOS buffer for
; BIOS reads & writes
; must jam FF into it to
; signal don't use when done
lhld aDPB
call gethl ; get [HL]
shld spt ! xchg
inx h! inx h! inx h ! inx h! inx h! ; HL => dirmax
call gethl ! shld dirmax ! xchg
inx h ! inx h !
call gethl ! shld checkv ! xchg
call gethl ! shld offset ! xchg
; HL => phys shift
call gethl ! xchg ; E = physhf, D = phymsk
inr d ! mov a,d ; phys mask+1 = # 128 byte rcd
; phymsk * 4 = nfcbs/rcd
ora a ! ral ! ora a ! ral ; clear carry & shift phymsk
sta nfcbs
lhld spt ; spt = spt/phymsk
mov c,e ! call hlrotr ; => spt = shl(spt,physhf)
shld spt
ret
search: ; search dir for pattern in
; info of length in c
xra a ! sta sect ! sta empty
lxi h,0 ! shld dcnt
lhld bufptr ! mov b,h ! mov c,l ; set BIOS dma
call setdma
src0: call read$dir
cpi 0 ! jnz oops ; if A ~= 0 then BIOS error
mvi b,0 ! lda nfcbs ! mov c,a ; BC always = nfcbs
lhld bufptr ! lxi d,20h ; start of buffer and FCB
xra a ; do i = 0 to nfcbs - 1
src1: sta i ! mov a,m ; user #
cpi 20h ! jnz src2 ; dir label mark
push h ! lxi d,10h ! dad d ! mov a,m ; found label, move to DM to
ora a ! pop h ! rz ; check if label is pass prot
push h ! cpi 20h ! pop h ! jnz checkpass
ret
src2: lda empty ! inr a ! jz src3 ; record first sect with empty
mov a,m
cpi 0e5h ! jnz src3 ! lda sect ; save sector #
sta savsect ! mvi a,0ffh ! sta empty ; set empty found = true
src3: dad d ; position to next FCB
lda i ! inr a ; while i < nfcbs
cmp c ! jnz src1
lhld dirmax ! xchg ! lhld dcnt ; while (dcnt < dirmax) &
; dir label not found
dad b ! shld dcnt ! call subdh ; is dcnt <= dirmax ?
jc not$found ; no
lda sect ! inr a ! sta sect ! jmp src0
oops: mvi a,0ffh ! lxi h,1ffh
pop b ! jmp goback ; return perm. error
not$found: ; must make a label
lda empty ! inr a ! jnz no$space ; if empty = false...
lda savsect ! sta sect
call read$dir ; get sector
lhld bufptr ! lxi d,20h ! mvi c,0 ; C = FCB offset in buffer
nf0: mov a,m ! cpi 0e5h ! jz nf1
dad d ! inr c !jmp nf0 ; know that empty occurs here
; so don't need bounds test
nf1: mvi m,20h ! mov a,c ! sta i
mvi a,0 ! push h ! mvi c,32 ; clear fcb to spaces
nf2: inx h ! dcr c ! jz nf3
mov m,a ! jmp nf2
nf3: pop h
mvi a,0ffh ! sta NEW
ret ; HL => dir FCB
no$space: mvi a,0ffh ! lxi h,0ffh ! pop b ! jmp goback
check$pass: ; Dir is password protected, check dma for
; proper password
push h ; save addr dir FCB
lxi d,0dh ! dad d ! mov c,m ; get XOR sum in S1, C = S1
lxi d,0ah ! dad d ; position to last char in label pass
mvi b,8 ; # chars in pass
xchg ! lhld curdma ! xchg ; DE => user pass, HL => label pass
cp0: mov a,m ! xra c ! push b ; HL = XOR(HL,C)
mov c,a ! ldax d ! cmp c ; compare user and label passwords
jnz wrong$pass
pop b ! inx d ! dcx h ! dcr b
jnz cp0
xchg ! shld curdma ; curdma => 2nd pass in field if there
pop h ; restore dir FCB addr
mvi a,0ffh ! sta oldpass
ret
wrong$pass:
mvi a,0ffh ! lxi h,07ffh ! pop b ! pop b
jmp goback
scramble: ; encrypt password at curdma
; 1. sum each char of pass.
; 2. XOR each char with sum
; 3. reverse order of encrypted pass
lxi b,8 ! lhld curdma ;checkpass sets to 2nd pos if
lda oldpass ! inr a ! jz scr0 ;old pass else must move dma
dad b ! shld curdma
; B = sum, C = max size of pass
scr0: mov a,m ! add b ! mov b,a ! dcr c
inx h ! jnz scr0
pop d ! pop h ! push d ; H => dFCB, D was return
lxi d,0dh ! dad d ! mov m,b ; S1 = sum
lxi d,0ah ! dad d ; position to last char in pass
mvi c,8 ! xchg ! lhld curdma
scr1: mov a,m ! xra b ! xchg ! mov m,a ; XOR(char) => dFCB
xchg ! inx h ! dcx d ! dcr c ! jnz scr1
ret
read$dir: ; read directory into bufptr
call track
call sector
call rdsec
ret
writedir: ; write directory from bufptr
lda sect
call track
call sector
call wrsec
ret
track: ; set the track for the BIOS call
lhld spt ! call intdiv ; E = integer(sect/spt)
lhld offset ! dad d ! xchg ! call settrk
ret
sector: ; set the sector for the BIOS
lda sect
lhld spt ! call intdiv ; get mod(sect,spt)
mov a,c ! sub l ; D = x * spt such that D > sect
; D - spt = least x*spt s.t. D < sect
mov c,a ! lda sect ! sub c ; a => remainder of sect/spt
mvi b,0 ! mov c,a ! lhld XLT ; BC = logical sector #, DE = translate
xchg ! call sectrn ; table address
xchg ! call setsec ; BC = physical sector #
ret
intdiv: ; compute the integer division of A/L
mvi c,0 ! lxi d,0
int0: push a ; compute the additive sum of L such
mov a,l ! add c ! mov c,a ; that C = E*L where C = 1,2,3,...
pop a
cmp C ! inr e ! jnc int0 ; if A < E*L then return E - 1
dcr e
ret
getexta:
; Get current extent field address to hl
lxi d,0ch ! dad d ; hl=.fcb(extnum)
mov a,m
ret
move: ; Move data length of length c from source de to
; destination given by hl
inr c ; in case it is zero
move0:
dcr c! rz ; more to move
ldax d! mov m,a ; one byte moved
inx d! inx h ; to next byte
jmp move0
gethl: ; get the word pointed at by HL
mov e,m ! inx h ! mov d,m ! inx h
xchg ! ret
subdh: ; HL = DE - HL
ora a ; clear carry
mov a,e ! sub l ! mov l,a
mov a,d ! sbb h ! mov h,a
ret
hlrotr:
; rotate HL right by amount c
inr c ; in case zero
hlr: dcr c! rz ; return when zero
mov a,h! ora a! rar! mov h,a ; high byte
mov a,l! rar! mov l,a ; low byte
jmp hlr
stamper: ; move time stamp into SFCB & FCB
lda SFCB ! inr a ; no SFCB, update DL only
cz stmp ! pop b ! pop d ! push h ! xchg
push b ! call stmp ! pop b ! xchg ! pop h ! push d
push b
ret
stmp: lxi d,stamp ! mvi c,4 ! call move
ret
;**********************************************************************
curdsk: db 0
set$time: db 0
oldpass: db 0
newpass: db 0
pass$prot db 0
sect: db 0
empty: db 0
stamp: ds 4
NEW: db 0
nfcbs: db 0
i: db 0
j: db 0
SFCB: db 0ffh
savsect: db 0
SFCB$addr: dw 0
info: dw 0
checkv dw 0
offset: dw 0
XLT: dw 0
bufptr: dw 0
spt: dw 0
dcnt: dw 0
curdma: dw 0
aDIRBCB dw 0
aDPB: dw 0
dFCB: dw 0
dirmax: dw 0
SCBPB:
Soff: db 3ch
Sset: db 0
Svalue: dw 0
;
;***********************************************************
;* *
;* bios calls from for track, sector io *
;* *
;***********************************************************
;***********************************************************
;* *
;* equates for interface to cp/m bios *
;* *
;***********************************************************
;
;
base equ 0
wboot equ base+1h ;warm boot entry point stored here
sdsk equ 18h ;bios select disk entry point
strk equ 1bh ;bios set track entry point
ssec equ 1eh ;bios set sector entry point
stdma equ 21h
read equ 24h ;bios read sector entry point
write equ 27h ;bios write sector entry point
stran equ 2dh ;bios sector translation entry point
;
;***********************************************************
;* *
;***********************************************************
seldsk: ;select drive number 0-15, in C
;1-> drive no.
;returns-> pointer to translate table in HL
mov c,a ;c = drive no.
lxi d,sdsk
jmp gobios
;
;***********************************************************
;* *
;***********************************************************
settrk: ;set track number 0-76, 0-65535 in BC
;1-> track no.
mov b,d
mov c,e ;bc = track no.
lxi d,strk
jmp gobios
;
;***********************************************************
;* *
;***********************************************************
setsec: ;set sector number 1 - sectors per track
;1-> sector no.
mov b,d
mov c,e ;bc = sector no.
lxi d,ssec
jmp gobios
;
;***********************************************************
;* *
;***********************************************************
rdsec: ;read current sector into sector at dma addr
;returns in A register: 0 if no errors
; 1 non-recoverable error
lxi d,read
jmp gobios
;***********************************************************
;* *
;***********************************************************
wrsec: ;writes contents of sector at dma addr to current sector
;returns in A register: 0 errors occured
; 1 non-recoverable error
lxi d,write
jmp gobios
;
;***********************************************************
;* *
;***********************************************************
sectrn: ;translate sector number
;1-> logical sector number (fixed(15))
;2-> pointer to translate table
;returns-> physical sector number
push d
lxi d,stran
lhld wboot
dad d ;hl = sectran entry point
pop d
pchl
;
;
setdma: ; set dma
; 1 -> BC = dma address
lxi d,stdma
jmp gobios
;
;
;***********************************************************
;***********************************************************
;***********************************************************
;* *
;* compute offset from warm boot and jump to bios *
;* *
;***********************************************************
;
;
gobios: ;jump to bios entry point
;de -> offset from warm boot entry point
lhld wboot
dad d
lxi d,0
pchl
;
ret$stack: dw 0
ds 32
loc$stack:
end


677
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/DISP.PLM Normal file
View File

@@ -0,0 +1,677 @@
$title ('SDIR - Display Files')
display:
do;
/* Display Module for SDIR */
$include(comlit.lit)
$include(mon.plm)
dcl debug boolean external;
dcl (cur$drv, cur$usr) byte external;
dcl (os,bdos) byte external;
$include(vers.lit)
dcl used$de address external; /* number of used directory entries */
dcl date$opt boolean external; /* date option flag */
dcl display$attributes boolean external; /* attributes display flag */
dcl sorted boolean external;
dcl filesfound address external;
dcl no$page$mode byte external;
dcl sfcbs$present byte external; /* sfcb's there/not there indicator */
$include (search.lit)
dcl find find$structure external;
dcl format byte external, /* format is one of the following */
page$len address external, /* page size before printing new headers */
message boolean external, /* print titles and msg when no file found */
formfeeds boolean external; /* use form feeds to separate headers */
$include(format.lit)
dcl file$displayed boolean public initial (false);
/* true if we ever display a file, from any drive or user */
/* used by main.plm for file not found message */
dcl dir$label byte external;
$include(fcb.lit)
$include(xfcb.lit)
dcl
buf$fcb$adr address external, /* index into directory buffer */
buf$fcb based buf$fcb$adr (32) byte,
/* fcb template for dir */
(f$i$adr,last$f$i$adr,first$f$i$adr) address external,
cur$file address; /* number of file currently */
/* being displayed */
$include(finfo.lit)
/* structure of file info */
dcl file$info based f$i$adr f$info$structure;
dcl x$i$adr address external,
xfcb$info based x$i$adr x$info$structure;
dcl f$i$indices$base address external, /* if sorted then f$i$indices */
f$i$indices based f$i$indices$base (1) address; /* are here */
/* -------- Routines in util.plm -------- */
printchar: procedure (char) external;
dcl char byte;
end printchar;
print: procedure (string$adr) external; /* BDOS call # 9 */
dcl string$adr address;
end print;
printb: procedure external;
end printb;
crlf: procedure external;
end crlf;
printfn: procedure(fname$adr) external;
dcl fname$adr address;
end printfn;
pdecimal: procedure(v,prec,zerosup) external;
/* print value val, field size = (log10 prec) + 1 */
/* with leading zero suppression if zerosup = true */
declare v address, /* value to print */
prec address, /* precision */
zerosup boolean; /* zero suppression flag */
end pdecimal;
p3byte: procedure(byte3adr,prec)external;
/* print 3 byte value with 0 suppression */
dcl (byte3adr,prec) address; /* assume high order bit is < 10 */
end p3byte;
add3byte: procedure (byte3$adr,word$amt) external;
dcl (byte3$adr, word$amt) address;
end add3byte; /* add word to 3 byte structure */
add3byte3: procedure (byte3$adr,byte3) external;
dcl (byte3$adr, byte3) address;
end add3byte3; /* add 3 byte quantity to 3 byte total */
shr3byte: procedure (byte3$adr) external;
dcl byte3$adr address;
end shr3byte;
/* -------- Routines in search.plm -------- */
search$first: procedure(fcb$adr) byte external;
dcl fcb$adr address;
end search$first;
search$next: procedure byte external;
end search$next;
break: procedure external;
end break;
match: procedure boolean external;
dcl fcb$adr address;
end match;
/* -------- Other external routines -------- */
display$time$stamp: procedure (ts$adr) external; /* in dts.plm */
dcl ts$adr address;
end display$time$stamp;
terminate: procedure external; /* in main.plm */
end terminate;
mult23: procedure(index) address external; /* in sort.plm */
dcl index address;
end mult23;
/* -------- From dpb86.plm or dpb80.plm -------- */
$include(dpb.lit)
dpb$byte: procedure (dpb$index) byte external;
dcl dpb$index byte;
end dpb$byte;
dpb$word: procedure (dpb$index) address external;
dcl dpb$index byte;
end dpb$word;
/* -------- routines and data structures local to this module -------- */
direct$console$io: procedure byte;
return mon2(6,0ffh); /* ff to stay downward compatable */
end direct$console$io;
dcl first$time address initial (0);
/*- - - - - - - - - - - - - - - - - - - - - - -*/
wait$keypress: procedure;
declare char byte;
/* if debug then
call print(.(cr,lf,'In wait*keypress...',cr,lf,'$'));
*/
char = direct$console$io;
do while char = 0;
char = direct$console$io;
end;
if char = ctrlc then
call terminate;
end wait$keypress;
declare global$line$count byte initial(1);
/*- - - - - - - - - - - - - - - - - - - - - - -*/
crlf$and$check: procedure;
/*
if debug then
call print(.(cr,lf,'In crlf*and*check...',cr,lf,'$'));
*/
if no$page$mode = 0 then do;
if global$line$count > page$len-1 then do;
call print(.(cr,lf,'Press RETURN to Continue $'));
cur$line = cur$line + 1;
call wait$keypress;
global$line$count = 0;
end; /* global$line$count > page$len */
end; /* no$page$mode = 0 */
call crlf;
global$line$count = global$line$count + 1;
end crlf$and$check;
dcl total$kbytes structure ( /* grand total k bytes of files matched */
lword address,
hbyte byte),
total$recs structure ( /* grand total records of files matched */
lword address,
hbyte byte),
total$1k$blocks structure( /* how many 1k blocks are allocated */
lword address,
hbyte byte);
/*- - - - - - - - - - - - - - - - - - - - - - -*/
add$totals: procedure;
/*
if debug then
call print(.(cr,lf,'In add*totals...',cr,lf,'$'));
*/
call add3byte(.total$kbytes,file$info.kbytes);
call add3byte3(.total$recs,.file$info.recs$lword); /* records in file */
call add3byte(.total$1k$blocks,file$info.onekblocks);
end add$totals;
dcl files$per$line byte;
dcl cur$line address;
dcl hdr (*) byte data (' Name Bytes Recs Attributes $');
dcl hdr$bars (*) byte data ('------------ ------ ------ ------------$');
dcl hdr$pu (*) byte data (' Prot Update $');
dcl hdr$xfcb$bars (*) byte data (' ------ -------------- --------------$');
dcl hdr$access (*) byte data (' Access $');
dcl hdr$create (*) byte data (' Create $');
/* example date 04/02/55 00:34 */
/*- - - - - - - - - - - - - - - - - - - - - - -*/
display$file$info: procedure;
/* print filename.typ */
/*
if debug then
call print(.(cr,lf,'In display*file*info...',cr,lf,'$'));
*/
call printfn(.file$info.name(0));
call printb;
call pdecimal(file$info.kbytes,10000,true);
call printchar('k'); /* up to 32 Meg - Bytes */
/* or 32,000k */
call printb;
call p3byte(.file$info.recs$lword,1); /* records */
call printb;
if rol(file$info.name(f$dirsys-1),1) then /* Type */
call print(.('Sys$'));
else call print(.('Dir$'));
call printb;
if rol(file$info.name(f$rw-1),1) then
call print(.('RO$'));
else call print(.('RW$'));
call printb;
if not display$attributes then do;
if rol(file$info.name(f$arc-1),1) then
call print(.('Arcv $'));
else
call print(.(' $'));
end;
else do;
if rol(file$info.name(f$arc-1),1) then /* arc bit was on in all */
call print$char('A'); /* dir entries */
else call printb;
if rol(file$info.name(0),1) then
call print$char('1');
else call printb;
if rol(file$info.name(1),1) then
call print$char('2');
else call printb;
if rol(file$info.name(2),1) then
call print$char('3');
else call printb;
if rol(file$info.name(3),1) then
call print$char('4');
else call printb;
end;
end display$file$info;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
display$xfcb$info: procedure;
/*
if debug then
call print(.(cr,lf,'In display*xfcb*info...',cr,lf,'$'));
*/
if file$info.x$i$adr <> 0 then
do;
call printb;
x$i$adr = file$info.x$i$adr;
if (xfcb$info.passmode and pm$read) <> 0 then
call print(.('Read $'));
else if (xfcb$info.passmode and pm$write) <> 0 then
call print(.('Write $'));
else if (xfcb$info.passmode and pm$delete) <> 0 then
call print(.('Delete$'));
else
call print(.('None $'));
call printb;
if (xfcb$info.update(0) <> 0 or xfcb$info.update(1) <> 0) then
call display$timestamp(.xfcb$info.update);
else call print(.(' $'));
call printb; call printb;
if (xfcb$info.create(0) <> 0 or xfcb$info.create(1) <> 0) then
call display$timestamp(.xfcb$info.create(0));
/* Create/Access */
end;
end display$xfcb$info;
dcl first$title boolean initial (true);
/*- - - - - - - - - - - - - - - - - - - - - - -*/
display$title: procedure;
/*
if debug then
call print(.(cr,lf,'In display*title...',cr,lf,'$'));
*/
if formfeeds then
call print$char(ff);
else if not first$title then
call crlf$and$check;
call print(.('Directory For Drive $'));
call printchar('A'+ cur$drv); call printchar(':');
if bdos >= bdos20 then
do;
call print(.(' User $'));
call pdecimal(cur$usr,10,true);
end;
call crlf$and$check;
cur$line = 2;
first$title = false;
end display$title;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
short$display: procedure (fname$adr);
dcl fname$adr address;
/*
if debug then
call print(.(cr,lf,'In short*display...',cr,lf,'$'));
*/
if cur$file mod files$per$line = 0 then
do;
if cur$line mod page$len = 0 and first$time = 0 then
do;
call crlf$and$check;
call display$title;
call crlf$and$check;
end;
else
call crlf$and$check;
cur$line = cur$line + 1;
call printchar(cur$drv + 'A');
end;
else call printb;
call print(.(': $'));
call printfn(fname$adr);
call break;
cur$file = cur$file + 1;
first$time = first$time + 1;
end short$display;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
test$att: procedure(char,off,on) boolean;
dcl (char,off,on) byte;
/*
if debug then
call print(.(cr,lf,'In test*att...',cr,lf,'$'));
*/
if (80h and char) <> 80h and off then
return(true);
if (80h and char) = 80h and on then
return(true);
return(false);
end test$att;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
right$attributes: procedure(name$adr) boolean;
dcl name$adr address,
name based name$adr (1) byte;
return
test$att(name(f$rw-1),find.rw,find.ro) and
test$att(name(f$dirsys-1),find.dir,find.sys);
end right$attributes;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
short$dir: procedure; /* looks like "DIR" command */
dcl dcnt byte;
/*
if debug then
call print(.(cr,lf,'In short*dir...',cr,lf,'$'));
*/
fcb(f$drvusr) = '?';
files$per$line = 4;
dcnt = search$first(.fcb);
do while dcnt <> 0ffh;
buf$fcb$adr = shl(dcnt and 11b,5)+.buff; /* dcnt mod 4 * 32 */
if (buf$fcb(f$drvusr) and 0f0h) = 0 and
buf$fcb(f$ex) = 0 and
buf$fcb(f$ex)<= dpb$byte(extmsk$b) then /* no dir labels, xfcbs */
if match then
if right$attributes(.buf$fcb(f$name)) then
call short$display(.buf$fcb(f$name));
dcnt = search$next;
end;
end short$dir;
dcl (last$plus$one,index) address;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
getnxt$file$info: procedure; /* set f$i$adr to base file$info on file */
dcl right$usr boolean; /* to be displayed, f$i$adr = 0ffffh if end */
/*
if debug then
call print(.(cr,lf,'In getnxt*file*info...',cr,lf,'$'));
*/
right$usr = false;
if sorted then
do; index = index + 1;
f$i$adr = mult23(f$i$indices(index));
do while file$info.usr <> cur$usr and index <> filesfound;
index = index + 1;
f$i$adr = mult23(f$i$indices(index));
end;
if index = files$found then
f$i$adr = last$plus$one; /* no more files */
end;
else /* not sorted display in order found in directory */
do; /* use last$plus$one to avoid wrap around problems */
f$i$adr = f$i$adr + size(file$info);
do while file$info.usr <> cur$usr and f$i$adr <> last$plus$one;
f$i$adr = f$i$adr + size(file$info);
end;
end;
end getnxt$file$info;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
size$display: procedure;
/*
if debug then
call print(.(cr,lf,'In size*display...',cr,lf,'$'));
*/
if (format and form$size) <> 0 then
files$per$line = 3;
else files$per$line = 4;
do while f$i$adr <> last$plus$one;
if ((file$info.x$i$adr <> 0 and find.xfcb) or
file$info.x$i$adr = 0 and find.nonxfcb) and
right$attributes(.file$info.name(0)) then
do;
call add$totals;
call short$display(.file$info.name(0));
call pdecimal(file$info.kbytes,10000,true);
call print(.('k$'));
end;
call getnxt$file$info;
end;
end size$display;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
display$no$dirlabel: procedure;
/*
if debug then
call print(.(cr,lf,'In display*no*dirlabel...',cr,lf,'$'));
*/
files$per$line = 2;
first$time = 0;
do while (f$i$adr <> last$plus$one);
if ((file$info.x$i$adr <> 0 and find.xfcb) or
(file$info.x$i$adr = 0 and find.nonxfcb)) and
right$attributes(.file$info.name(0)) then
do;
if ((cur$file mod files$per$line) = 0) then /* need new line */
do;
if ((cur$line mod page$len) = 0) then
do;
if ((no$page$mode = 0) or (first$time = 0)) then do;
call crlf$and$check;
call display$title;
call crlf$and$check;
call print(.hdr);
call printb; /* two sets of hdrs */
call print(.hdr);
call crlf$and$check;
call print(.hdr$bars);
call printb;
call print(.hdr$bars);
call crlf$and$check;
cur$line = cur$line + 4;
first$time = first$time+1;
end;
else do;
call crlf$and$check;
cur$line = cur$line + 1;
end; /* no$page$mode check */
end;
else
do; call crlf$and$check;
cur$line = cur$line + 1;
end;
end;
else
call printb; /* separate the files */
call display$file$info;
cur$file = cur$file + 1;
call add$totals;
call break;
end;
call getnxt$file$info;
end;
end display$no$dirlabel;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
display$with$dirlabel: procedure;
/*
if debug then
call print(.(cr,lf,'In display*with*dirlabel...',cr,lf,'$'));
*/
files$per$line = 1;
first$time = 0;
do while (f$i$adr <> last$plus$one);
if ((file$info.x$i$adr <> 0 and find.xfcb) or
(file$info.x$i$adr = 0 and find.nonxfcb)) and
right$attributes(.file$info.name(0)) then
do;
if cur$line mod page$len = 0 then
do;
if ((no$page$mode = 0) or (first$time = 0)) then do;
call crlf$and$check;
call display$title;
call crlf$and$check;
call print(.hdr);
call print(.hdr$pu);
if (dirlabel and dl$access) <> 0 then
call print(.hdr$access);
else
call print(.hdr$create);
call crlf$and$check;
call print(.hdr$bars);
call print(.hdr$xfcb$bars);
call crlf$and$check;
cur$line = cur$line + 4;
first$time = first$time + 1;
end; /* no$page$mode check */
end;
call crlf$and$check;
cur$line = cur$line + 1;
call display$file$info; /* display non bdos 3.0 file info */
call display$xfcb$info;
cur$file = cur$file + 1;
call break;
call add$totals;
end;
call getnxt$file$info;
end;
end display$with$dirlabel;
/*- - - - -MAIN ENTRY POINT - - - - - - - - - -*/
display$files: procedure public; /* MODULE ENTRY POINT */
/* display the collected data */
/*
if debug then
call print(.(cr,lf,'In main display routine...',cr,lf,'$'));
*/
cur$line, cur$file = 0; /* force titles and new line */
totalkbytes.lword, totalkbytes.hbyte, totalrecs.lword, totalrecs.hbyte =0;
total$1k$blocks.lword, total$1k$blocks.hbyte = 0;
f$i$adr = first$f$i$adr - size(file$info); /* initial if no sort */
last$plus$one = last$f$i$adr + size(file$info);
index = 0ffffh; /* initial if sorted */
call getnxt$file$info; /* base file info record */
if format > 2 then
do;
call print(.('ERROR: Illegal Format Value.',cr,lf,'$'));
call terminate; /* default could be patched - watch it */
end;
do case format; /* format = */
call short$dir; /* form$short */
call size$display; /* form$size */
/* form = full */
if date$opt then do;
if ((( dir$label and dl$exists) <> 0 ) and
((( dir$label and dl$access) <> 0 ) or
(( dir$label and dl$update) <> 0 ) or
(( dir$label and dl$makexfcb) <> 0 )) and (sfcbs$present)) then
call display$with$dirlabel; /* Timestamping is active! */
else do;
call print(.('ERROR: Date and Time Stamping Inactive.',cr,lf,'$'));
call terminate;
end;
end;
else do; /* No date option; Regular Full display */
if (((dir$label and dl$exists) <> 0) and (sfcbs$present)) then
do;
call display$with$dirlabel;
end;
else
do;
call display$no$dirlabel;
end;
end;
end; /* end of case */
if format <> form$short and cur$file > 0 then /* print totals */
do;
if cur$line + 4 > page$len and formfeeds then
do;
call printchar(cr);
call printchar(ff); /* need a new page ? */
end;
else
do;
call crlf$and$check;
call crlf$and$check;
end;
call print(.( 'Total Bytes = $'));
call p3byte(.total$kbytes,1); /* 6 digit max */
call printchar('k');
call print(.(' Total Records = $'));
call p3byte(.total$recs,10); /* 7 digit max */
call print(.(' Files Found = $'));
call pdecimal(cur$file,1000,true); /* 4 digit max */
call print(.(cr,lf,'Total 1k Blocks = $'));
call p3byte(.total$1k$blocks,1); /* 6 digit max */
call print(.(' Used/Max Dir Entries For Drive $'));
call print$char('A' + cur$drv);
call print$char(':'); call printb;
call pdecimal(used$de,1000,true);
call print$char('/');
call pdecimal(dpb$word(dirmax$w) + 1,1000,true);
end;
if cur$file = 0 then
do;
if message then
do; call crlf$and$check;
call display$title;
call print(.('No File',cr,lf,'$'));
end;
call break;
end;
else do;
file$displayed = true;
if not formfeeds then
call crlf$and$check;
end;
end display$files;
end display;

14
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/DPB.LIT Normal file
View File

@@ -0,0 +1,14 @@
/* indices into disk parameter block, used as parameters to dpb procedure */
dcl spt$w lit '0',
blkshf$b lit '2',
blkmsk$b lit '3',
extmsk$b lit '4',
blkmax$w lit '5',
dirmax$w lit '7',
dirblk$w lit '9',
chksiz lit '11',
offset$w lit '13';


46
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/DPB80.PLM Normal file
View File

@@ -0,0 +1,46 @@
$title ('SDIR 8080 - Get Disk Parameters')
dpb80:
do;
/* the purpose of this module is to allow independence */
/* of processor, i.e., 8080 or 8086 */
$include (comlit.lit)
/* function call 32 in 2.0 or later BDOS, returns the address of the disk
parameter block for the currently selected disk, which consists of:
spt (2 bytes) number of sectors per track
blkshf (1 byte) block size = shl(double(128),blkshf)
blkmsk (1 byte) sector# and blkmsk = block number
extmsk (1 byte) logical/physical extents
blkmax (2 bytes) max alloc number
dirmax (2 bytes) size of directory-1
dirblk (2 bytes) reservation bits for directory
chksiz (2 bytes) size of checksum vector
offset (2 bytes) offset for operating system
*/
$include(dpb.lit)
$include(mon.plm)
declare k$per$block address public;
declare dpb$base address;
declare dpb$array based dpb$base (15) byte;
dcl get$dpb lit '31';
dpb$byte: procedure(param) byte public;
dcl param byte;
return(dpb$array(param));
end dpb$byte;
dpb$word: procedure(param) address public;
dcl param byte;
return(dpb$array(param) + shl(double(dpb$array(param+1)),8));
end dpb$word;
base$dpb: procedure public;
dpb$base = mon3(get$dpb,0);
k$per$block = shr(dpb$byte(blkmsk$b)+1,3);
end base$dpb;
end dpb80;


487
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/DUMP.ASM Normal file
View File

@@ -0,0 +1,487 @@
title 'CP/M 3 DUMP Utility'
;***************************
;***************************
;** **
;** D U M P **
;** **
;** FILE DUMP ROUTINE **
;** **
;** JULY 16 1982 **
;** **
;***************************
;***************************
;
;
;
org 100h ;base of TPA
;
;******************
;* BDOS Functions *
;******************
return equ 0 ;System reset
conin equ 01 ;Read console
conout equ 02 ;Type character
bdos equ 05 ;DOS entry point
input equ 06 ;Raw console I/O
pstring equ 09 ;Type string
rstring equ 10 ;Read connsole buffer
chkio equ 11 ;Console status
reset equ 13 ;Reset Disk System
openf equ 15 ;Open file
readf equ 20 ;Read buffer
dmaf equ 26 ;Set DMA address
fsize equ 35 ;Compute file size
errmode equ 45 ;Set ERROR mode
getscb equ 49 ;Get/Set SCB
conmode equ 109 ;Set console mode
;**************************
;* Non Graphic Characters *
;**************************
ctrlc equ 03h ;control - C (^C)
ctrlx equ 018h ;control - X (^X)
cr equ 0dh ;carriage return
lf equ 0ah ;line feed
;
;*******************
;* FCB definitions *
;*******************
fcb equ 5ch ;File Control Block
buf equ 80h ;Password Buffer Location
;
;*****************
;* Begin Program *
;*****************
jmp begin
;
;*********************************************
;* Patch Area, Date, Version & Serial Number *
;*********************************************
dw 0,0,0,0,0,0
db 0
db 'DUMP VERSION 3.0'
db ' DUMP.COM '
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
db 'COPYRIGHT 1982, '
db 'DIGITAL RESEARCH'
db '151282' ;version date [day-month-year]
db 0,0,0,0 ;patch bit map
db '654321' ;Serial Number
;
pgraph: ;print graphic char. in ACC. or period
cpi 7fh
jnc pperiod
cpi ' '
jnc pchar
;
pperiod: ;print period
mvi a,'.'
jmp pchar
;
pchar: ;print char. in ACC. to console
push h
push d
push b
mov e,a ;value in ACC. is put in register E
mvi c,conout ;value in register E is sent to console
call bdos ;print character
pop b
pop d
pop h
ret
;
pnib: ;print nibble in low Acc.
cpi 10
jnc pnibh ;jump if 'A-F'
adi '0'
jmp pchar
;
pnibh:
adi 'A'-10
jmp pchar
;
pbyte: ;print byte in hex
push psw ;save copy for low nibble
rar ;rotate high nibble to low
rar
rar
rar
ani 0fh ;mask high nibble
call pnib
pop psw
ani 0fh
jmp pnib
;
openfile:
mvi c,openf
lxi d,fcb
call bdos ;open file
sta keepa
mov a,h
cpi 07 ;check password status
jz getpasswd ;Reg. H contains '7' if password exists
lda keepa
cpi 0ffh ;ACC.=FF if there is no file found
jz nofile
ret
;
getpasswd:
lda tpasswd
cpi 255 ;check if already tried password
jz wrngpass
call space ;set password memory area too blanks
lxi d,quest
call print ;print question
mvi a,8 ;max # of characters able to input
sta buf ;for password is eight (8)
mvi c,rstring
lxi d,buf
call bdos ;get password
lda buf+1
sta len ;store length of password
cpi 0
jz stop ;if <cr> entered then stop program
call cap ;cap the password
lxi d,buf+2
call setdma
mvi a,255
sta tpasswd ;set Tried Password Flag
mvi a,0
jmp openfile
;
space: ;this routine fills the memory
mvi a,8 ;locations from 82-89H with
lxi h,buf+2 ;a space
space2:
mvi m,' ' ;put a (blank) into the memory
inx h ;location where HL are pointing
dcr a
jnz space2
ret
;
cap: ;this routine takes the inputed
mvi b,8 ;Password and converts it to
lxi h,buf+2 ;upper-case letters
cap2:
mov a,m ;move into the ACC. where the
cpi 'a' ;current HL position points to
jc skip ;and if it is a lower-case letter
cpi '{' ;make it upper case
jnc skip
sui 20h
mov m,a
skip:
inx h ;inc the pointer to the next letter
dcr b
jnz cap2
delchar: ;this routine deletes the last
lda len ;character in the input because
adi 82h ;an extra character is added to
sta len2 ;the input when using BDOS function 10
lhld len2
mvi m,' '
ret
;
fillbuff:
lxi d,buff ;current position
fillbuff2:
sta keepa
push d
call setdma ;set DMA for file reading
call readbuff ;read file and fill BUFF
lda norec ;# records read in current loop
inr a
sta norec
cpi 8 ;check if '8' records read in loop
jz loop2
pop d
lxi h,80h ;80h=128(decimal)= # bytes in 1 record read
dad d
xchg ;changes DMA = DMA+80h
jmp fillbuff2
;
setdma:
mvi c,dmaf
call bdos ;set DMA
ret
;
readbuff:
mvi c,readf
lxi d,fcb
call bdos ;fill buffer
cpi 0 ;ACC. <> 0 if unsuccessful
rz ;return if not End Of File
lda norec
cpi 0 ;this check is needed to see if
jz stop ;the record is the first in the
mvi a,255 ;loop
sta eof ;set End Of File flag
jmp loop2 ;no more buff reading
;
break:
push b
push d ;see if character ready
push h ;if so then quit program
mvi c,chkio ;if character is a ^C
call bdos ;check console status
ora a ;zero flag is set if no character
push psw ;save all registers
mvi c,conin ;console in function
cnz bdos ;eat character if not zero
pop psw ;restore all registers
pop h
pop d
pop b
ret
;
paddr:
lhld aloc ;current display address
mov a,h
call pbyte ;high byte
mov a,l
lhld disloc
call pbyte ;low byte
mvi a,':'
jmp pchar
;
page$check:
lda page$on
cpi 0
cz page$count ;if page mode on call routine
ret
;
crlf:
mvi a,cr
call pchar
mvi a,lf
jmp pchar
;
blank:
mvi a,' '
jmp pchar
;
page$count:
lda page$size ;relative to zero
mov e,a
lda count ;current number of lines
cmp e
jz stop$display ;if xx lines then stop display
inr a
sta count ;count=count+1
ret
;
stop$display:
mvi a,0
sta count ;count=0
lxi d,con$mess
call print
stop$display2:
mvi c,input
mvi e,0fdh
call bdos
cpi ctrlc
jz stop
cpi cr ;compare character with <CR>
jnz stop$display2 ;wait until <CR> is encountered
mvi a,ctrlx
jmp pchar
;
discom: ;check line format
xchg
lhld dismax
mov a,l
sub e
mov l,a
mov a,h
sbb d
xchg
ret
;
display:
lhld size ;[(norec)x(128)]-1
xchg
lxi h,buff ;buffer location
shld disloc
dad d
;
display2:
shld dismax
;
display3:
call page$check
call crlf
call break
jnz stop ;if key pressed then quit
lhld disloc
shld tdisp
call paddr ;print the line address
;
display4:
call blank
mov a,m
call pbyte ;print byte
inx h ;increment the current buffer location
push h
lhld aloc ;aloc is current address for the display
mov a,l
ani 0fh
cpi 0fh ;check if 16 bytes printed
inx h ;increment current display address
shld aloc ;save it
pop h
jnz display4 ;if not then continue
;
display5:
shld disloc ;save the current place
lhld tdisp ;load current place - 16
xchg
call blank
call blank
;
display6:
ldax d ;get byte
call pgraph ;print if graphic character
inx d
lhld disloc
mov a,l
sub e
jnz display6
mov a,h
sub d
jnz display6
lhld disloc
call discom ;end of display ?
rc
jmp display3
;
pintro:
lxi d,intromess
call print
ret
;
setmode: ;this routine allows error codes
mvi c,errmode ;to be detected in the ACC. and
mvi e,255 ;Reg. H instead of BDOS ERROR
call bdos ;Messages
mvi c,conmode ;and also sets the console status
lxi d,1 ;so that only a ^C can affect
call bdos ;function 11
ret
;
check$page:
mvi c,getscb ;Get/Set SCB function
lxi d,page$mode
call bdos
cpi 0
rnz ;return if mode is off (false)
sta page$on ;set 'on' byte
mvi c,getscb
lxi d,page$len
call bdos
dcr a
sta page$size ;store page length (relative to zero)
ret
;
checkfile:
mvi c,fsize
lxi d,fcb
call bdos
lda fcb+33
cpi 0
rnz
lxi d,norecmess
call print
jmp stop
;
chngsize: ;if odd number of records read
sta keepa ;this routine adds 128 or
mvi a,80h ;80h to the display size
mov l,a ;because the ACC. cannot deal
lda keepa ;with decimals
ret
;
print: ;prints the string where
mvi c,pstring ;DE are pointing to
call bdos
ret
;
nofile:
mvi c,pstring
lxi d,nofmess
call bdos ;print 'FILE NOT FOUND'
jmp stop
;
wrngpass:
lxi d,badpass
call print ;print 'False Password'
;
stop: ;stop program execution
mvi c,reset
call bdos
mvi c,return
call bdos
;
begin:
lxi sp,stack
call pintro ;print the intro
call setmode ;set ERROR mode
call check$page ;check console page mode
call openfile ;open the file
call checkfile ;check if reany records exist
;
loop:
jmp fillbuff ;fill the buffer(s)
loop2:
mvi l,0 ;set L = 0
lda norec ;norec is set by fillbuff routine
rar ;(x128) or (/2)
cc chngsize ;if odd # records read then call this routine
mov h,a
dcx h
shld size ;number of bytes to display
pop d
call display ;call display routine
lda eof
cpi 255
jz stop ;jump if End Of File
mvi a,0
sta norec ;reset # records read to 0
jmp loop
;
;****************************
;* Console Messages To User *
;****************************
intromess: db cr,lf,lf,'CP/M 3 DUMP - Version 3.0$'
nofmess: db cr,lf,'ERROR: File Not Found',cr,lf,'$'
quest: db cr,lf,'Enter Password: $'
badpass: db cr,lf,'Password Error$'
norecmess: db cr,lf,'ERROR: No Records Exist$'
con$mess: db cr,lf,'Press RETURN to continue $'
;
;*****************************
;* Variable and Storage Area *
;*****************************
dismax: ds 2 ;Max.# reference
tdisp: ds 2 ;Current buffer location (for ASCII)
disloc: ds 2 ;Current buffer loocation
aloc: dw 0 ;Line address
ploc: ds 2 ;Current buffer location storage
keepa: ds 2 ;Storage for ACC.
norec: db 0 ;# of records read in certain loop (1-8)
eof: db 0 ;End Of File flag
tpasswd: dw 0 ;Tried Password flag
size: dw 0 ;Display size
page$mode: db 02ch ;page mode offset relative to SCB
db 00h
page$len: db 01ch ;page length offset relative to SCB
db 00h
page$on: db 0ffh ;page ON/OFF flag (0=ON)
page$size: db 00h ;page length relative to zero
count: db 0 ;line counter
len: dw 0 ;Password Input length
len2: dw 0 ;Extra character pointer
ds 12h
stack: ds 2
buff: ds 1024 ;The buffer (holds up to 400h = 1k)
end:


219
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/ED.LIN Normal file
View File

@@ -0,0 +1,219 @@
0000 ED#
0000 ED#
0AF3 17 0AF3 18 0AFC 19 0AFC 22 0B00 24
0B07 25 0B08 26 0B13 27 0B14 29 0B18 31
0B20 32 0B24 33 0B2C 34 0B31 35 0B38 36
0B39 37 0B39 38 0B41 39 0B42 40 0B47 41
0B4C 42 0B51 43 0B56 44 0B57 45 0B5B 47
0B73 48 0B78 49 0B7D 50 0B8C 51 0B93 52
0B9A 53 0B9B 54 0B9F 56 0BA7 57 0BAA 58
0BCB 59 0BCB 60 0BCF 62 0BDA 64 0BDF 65
0BE7 66 0BE7 67 0BEE 68 0BEF 69 0BEF 70
0BF4 71 0BF9 72 0BFA 73 0C00 75 0C09 76
0C0A 77 0C10 79 0C13 80 0C1B 81 0C1C 82
0C22 84 0C2B 85 0C2C 87 0C32 89 0C3E 90
0C3F 91 0C45 93 0C51 94 0C52 95 0C58 97
0C64 98 0C65 99 0C6B 101 0C74 102 0C75 103
0C7B 105 0C85 106 0C85 107 0C8B 109 0C95 110
0C95 111 0C9B 113 0CA7 114 0CA8 115 0CAE 117
0CB7 118 0CB8 120 0CB8 121 0CBD 122 0CC3 123
0CC4 124 0CC4 125 0CD0 127 0CD8 128 0CDB 129
0CDB 130 0CDE 131 0CDE 132 0CDE 133 0CE7 134
0CE7 135 0CEB 137 0CF6 138 0CF7 139 0CFD 141
0D06 142 0D07 143 0D07 144 0D0E 145 0D14 146
0D17 147 0D18 149 0D1E 151 0D26 152 0D29 153
0D2C 154 0D2D 155 0D2D 156 0D33 157 0D39 158
0D3A 159 0D40 161 0D54 162 0D55 163 0D55 164
0D5B 165 0D61 166 0D70 167 0D80 168 0D8A 170
0D91 171 0D97 172 0D9F 173 0DA5 174 0DA5 175
0DAC 176 0DB2 177 0DBA 179 0DC0 180 0DC8 181
0DCB 182 0DD1 183 0DD4 184 0DD7 185 0DDF 187
0DE5 188 0DE8 189 0DEB 190 0DF3 191 0DF9 192
0DFF 193 0E05 194 0E0F 196 0E16 197 0E1C 198
0E1C 199 0E22 200 0E28 201 0E2E 202 0E33 203
0E3B 204 0E3E 205 0E44 206 0E45 207 0E45 208
0E59 209 0E5A 210 0E5A 211 0E61 212 0E67 213
0E68 214 0ED3 216 0ED3 217 0ED9 218 0E68 219
0E6B 220 0E72 221 0E81 222 0E8E 223 0E9C 225
0EA5 226 0EA8 227 0EB2 228 0EB8 229 0EBB 230
0EC5 231 0ECF 232 0ED2 233 0EDA 234 0EDA 236
0EE6 237 0EE9 238 0EFA 239 0F01 240 0F05 241
0F05 242 0F66 244 0F66 245 0F6C 246 0F05 247
0F0C 248 0F20 249 0F21 250 0F24 251 0F33 252
0F40 253 0F4B 254 0F4E 255 0F58 256 0F62 257
0F65 258 0F6D 259 0F71 261 0F7D 262 0F80 263
0F8C 264 0F93 265 0F94 266 0F98 268 0FA0 270
0FA3 271 0FAE 272 0FB1 273 0FB6 274 0FB6 275
0FC3 276 0FCA 277 0FCB 278 103B 279 103B 280
104B 281 0FCB 282 0FD0 283 0FDB 284 0FE2 285
0FE7 286 0FEA 287 0FED 288 0FF3 289 0FFB 290
0FFE 291 1004 292 1007 293 100E 294 101E 295
1024 296 1027 297 102D 298 1034 299 103A 300
104C 306 1050 308 1058 309 1059 310 1060 311
1061 313 1065 315 1079 316 1079 317 107D 319
1088 320 108E 321 1092 322 1092 323 1096 325
109D 326 10A5 327 10A9 328 10A9 329 10AF 331
10B5 332 10BA 333 10C6 334 10D4 335 10E1 336
10EF 337 10FF 339 1104 340 110D 341 1110 342
1115 343 1118 344 1119 345 111F 347 1127 348
1128 349 1130 350 1135 351 113A 352 1141 353
1149 354 114E 355 114F 356 114F 357 1157 358
1158 359 1158 360 1160 361 1161 362 1164 363
1165 364 1165 365 116E 367 1175 368 1178 369
1182 371 118E 373 119E 374 11A1 375 11A1 376
11A6 377 11A6 378 11BA 379 11BA 380 11C1 381
11C9 382 11D0 384 11D5 385 11E5 387 11F1 388
11FA 389 11FD 390 1200 391 1205 392 1208 393
120D 394 1212 395 1217 396 1217 397 1228 398
1233 399 1247 400 1247 401 1247 402 124E 403
1254 404 1255 405 1255 406 125D 408 1260 409
126B 410 126E 411 1273 412 1273 413 1287 414
1287 416 1287 417 128D 418 128E 419 128E 420
129B 421 129B 422 129B 423 12A1 424 12A2 425
12A2 426 12AA 428 12B1 429 12B4 430 12B4 431
12B7 432 12B7 433 12B7 435 12BD 436 12C5 438
12CC 439 12D2 440 12D8 441 12DC 442 12DF 444
12E5 445 12EB 446 12F1 447 12F1 448 12F6 449
12FD 450 132A 451 1330 452 1333 453 133A 454
134D 455 1355 457 135A 458 1368 459 136B 460
1372 461 1378 462 137B 463 1383 465 1389 466
1390 467 1393 469 139A 470 13A1 471 13A1 472
13A2 473 13A2 474 13A9 475 13AA 476 13AA 477
13B1 478 13B2 479 13B2 480 13B9 481 13BA 482
13BA 483 13C1 484 13C2 485 13C2 486 13C9 487
13CA 488 13CE 490 13D6 491 13E2 492 13E5 493
13EC 495 13FC 496 13FF 497 140A 498 140D 499
140D 500 1413 501 141F 502 1422 503 1432 504
1439 505 1440 507 144B 508 144E 509 144E 510
1451 511 1452 512 1452 513 1457 514 1458 515
1458 516 145D 517 145E 518 145E 519 1461 520
1464 521 1465 522 1465 523 146D 525 1473 526
147F 527 1488 528 1494 529 1497 531 149D 532
14AF 533 14B8 534 14C3 535 14C3 536 14C4 537
1504 539 1508 541 150F 542 1517 543 151B 544
14C4 545 14C4 546 14D0 547 14D3 548 14E2 550
14E5 551 14E6 552 14E6 553 14F1 554 14F4 555
14FC 557 14FF 558 1500 559 1500 560 1503 561
151B 562 151B 564 151B 565 1527 567 152A 568
152B 569 152B 570 152E 571 153D 572 1545 574
1548 575 1549 576 1549 577 154C 578 154D 579
154D 580 1550 581 1557 582 1569 583 156F 584
1572 585 1575 586 1576 587 1576 588 157B 589
1581 590 1587 591 158A 592 1591 593 1594 594
159B 595 159E 596 15A1 597 15AD 599 15B2 600
15B5 601 15B5 602 15B6 603 15B6 604 15B9 605
15BC 606 15BD 607 15BD 608 15C0 609 15CB 610
15D2 611 15D5 612 15D8 613 15D9 614 15D9 615
15E6 616 15E9 617 15F4 618 15F7 619 15FF 620
1602 621 1603 622 1603 623 1624 624 1624 625
1652 626 1652 627 165F 628 166B 629 166E 630
1624 631 162B 632 1633 634 1638 635 163B 636
1640 637 1640 638 1648 639 164B 640 164E 641
1651 642 166F 643 1675 646 167B 647 1680 648
1696 649 16A0 650 16A6 651 16D3 652 16DA 653
16E1 654 16E4 655 16E7 656 16EE 658 16F5 659
16F8 660 16F8 661 16FC 662 16FC 663 16FC 664
1701 665 1704 666 170A 667 170B 668 170B 669
1719 670 171C 671 171D 672 171D 673 1737 674
1738 675 1738 676 1745 677 1746 678 1746 681
1749 682 174E 683 1756 685 175C 686 1762 687
1765 688 176B 689 178C 690 178F 691 17A1 692
17A9 694 17AC 695 17B3 696 17BA 697 17BD 698
17BD 699 17CC 700 17D9 701 17DA 702 17DA 703
17E0 704 17E1 705 17E1 706 17E7 707 17E8 708
17E8 709 17EE 710 17EF 711 17EF 713 17F2 714
17F5 715 17F8 716 17FE 717 1803 718 1806 719
1809 720 180F 721 1830 722 1836 723 1839 724
183A 725 183A 727 1848 728 184F 729 1852 730
1857 731 1861 732 1862 733 1862 734 1867 735
186D 736 186E 737 186E 738 1871 739 1878 740
1884 741 188A 742 188D 743 1890 744 1891 745
1891 746 1896 747 1899 748 189E 749 18A1 750
18A2 751 18A2 753 18A7 754 18B1 755 18BB 756
18C5 757 18C6 758 18C6 759 18CB 760 18D1 761
18D4 762 18D5 763 18D9 765 18FC 766 18FC 767
1900 769 190B 771 190E 772 1915 773 191D 774
1927 775 192A 776 1932 777 1935 778 1938 779
1938 780 193B 781 01C0 782 01DA 783 01E9 784
01F9 786 01FF 787 0202 788 0202 789 0211 790
021E 791 022A 792 0236 793 023F 794 0246 795
0253 796 025D 797 0262 798 027A 799 027D 800
0288 801 0291 803 0298 804 029D 805 029D 806
02A8 807 02B1 808 02B8 809 02BB 810 02BE 811
02C3 812 02C9 813 02CF 814 02D4 815 02D7 816
02DF 817 02E2 818 02EA 819 02ED 820 02F5 821
02FD 822 0303 823 030A 824 0310 825 0317 826
031A 827 0322 828 0327 829 0327 830 032C 831
032F 832 0335 833 033E 835 0341 836 034B 837
035C 838 035F 839 0362 840 036B 842 036E 843
0374 844 037A 845 0380 846 0383 847 0386 848
038E 850 03AB 851 03AE 852 03B4 853 03BB 854
03C3 855 03E7 857 03ED 858 03F2 859 03F9 861
03FC 862 03FF 863 0402 865 0405 866 0408 867
0410 869 0413 870 0416 871 0419 872 0423 873
0426 874 0429 875 0429 876 042C 877 0434 879
0441 880 0446 881 045F 883 046D 885 0470 886
0475 887 047A 888 0480 889 0485 890 0488 891
048D 892 049A 893 04A0 894 04A6 895 04B0 896
04B3 897 04B6 898 04BC 899 04BC 900 04BC 901
04C1 902 04C7 903 04CA 904 04D2 906 04DE 907
04E1 908 04E4 909 04F3 910 04FB 911 0502 912
0507 913 050A 915 0516 917 051B 918 0524 919
0524 920 052C 921 0532 923 053A 925 0542 926
054C 927 0554 928 0562 929 0562 930 0565 931
0565 932 0565 933 056D 934 0570 935 0578 936
0585 937 058A 938 058D 939 0590 940 0598 941
059B 942 05A6 943 05A9 944 05AC 945 05B5 946
05B8 947 05C0 950 05C5 951 05C8 952 05CF 953
05D8 954 05DB 955 05DE 956 05E1 957 05E6 958
05F5 960 0605 961 060B 962 060E 963 0617 964
061A 965 061D 966 0627 967 062D 968 0632 969
063A 971 063F 972 0642 973 0642 974 064D 975
0650 976 0653 977 0658 978 065F 979 0669 980
0676 981 067D 982 0680 983 0683 984 0686 985
068F 987 0695 988 0698 989 193B 992 193B 993
194A 994 194A 995 194A 996 1950 997 1957 998
196F 999 1972 1000 1975 1001 1976 1002 1976 1003
1982 1005 1987 1006 1995 1007 1998 1009 199D 1010
19A9 1011 19A9 1012 069B 1013 069E 1014 06A6 1016
06A9 1017 06AE 1018 06AE 1019 06B6 1021 06B9 1022
06BC 1023 06BF 1024 06C6 1026 06C9 1027 06D1 1029
06D6 1030 06D9 1031 06D9 1032 06DC 1033 06E4 1035
06E7 1036 06EA 1037 06ED 1038 06F5 1039 06FC 1040
06FC 1041 0703 1042 0708 1043 0710 1045 0717 1046
071D 1047 0723 1048 0726 1049 0729 1050 0731 1052
0734 1053 0737 1054 073A 1055 0742 1057 0745 1058
0748 1059 074B 1060 0753 1062 0756 1063 0759 1064
075C 1065 0764 1066 076A 1067 0772 1069 0779 1071
077E 1072 0781 1073 0784 1074 0787 1075 078E 1076
0791 1077 0794 1078 0797 1079 079A 1080 07A2 1081
07A8 1082 07B0 1083 07BE 1084 07C6 1086 07CD 1088
07DB 1089 07E0 1090 07E8 1091 07EB 1092 07EE 1093
07F9 1094 07FC 1095 0804 1097 081C 1099 081F 1100
0822 1101 0825 1102 0825 1103 0828 1104 083B 1106
0843 1108 0848 1109 084E 1110 0854 1111 0857 1112
085E 1113 0861 1114 0868 1115 086B 1116 086E 1117
0873 1118 0876 1119 0879 1120 0881 1122 0884 1123
088B 1124 088E 1125 0891 1126 0894 1127 089C 1130
089F 1131 08A2 1132 08A8 1133 08AB 1134 08B2 1135
08B5 1136 08BC 1137 08CA 1138 08D7 1139 08DA 1140
08DD 1141 08E3 1142 08F3 1143 08F6 1144 0906 1145
090B 1146 090E 1147 0914 1148 0917 1149 091A 1150
0932 1152 0937 1153 0943 1154 0946 1155 0961 1156
0964 1157 096A 1158 096F 1159 0979 1160 097C 1161
0984 1163 0987 1164 098E 1165 099C 1166 09A3 1167
09A6 1168 09A9 1169 09AC 1170 09AF 1171 09B4 1172
09BA 1173 09BD 1174 09C0 1175 09C5 1176 09D1 1177
09D4 1178 09D7 1179 09DA 1180 09DD 1181 09E5 1183
09E8 1184 09EB 1185 09F2 1186 09F5 1187 0A06 1188
0A10 1189 0A1D 1190 0A24 1191 0A27 1192 0A2A 1193
0A2D 1194 0A30 1195 0A38 1196 0A3E 1197 0A46 1199
0A49 1200 0A50 1202 0A53 1203 0A59 1204 0A5C 1207
0A64 1209 0A67 1210 0A6C 1211 0A72 1212 0A78 1213
0A80 1214 0A83 1215 0A83 1216 0A86 1217 0A98 1218
0AA3 1219 0AB0 1220 0AB0 1221 0AB3 1222 0ABB 1224
0AC2 1226 0ACA 1227 0ACD 1228 0ACD 1229 0AD4 1230
0AD7 1231 0ADA 1232 0ADD 1233 0AE5 1234 0AE8 1235
0AEB 1236 0AEE 1237 0AEE 1238 0AF1 1239
0000 MODULE#

1630
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/ED.PLM Normal file
View File

File diff suppressed because it is too large Load Diff

106
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/ED20PAT.ASM Normal file
View File

@@ -0,0 +1,106 @@
; assembly language version of mem$move for ed speedup
; version 2.0 of ED
;
mem$move equ 13cah
moveflag equ 1d34h
direction equ 1d20h
front equ 1d22h
back equ 1d24h
first equ 1d26h
last equ 1d28h
baseline equ 1c10h
memory equ 1d4dh
;
forward equ 1
lf equ 0ah
;
org mem$move
lxi h,moveflag
mov m,c ;1 = move data
lxi d,memory
lhld front
dad d ;memory+front
push h
lhld back
dad d
push h
lda direction
cpi forward
jnz moveback
lhld last
mov a,c ;moveflag to a
rar
jc moveforw
; set back to last
shld back
pop h
pop h
ret
;
moveforw:
dad d ;memory+last
mov b,h
mov c,l
pop h
pop d ;bc=last, de=front, hl=back
movef: mov a,l ;back < last?
sub c
mov a,h
sbb b ;cy if true
jnc emove
inx h ;back=back+1
mov a,m ;char to a
cpi lf ;end of line?
jnz notlff
push h
lhld baseline
inx h ;baseline=baseline+1
shld baseline
pop h
notlff:
stax d ;to front
inx d ;front=front+1
jmp movef
moveback:
lhld first
dad d ;memory+first
mov b,h
mov c,l
pop h
pop d ;bc=first, de=front, hl=last
moveb: mov a,c ;first > front?
sub e
mov a,b
sbb d ;cy if true
jnc emove
dcx d ;front=front-1
ldax d ;char to a
cpi lf
jnz notlfb
push h
lhld baseline
dcx h ;baseline=baseline-1
shld baseline
pop h
notlfb: push psw ;save char
lda moveflag
rar
jnc nomove
pop psw
mov m,a ;store to back
dcx h
jmp moveb
nomove: pop psw
jmp moveb
;
emove: push d
lxi d,-memory
dad d ;relative value of back
shld back
pop h
dad d ;relative value of front
shld front
ret
end


825
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/ERASE.PLM Normal file
View File

@@ -0,0 +1,825 @@
$ TITLE('CP/M 3.0 --- ERA ')
/* contains the confirm option */
era:
do;
/*
Copyright (C) 1982
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
*/
/*
Revised:
19 Jan 80 by Thomas Rolander
14 Sept 81 by Doug Huskey
23 June 82 by John Knight
03 Dec 82 by Bruce Skidmore
*/
declare
true literally '1',
false literally '0',
forever literally 'while true',
lit literally 'literally',
proc literally 'procedure',
dcl literally 'declare',
addr literally 'address',
cr literally '13',
lf literally '10',
ctrlc literally '3',
ctrlx literally '18h',
tab literally '9',
bksp literally '8',
cpmversion literally '30h',
dcnt$offset literally '45h',
searcha$offset literally '47h',
searchl$offset literally '49h',
hash1$offset literally '00h',
hash2$offset literally '02h',
hash3$offset literally '04h';
declare plm label public;
/**************************************
* *
* B D O S INTERFACE *
* *
**************************************/
mon1:
procedure (func,info) external;
declare func byte;
declare info address;
end mon1;
mon2:
procedure (func,info) byte external;
declare func byte;
declare info address;
end mon2;
mon3:
procedure (func,info) address external;
declare func byte;
declare info address;
end mon3;
parse:
procedure (pfcb) address external;
declare pfcb address;
end parse;
declare cmdrv byte external; /* command drive */
declare fcb (1) byte external; /* 1st default fcb */
declare fcb16 (1) byte external; /* 2nd default fcb */
declare pass0 address external; /* 1st password ptr */
declare len0 byte external; /* 1st passwd length */
declare pass1 address external; /* 2nd password ptr */
declare len1 byte external; /* 2nd passwd length */
declare tbuff (1) byte external; /* default dma buffer */
/**************************************
* *
* B D O S Externals *
* *
**************************************/
read$console:
procedure byte;
return mon2 (1,0);
end read$console;
printchar:
procedure(char);
declare char byte;
call mon1(2,char);
end printchar;
conin:
procedure byte;
return mon2(6,0fdh);
end conin;
print$buf:
procedure (buffer$address);
declare buffer$address address;
call mon1 (9,buffer$address);
end print$buf;
read$console$buf:
procedure (buffer$address,max) byte;
declare buffer$address address;
declare new$max based buffer$address address;
declare max byte;
new$max = max;
call mon1(10,buffer$address);
buffer$address = buffer$address + 1;
return new$max; /* actually number of chars input */
end read$console$buf;
check$con$stat:
procedure byte;
return mon2 (11,0);
end check$con$stat;
version: procedure address;
/* returns current cp/m version # */
return mon3(12,0);
end version;
setdma: procedure(dma);
declare dma address;
call mon1(26,dma);
end setdma;
search$first:
procedure (fcb$address) byte;
declare fcb$address address;
return mon2 (17,fcb$address);
end search$first;
search$next:
procedure byte;
return mon2 (18,0);
end search$next;
delete$file:
procedure (fcb$address) address;
declare fcb$address address;
return mon3 (19,fcb$address);
end delete$file;
get$user$code:
procedure byte;
return mon2 (32,0ffh);
end get$user$code;
/* 0ff => return BDOS errors */
return$errors:
procedure;
call mon1 (45,0ffh);
end return$errors;
declare scbpd structure
(offset byte,
set byte,
value address);
getscbword:
procedure (offset) address;
declare offset byte;
scbpd.offset = offset;
scbpd.set = 0;
return mon3(49,.scbpd);
end getscbword;
setscbword:
procedure (offset,value);
declare offset byte;
declare value address;
scbpd.offset = offset;
scbpd.set = 0FEh;
scbpd.value = value;
call mon1(49,.scbpd);
end setscbword;
set$console$mode: procedure;
/* set console mode to ctrl-c only */
call mon1(109,1);
end set$console$mode;
declare
parse$fn structure (
buff$adr address,
fcb$adr address);
/**************************************
* *
* GLOBAL VARIABLES *
* *
**************************************/
declare successful lit '0FFh';
declare dir$entry$adr address;
declare dir$entry based dir$entry$adr (1) byte;
declare confirm$opt byte initial (false);
declare passwd$opt byte initial (false);
declare save$passwd (8) byte;
declare (savdcnt,savsearcha,savsearchl) address;
declare (hash1,hash2,hash3) address;
/* options scanner variables and data */
declare
options(*) byte
data('PASSWORD0CONFIRM',0ffh),
off$opt(*) byte data(0,9,16),
end$list byte data (0ffh),
delimiters(*) byte data (0,'[]=, ',0,0ffh),
SPACE byte data(5),
j byte initial(0),
buf$ptr address,
index byte,
endbuf byte,
delimiter byte;
declare end$of$string byte initial('0');
/**************************************
* *
* S U B R O U T I N E S *
* *
**************************************/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* * * * Option scanner * * * */
separator: procedure(character) byte;
/* determines if character is a
delimiter and which one */
declare k byte,
character byte;
k = 1;
loop: if delimiters(k) = end$list then return(0);
if delimiters(k) = character then return(k); /* null = 25 */
k = k + 1;
go to loop;
end separator;
opt$scanner: procedure(list$ptr,off$ptr,idx$ptr);
/* scans the list pointed at by idxptr
for any strings that are in the
list pointed at by list$ptr.
Offptr points at an array that
contains the indices for the known
list. Idxptr points at the index
into the list. If the input string
is unrecognizable then the index is
0, otherwise > 0.
First, find the string in the known
list that starts with the same first
character. Compare up until the next
delimiter on the input. if every input
character matches then check for
uniqueness. Otherwise try to find
another known string that has its first
character match, and repeat. If none
can be found then return invalid.
To test for uniqueness, start at the
next string in the knwon list and try
to get another match with the input.
If there is a match then return invalid.
else move pointer past delimiter and
return.
P.Balma */
declare
buff based buf$ptr (1) byte,
idx$ptr address,
off$ptr address,
list$ptr address;
declare
i byte,
j byte,
list based list$ptr (1) byte,
offsets based off$ptr (1) byte,
wrd$pos byte,
character byte,
letter$in$word byte,
found$first byte,
start byte,
index based idx$ptr byte,
save$index byte,
(len$new,len$found) byte,
valid byte;
/*****************************************************************************/
/* internal subroutines */
/*****************************************************************************/
check$in$list: procedure;
/* find known string that has a match with
input on the first character. Set index
= invalid if none found. */
declare i byte;
i = start;
wrd$pos = offsets(i);
do while list(wrd$pos) <> end$list;
i = i + 1;
index = i;
if list(wrd$pos) = character then return;
wrd$pos = offsets(i);
end;
/* could not find character */
index = 0;
return;
end check$in$list;
setup: procedure;
character = buff(0);
call check$in$list;
letter$in$word = wrd$pos;
/* even though no match may have occurred, position
to next input character. */
i = 1;
character = buff(1);
end setup;
test$letter: procedure;
/* test each letter in input and known string */
letter$in$word = letter$in$word + 1;
/* too many chars input? 0 means
past end of known string */
if list(letter$in$word) = end$of$string then valid = false;
else
if list(letter$in$word) <> character then valid = false;
i = i + 1;
character = buff(i);
end test$letter;
skip: procedure;
/* scan past the offending string;
position buf$ptr to next string...
skip entire offending string;
ie., falseopt=mod, [note: comma or
space is considered to be group
delimiter] */
character = buff(i);
delimiter = separator(character);
/* No skip for ERA */
do while ((delimiter < 1) or (delimiter > 6));
i = i + 1;
character = buff(i);
delimiter = separator(character);
end;
endbuf = i;
buf$ptr = buf$ptr + endbuf + 1;
return;
end skip;
eat$blanks: procedure;
declare charac based buf$ptr byte;
do while ((delimiter := separator(charac)) = SPACE);
buf$ptr = buf$ptr + 1;
end;
end eat$blanks;
/*****************************************************************************/
/* end of internals */
/*****************************************************************************/
/* start of procedure */
call eat$blanks;
start = 0;
call setup;
/* match each character with the option
for as many chars as input
Please note that due to the array
indices being relative to 0 and the
use of index both as a validity flag
and as a index into the option/mods
list, index is forced to be +1 as an
index into array and 0 as a flag*/
do while index <> 0;
start = index;
delimiter = separator(character);
/* check up to input delimiter */
valid = true; /* test$letter resets this */
do while delimiter = 0;
call test$letter;
if not valid then go to exit1;
delimiter = separator(character);
end;
go to good;
/* input ~= this known string;
get next known string that
matches */
exit1: call setup;
end;
/* fell through from above, did
not find a good match*/
endbuf = i; /* skip over string & return*/
call skip;
return;
/* is it a unique match in options
list? */
good: endbuf = i;
len$found = endbuf;
save$index = index;
valid = false;
next$opt:
start = index;
call setup;
if index = 0 then go to finished;
/* look at other options and check
uniqueness */
len$new = offsets(index + 1) - offsets(index) - 1;
if len$new = len$found then do;
valid = true;
do j = 1 to len$found;
call test$letter;
if not valid then go to next$opt;
end;
end;
else go to nextopt;
/* fell through...found another valid
match --> ambiguous reference */
index = 0;
call skip; /* skip input field to next delimiter*/
return;
finished: /* unambiguous reference */
index = save$index;
buf$ptr = buf$ptr + endbuf;
call eat$blanks;
if delimiter <> 0 then
buf$ptr = buf$ptr + 1;
else
delimiter = 5;
return;
end opt$scanner;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
break: procedure;
if check$con$stat then do;
call print$buf(.(cr,lf,'*** Aborted by ^C ***$'));
call mon1(0,0);
end;
end break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* upper case character from console */
crlf: proc;
call printchar(cr);
call printchar(lf);
end crlf;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* fill string @ s for c bytes with f */
fill: proc(s,f,c);
dcl s addr,
(f,c) byte,
a based s byte;
do while (c:=c-1)<>255;
a = f;
s = s+1;
end;
end fill;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* error message routine */
error: proc(code);
declare
code byte;
call printchar(' ');
if code=1 then
call print$buf(.(cr,lf,'Disk I/O $'));
if code=2 then
call print$buf(.(cr,lf,'Drive $'));
if code = 3 or code = 2 then
call print$buf(.('Read Only$'));
if code = 5 then
call print$buf(.('Currently Opened$'));
if code = 7 then
call print$buf(.('Password Error$'));
if code < 3 then
call mon1(0,0);
end error;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* try to delete fcb at fcb$address
return error code if unsuccessful */
delete:
procedure(fcb$address) byte;
declare
fcb$address address,
fcbv based fcb$address (32) byte,
error$code address,
code byte;
if passwd$opt then
fcbv(5) = fcbv(5) or 80h;
call setdma(.save$passwd(0)); /* password */
fcbv(0) = fcb(0); /* drive */
error$code = delete$file(fcb$address);
fcbv(5) = fcbv(5) and 7fh; /* reset xfcb bit */
if low(error$code) = 0FFh then do;
code = high(error$code);
if (code=1) or (code=2) then
call error(code);
return code;
end;
return successful;
end delete;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* upper case character from console */
ucase: proc byte;
dcl c byte;
if (c:=conin) >= 'a' then
if c < '{' then
return(c-20h);
return c;
end ucase;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* get password and place at fcb + 16 */
getpasswd: proc;
dcl (i,c) byte;
call print$buf(.('Password: ','$'));
retry:
call fill(.save$passwd(0),' ',8);
do i = 0 to 7;
nxtchr:
if (c:=ucase) >= ' ' then
save$passwd(i)=c;
if c = cr then
go to exit;
if c = ctrlx then
goto retry;
if c = bksp then do;
if i<1 then
goto retry;
else do;
save$passwd(i:=i-1)=' ';
goto nxtchr;
end;
end;
if c = 3 then
call mon1(0,0);
end;
exit:
c = check$con$stat; /* clear raw I/O mode */
end getpasswd;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* error on deleting a file */
file$err: procedure(code);
declare code byte;
if not confirm$opt then do; /* print file */
call printchar('A'+fcb(0)-1);
call printchar(':');
call printchar(' ');
do k=1 to 11;
if k=9 then
call printchar('.');
call printchar(dir$entry(k));
end;
call print$buf(.(' $'));
end;
call print$buf(.('Not erased, $'));
call error(code);
call crlf;
end file$err;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
erase: procedure;
if (code:=delete(.fcb)) <> successful then do;
if code < 3 then
call error(code);
else if code = 7 then do;
call file$err(code);
call getpasswd;
call crlf;
code = delete(.fcb);
end;
if code <> successful then
call file$err(code);
end;
end erase;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
parse$options: procedure;
declare
t address,
char based t byte,
i byte;
delimiter = 1;
index = 0;
do while ((delimiter <> 0) and (delimiter <> 2) and (delimiter <> 6));
call opt$scanner(.options(0),.off$opt(0),.index);
if index = 0 then do;
/* unrecognized option */
call print$buf(.(cr,lf,'ERROR: Missing Delimiter or$'));
call print$buf(.(cr,lf,' Unrecognized Option $'));
call print$buf(.('Near: $'));
t = buf$ptr - endbuf - 1;
do i = 1 to endbuf;
call printchar(char);
t = t + 1;
end;
call mon1(0,0);
end;
if index = 1 then
passwd$opt = true;
if index = 2 then
confirm$opt = true;
end;
end parse$options;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
input$found: procedure (buffer$adr) byte;
declare buffer$adr address;
declare char based buffer$adr byte;
do while (char = ' ') or (char = tab);
buffer$adr = buffer$adr + 1;
end;
if char = 0 then /* eoln */
return false; /* input not found */
else
return true; /* input found */
end input$found;
/**************************************
* *
* M A I N P R O G R A M *
* *
**************************************/
declare (i,k,code,response,user,dcnt) byte;
declare status address;
declare char$count byte;
declare last$dseg$byte byte
initial (0);
declare no$chars byte;
declare m based status byte;
plm:
do;
if (low(version) < cpmversion) or (high(version) = 1) then do;
call print$buf(.('Requires CP/M 3.0 $'));
call mon1(0,0);
end;
call set$console$mode;
if not input$found(.tbuff(1)) then do;
/* prompt for file */
confirm$opt = true; /* confirm, unless otherwise specified */
call print$buf(.('Enter filename: $'));
no$chars = read$console$buf(.tbuff(0),40);
char$count = no$chars + 2;
call print$buf(.(cr,lf,'$'));
tbuff(1) = ' '; /* blank out nc field */
tbuff(char$count) = 00h; /* eoln marker set */
/* convert input string to upper case */
do i = 1 to char$count;
if tbuff(i+1) >= 'a' then
if tbuff(i+1) < '}' then
tbuff(i+1) = tbuff(i+1) - 20h;
end;
end;
parse$fn.buff$adr = .tbuff(1);
parse$fn.fcb$adr = .fcb;
status = parse(.parse$fn);
if status = 0FFFFh then do;
call print$buf(.('ERROR: Invalid file name $'));
call mon1(0,0);
end;
if status <> 0 then do; /* options must follow */
do while m = ' ';
status = status + 1; /* skip over blank delimiters */
end;
buf$ptr = status + 1; /* skip first delimiter */
call parse$options;
end;
if fcb(0) = 0 then
fcb(0) = low (mon2 (25,0)) + 1;
user = get$user$code;
call return$errors;
call move(8,.fcb16,.save$passwd(0));
if not confirm$opt then do;
i = 0;
do while fcb(i:=i+1) = '?';
end;
if i > 11 then
if not passwd$opt then do;
call print$buf(.('Confirm delete all user files (Y/N)?$'));
response = read$console;
if not ((response = 'y') or (response = 'Y')) then
call mon1(0,0);
call crlf;
end;
end;
call move(16,.fcb,.fcb16);
call setdma(.tbuff);
dcnt = search$first (.fcb16);
if dcnt = 0FFh then do;
call print$buf(.('No File $'));
call mon1(0,0);
end;
do while dcnt <> 0ffh;
dir$entry$adr = .tbuff(ror(dcnt,3) and 110$0000b);
savdcnt = getscbword(dcnt$offset);
savsearcha = getscbword(searcha$offset);
savsearchl = getscbword(searchl$offset);
/* save searched fcb's hash code (5 bytes) */
hash1 = getscbword(hash1$offset);
hash2 = getscbword(hash2$offset);
hash3 = getscbword(hash3$offset);
if confirm$opt then do;
if dir$entry(0) = user then do;
call printchar ('A'+fcb(0)-1);
call printchar (':');
call printchar (' ');
do k = 1 to 11;
if k = 9
then call printchar ('.');
call printchar (dir$entry(k));
end;
call print$buf(.(' (Y/N)? $'));
response = read$console;
call printchar (cr);
call printchar (lf);
if response = ctrlc then do;
call print$buf(.(cr,lf,'*** Aborted by ^C ***$'));
call mon1(0,0);
end;
if (response = 'y') or
(response = 'Y') then do;
call move (12,.dir$entry(1),.fcb(1));
call erase;
end;
end;
end;
else do; /* not confirm option */
call move(12,.dir$entry(1),.fcb(1));
call break;
call erase;
end;
call setdma(.tbuff);
call setscbword(dcnt$offset,savdcnt);
call setscbword(searcha$offset,savsearcha);
call setscbword(searchl$offset,savsearchl);
/* restore hash code */
call setscbword(hash1$offset,hash1);
call setscbword(hash2$offset,hash2);
call setscbword(hash3$offset,hash3);
if .fcb16 <> savsearcha then /* restore search fcb if destroyed */
call move(16,.fcb16,savsearcha);
dcnt = search$next;
end;
call mon1(0,0);
end;
end era;


22
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/FCB.LIT Normal file
View File

@@ -0,0 +1,22 @@
declare
f$drvusr lit '0', /* drive/user byte */
f$name lit '1', /* file name */
f$namelen lit '8', /* file name length */
f$type lit '9', /* file type field */
f$typelen lit '3', /* type length */
f$rw lit '9', /* high bit is R/W attribute */
f$dirsys lit '10', /* high bit is dir/sys attribute */
f$arc lit '11', /* high bit is archive attribute */
f$ex lit '12', /* extent */
f$s1 lit '13', /* module byte */
f$rc lit '15', /* record count */
f$diskmap lit '16', /* file disk map */
diskmaplen lit '16', /* disk map length */
f$drvusr2 lit '16', /* fcb2 */
f$name2 lit '17',
f$type2 lit '25',
f$rrec lit '33', /* random record */
f$rreco lit '35'; /* " " overflow */


16
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/FINFO.LIT Normal file
View File

@@ -0,0 +1,16 @@
/* file info record for SDIR - note if this structure changes in size */
/* the multXX: routine in the sort.plm module must also change */
declare
f$info$structure lit 'structure(
usr byte, name (8) byte, type (3) byte, onekblocks address,
kbytes address, recs$lword address, recs$hbyte byte,
hash$link address, x$i$adr address)';
declare
x$info$structure lit 'structure (
create (4) byte,
update (4) byte,
passmode byte)';


6
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/FORMAT.LIT Normal file
View File

@@ -0,0 +1,6 @@
dcl form$short lit '0', /* format values for SDIR */
form$size lit '1',
form$full lit '2';


2000
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/GENCOM.PLM Normal file
View File

File diff suppressed because it is too large Load Diff

1479
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/GENCPM.PLM Normal file
View File

File diff suppressed because it is too large Load Diff

940
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/GET.PLM Normal file
View File

@@ -0,0 +1,940 @@
$ TITLE('CP/M 3.0 --- GET user interface')
get:
do;
/*
Copyright (C) 1982
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
*/
/*
Written: 30 July 82 by John Knight
12 Sept 82 by Doug Huskey
*/
/********************************************
* *
* LITERALS AND GLOBAL VARIABLES *
* *
********************************************/
declare
true literally '1',
false literally '0',
forever literally 'while true',
lit literally 'literally',
proc literally 'procedure',
dcl literally 'declare',
addr literally 'address',
cr literally '13',
lf literally '10',
ctrlc literally '3',
ctrlx literally '18h',
bksp literally '8',
con$type literally '0',
aux$type literally '1',
con$width$offset literally '1ah',
ccp$flag$offset literally '18h',
get$rsx$init literally '128',
get$rsx$kill literally '129',
get$rsx$fcb literally '130',
cpmversion literally '30h';
declare ccp$flag byte;
declare con$width byte;
declare i byte;
declare begin$buffer address;
declare buf$length byte;
declare no$chars byte;
declare get$init$pb byte initial(get$rsx$init);
declare get$kill$pb byte initial(get$rsx$kill);
declare get$fcb$pb byte initial(get$rsx$fcb);
declare input$type byte;
declare
sub$fcb (*) byte data (0,'SYSIN $$$'),
get$msg (*) byte data ('Getting console input from $');
/* scanner variables and data */
declare
options(*) byte data
('INPUT~FROM~FILE~STATUS~CONDITIONAL~',
'FALSE~TRUE~CONSOLE~CONIN:~AUXILIARY~',
'AUXIN:~END~CON:~AUX:~NOT~ECHO~FILTERED~SYSTEM~PROGRAM',0FFH),
options$offset(*) byte data
(0,6,11,16,23,35,41,46,54,61,71,78,82,87,92,96,101,110,117,124),
end$list byte data (0ffh),
delimiters(*) byte data (0,'[]=, ./;',0,0ffh),
SPACE byte data(5),
buf$ptr address,
index byte,
endbuf byte,
j byte initial(0),
delimiter byte;
declare end$of$string byte initial ('~');
declare getpb structure
(input$type byte,
echo$flag byte,
filtered$flag byte,
program$flag byte)
initial(con$type,true,true,true);
declare scbpd structure
(offset byte,
set byte,
value address);
declare parse$fn structure
(buff$adr address,
fcb$adr address);
declare plm label public;
/**************************************
* *
* B D O S INTERFACE *
* *
**************************************/
mon1:
procedure (func,info) external;
declare func byte;
declare info address;
end mon1;
mon2:
procedure (func,info) byte external;
declare func byte;
declare info address;
end mon2;
mon3:
procedure (func,info) address external;
declare func byte;
declare info address;
end mon3;
declare cmdrv byte external; /* command drive */
declare fcb (1) byte external; /* 1st default fcb */
declare fcb16 (1) byte external; /* 2nd default fcb */
declare pass0 address external; /* 1st password ptr */
declare len0 byte external; /* 1st passwd length */
declare pass1 address external; /* 2nd password ptr */
declare len1 byte external; /* 2nd passwd length */
declare tbuff (1) byte external; /* default dma buffer */
/**************************************
* *
* B D O S Externals *
* *
**************************************/
printchar:
procedure(char);
declare char byte;
call mon1(2,char);
end printchar;
conin:
procedure byte;
return mon2(6,0fdh);
end conin;
print$buf:
procedure (buffer$address);
declare buffer$address address;
call mon1 (9,buffer$address);
end print$buf;
read$console$buf:
procedure (buffer$address,max) byte;
declare buffer$address address;
declare new$max based buffer$address address;
declare max byte;
new$max = max;
call mon1(10,buffer$address);
buffer$address = buffer$address + 1;
return new$max; /* actually number of characters input */
end read$console$buf;
version: procedure address;
/* returns current cp/m version # */
return mon3(12,0);
end version;
check$con$stat: procedure byte;
return mon2(11,0);
end check$con$stat;
open$file:
procedure (fcb$address) address;
declare fcb$address address;
return mon3(15,fcb$address);
end open$file;
set$dma: procedure(dma);
declare dma address;
call mon1(26,dma);
end set$dma;
/* 0ffh ==> return BDOS errors */
return$errors: procedure (mode);
declare mode byte;
call mon1(45,mode);
end return$errors;
getscbbyte: procedure (offset) byte;
declare offset byte;
scbpd.offset = offset;
scbpd.set = 0;
return mon2(49,.scbpd);
end getscbbyte;
setscbbyte:
procedure (offset,value);
declare offset byte;
declare value byte;
scbpd.offset = offset;
scbpd.set = 0ffh;
scbpd.value = double(value);
call mon1(49,.scbpd);
end setscbbyte;
get$console$mode: procedure address;
/* returns console mode */
return mon3(6dh,0ffffh);
end get$console$mode;
set$console$mode: procedure (new$value);
declare new$value address;
call mon1(6dh,new$value);
end set$console$mode;
rsx$call: procedure (rsxpb) address;
/* call Resident System Extension */
declare rsxpb address;
return mon3(60,rsxpb);
end rsx$call;
parse: procedure (pfcb) address external;
declare pfcb address;
end parse;
getf: procedure (input$type) external;
declare input$type address;
end getf;
/**************************************
* *
* S U B R O U T I N E S *
* *
**************************************/
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * Option scanner * * *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
separator: procedure(character) byte;
/* determines if character is a
delimiter and which one */
declare k byte,
character byte;
k = 1;
loop: if delimiters(k) = end$list then return(0);
if delimiters(k) = character then return(k); /* null = 25 */
k = k + 1;
go to loop;
end separator;
opt$scanner: procedure(list$ptr,off$ptr,idx$ptr);
/* scans the list pointed at by idxptr
for any strings that are in the
list pointed at by list$ptr.
Offptr points at an array that
contains the indices for the known
list. Idxptr points at the index
into the list. If the input string
is unrecognizable then the index is
0, otherwise > 0.
First, find the string in the known
list that starts with the same first
character. Compare up until the next
delimiter on the input. if every input
character matches then check for
uniqueness. Otherwise try to find
another known string that has its first
character match, and repeat. If none
can be found then return invalid.
To test for uniqueness, start at the
next string in the knwon list and try
to get another match with the input.
If there is a match then return invalid.
else move pointer past delimiter and
return.
P.Balma */
declare
buff based buf$ptr (1) byte,
idx$ptr address,
off$ptr address,
list$ptr address;
declare
i byte,
j byte,
list based list$ptr (1) byte,
offsets based off$ptr (1) byte,
wrd$pos byte,
character byte,
letter$in$word byte,
found$first byte,
start byte,
index based idx$ptr byte,
save$index byte,
(len$new,len$found) byte,
valid byte;
/*****************************************************************************/
/* internal subroutines */
/*****************************************************************************/
check$in$list: procedure;
/* find known string that has a match with
input on the first character. Set index
= invalid if none found. */
declare i byte;
i = start;
wrd$pos = offsets(i);
do while list(wrd$pos) <> end$list;
i = i + 1;
index = i;
if list(wrd$pos) = character then return;
wrd$pos = offsets(i);
end;
/* could not find character */
index = 0;
return;
end check$in$list;
setup: procedure;
character = buff(0);
call check$in$list;
letter$in$word = wrd$pos;
/* even though no match may have occurred, position
to next input character. */
i = 1;
character = buff(1);
end setup;
test$letter: procedure;
/* test each letter in input and known string */
letter$in$word = letter$in$word + 1;
/* too many chars input? 0 means
past end of known string */
if list(letter$in$word) = end$of$string then valid = false;
else
if list(letter$in$word) <> character then valid = false;
i = i + 1;
character = buff(i);
end test$letter;
skip: procedure;
/* scan past the offending string;
position buf$ptr to next string...
skip entire offending string;
ie., falseopt=mod, [note: comma or
space is considered to be group
delimiter] */
character = buff(i);
delimiter = separator(character);
/* No skip for GET */
do while ((delimiter < 1) or (delimiter > 9));
i = i + 1;
character = buff(i);
delimiter = separator(character);
end;
endbuf = i;
buf$ptr = buf$ptr + endbuf + 1;
return;
end skip;
eat$blanks: procedure;
declare charac based buf$ptr byte;
do while ((delimiter := separator(charac)) = SPACE);
buf$ptr = buf$ptr + 1;
end;
end eat$blanks;
/*****************************************************************************/
/* end of internals */
/*****************************************************************************/
/* start of procedure */
if delimiter = 9 then
return;
call eat$blanks;
start = 0;
call setup;
/* match each character with the option
for as many chars as input
Please note that due to the array
indices being relative to 0 and the
use of index both as a validity flag
and as a index into the option/mods
list, index is forced to be +1 as an
index into array and 0 as a flag*/
do while index <> 0;
start = index;
delimiter = separator(character);
/* check up to input delimiter */
valid = true; /* test$letter resets this */
do while delimiter = 0;
call test$letter;
if not valid then go to exit1;
delimiter = separator(character);
end;
go to good;
/* input ~= this known string;
get next known string that
matches */
exit1: call setup;
end;
/* fell through from above, did
not find a good match*/
endbuf = i; /* skip over string & return*/
call skip;
return;
/* is it a unique match in options
list? */
good: endbuf = i;
len$found = endbuf;
save$index = index;
valid = false;
next$opt:
start = index;
call setup;
if index = 0 then go to finished;
/* look at other options and check
uniqueness */
len$new = offsets(index + 1) - offsets(index) - 1;
if len$new = len$found then do;
valid = true;
do j = 1 to len$found;
call test$letter;
if not valid then go to next$opt;
end;
end;
else go to nextopt;
/* fell through...found another valid
match --> ambiguous reference */
index = 0;
call skip; /* skip input field to next delimiter*/
return;
finished: /* unambiguous reference */
index = save$index;
buf$ptr = buf$ptr + endbuf;
call eat$blanks;
if delimiter <> 0 then
buf$ptr = buf$ptr + 1;
else
delimiter = 5;
return;
end opt$scanner;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
crlf: proc;
call printchar(cr);
call printchar(lf);
end crlf;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* fill string @ s for c bytes with f */
fill: procedure(s,f,c);
declare s address;
declare (f,c) byte;
declare a based s byte;
do while (c:=c-1) <> 255;
a=f;
s=s+1;
end;
end fill;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* The error processor. This routine prints the command line
with a carot '^' under the offending delimiter, or sub-string.
The code passed to the routine determines the error message
to be printed beneath the command string. */
error: procedure (code);
declare (code,i,j,nlines,rem) byte;
declare (string$ptr,tstring$ptr) address;
declare chr1 based string$ptr byte;
declare chr2 based tstring$ptr byte;
declare carot$flag byte;
print$command: procedure (size);
declare size byte;
do j=1 to size; /* print command string */
call printchar(chr1);
string$ptr = string$ptr + 1;
end;
call crlf;
do j=1 to size; /* print carot if applicable */
if .chr2 = buf$ptr then do;
carot$flag = true;
call printchar('^');
end;
else
call printchar(' ');
tstring$ptr = tstring$ptr + 1;
end;
call crlf;
end print$command;
carot$flag = false;
string$ptr,tstring$ptr = begin$buffer;
con$width = getscbbyte(con$width$offset);
if con$width < 40 then con$width = 40;
nlines = buf$length / con$width; /* num lines to print */
rem = buf$length mod con$width; /* num extra chars to print */
if code <> 2 then do;
if ((code = 1) or (code = 4)) then /* adjust carot pointer */
buf$ptr = buf$ptr - 1; /* for delimiter errors */
else if code <> 5 then
buf$ptr = buf$ptr - endbuf - 1; /* all other errors */
end;
call crlf;
do i=1 to nlines;
tstring$ptr = string$ptr;
call print$command(con$width);
end;
call print$command(rem);
if carot$flag then
call print$buf(.('Error at the ''^'': $'));
else
call print$buf(.('Error at end of line: $'));
if con$width < 65 then
call crlf;
do case code;
call print$buf(.('Invalid option or modifier$'));
call print$buf(.('End of line expected$'));
call print$buf(.('Invalid file specification$'));
call print$buf(.('Invalid command$'));
call print$buf(.('Invalid delimiter$'));
call print$buf(.('File not found$'));
end;
call crlf;
call mon1(0,0);
end error;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ucase: procedure (char) byte;
declare char byte;
if char >= 'a' then
if char < '{' then
return (char-20h);
return char;
end ucase;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
getucase: procedure byte;
declare c byte;
c = ucase(conin);
return c;
end getucase;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
getpasswd: procedure;
declare (i,c) byte;
call crlf;
call crlf;
call print$buf(.('Enter Password: $'));
retry:
call fill(.fcb16,' ',8);
do i=0 to 7;
nxtchr:
if (c:=getucase) >= ' ' then
fcb16(i)=c;
if c = cr then
go to exit;
if c = ctrlx then
go to retry;
if c = bksp then do;
if i < 1 then
goto retry;
else do;
fcb16(i := i - 1) = ' ';
goto nxtchr;
end;
end;
if c = 3 then
call mon1(0,0);
end;
exit:
c = check$con$stat; /* clear raw i/o mode */
end getpasswd;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
print$fn: procedure (fcb$ad);
declare k byte;
declare fcb$ad address;
declare driv based fcb$ad byte;
declare fn based fcb$ad (12) byte;
call print$buf(.('file: $'));
if driv <> 0 then do;
call printchar('@'+driv);
call printchar(':');
end;
do k=1 to 11;
if k=9 then
call printchar('.');
if fn(k) <> ' ' then
call printchar(fn(k) and 07fh);
end;
end print$fn;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
try$open: procedure;
declare (error$code,a) address;
declare prog$flag based a byte;
declare code byte;
error$code = rsx$call(.get$fcb$pb);
if error$code <> 0ffh then do; /* 0ffh means no active get */
a = error$code - 2;
if prog$flag then /* program input only? */
error$code = rsx$call(.get$kill$pb); /* kill if so */
end;
call setdma(.fcb16); /* set dma to password */
call return$errors(0ffh);
error$code = open$file(.fcb);
call return$errors(0);
if low(error$code) = 0ffh then
if (code := high(error$code)) <> 0 then do;
if code = 7 then do;
call getpasswd;
call crlf;
call setdma(.fcb16);
end;
error$code=open$file(.fcb);
end;
else do;
buf$ptr = parse$fn.buff$adr; /* adjust pointer to file */
call error(5); /* file not found */
end;
call print$buf(.get$msg);
if getscbbyte(26) < 48 then
call crlf; /* console width */
call print$fn(.fcb);
call getf(.getpb);
end try$open;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
submit: procedure(adr) byte;
declare adr address;
declare fn based adr (12) byte;
declare (i,match) byte;
compare: procedure(j);
dcl j byte;
if (fn(j) and 07fh) = sub$fcb(j) then
return;
match = false;
end compare;
match = true;
do i = 1 to 3; /* sub = SYS $$$ */
call compare(i);
call compare(i+8);
end;
return match;
end submit;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
kill$rsx: procedure;
declare (fcb$adr,a) address;
if delimiter <> 9 then /* check for eoln */
call error(1);
/* remove SUBMIT & GET rsx modules */
do while (fcb$adr:=rsx$call(.get$fcb$pb)) <> 0ffh;
a = rsx$call(.get$kill$pb);
if submit(fcb$adr) then
call print$buf(.('SUBMIT of $'));
else
call print$buf(.('GET from $'));
call print$fn(fcb$adr);
call print$buf(.(' stopped$'));
call crlf;
end;
call print$buf(.get$msg);
call print$buf(.('console$'));
call mon1(0,0);
end kill$rsx;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
end$rsx: procedure;
declare (a,fcb$adr) address;
if delimiter <> 9 then /* check for eoln */
call error(1);
if (fcb$adr := rsx$call(.get$fcb$pb)) <> 0ffh then
if not submit(fcb$adr) then do;
a = rsx$call(.get$kill$pb);
call print$buf(.('GET from $'));
call print$fn(fcb$adr);
call print$buf(.(' stopped$'));
call crlf;
end;
/* determine where console input comes from now */
call print$buf(.get$msg);
fcb$adr = rsx$call(.get$fcb$pb);
if fcb$adr = 0ffh then
call print$buf(.('console$'));
else do;
if getscbbyte(26) < 48 then
call crlf; /* console width */
call print$fn(fcb$adr);
end;
call mon1(0,0);
end end$rsx;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
set$rsx$mode: procedure (bit$value);
declare bit$value byte;
declare temp address;
temp = get$console$mode;
temp = temp and 111111$00$11111111b; /* mask off bits to be set */
if bit$value <> 0 then
temp = temp or (255 + bit$value);
call set$console$mode(temp);
end set$rsx$mode;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
process$file: procedure(buf$adr);
declare negate byte;
declare status address;
declare buf$adr address;
declare char based status byte;
parse$fn.buff$adr = buf$adr;
parse$fn.fcb$adr = .fcb;
status = parse(.parse$fn);
if status = 0ffffh then
call error(2); /* bad file */
if status = 0 then /* eoln */
call try$open; /* try$open does not return */
else
buf$ptr = status + 1; /* position buf$ptr past '[' */
if char <> '[' then /* PROCESS OPTIONS */
call error(4);
do while ((delimiter<>2) and (delimiter<>9));
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 4 then do; /* STATUS */
if delimiter <> 3 then /* '=' */
call error(4);
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 5 then /* CONDITIONAL */
call set$rsx$mode(0);
else if index = 6 then /* FALSE */
call set$rsx$mode(1);
else if index = 7 then /* TRUE */
call set$rsx$mode(2);
else
call error(0); /* Not a valid option */
end;
else do; /* ECHO, FILTER, & SYSTEM options */
negate=false;
if index = 15 then do;
negate = true;
call opt$scanner(.options(0),.options$offset(0),.index);
end;
if index = 16 then do; /* ECHO */
if negate then
getpb.echo$flag = false;
else
getpb.echo$flag = true;
end;
else if index = 17 then do; /* FILTER */
if negate then
getpb.filtered$flag = false;
else
getpb.filtered$flag = true;
end;
else if index = 18 then do; /* SYSTEM */
if negate then
getpb.program$flag = true;
else
getpb.program$flag = false;
end;
else if index = 19 then do; /* PROGRAM */
if negate then
getpb.program$flag = false;
else
getpb.program$flag = true;
end;
else
call error(0);
end;
end;
call try$open; /* all set up, so do open */
end process$file;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
input$found: procedure (buffer$adr) byte;
declare buffer$adr address;
declare char based buffer$adr byte;
do while (char = ' ') or (char = 9); /* tabs & spaces */
buffer$adr = buffer$adr + 1;
end;
if char = 0 then /* eoln */
return false; /* input not found */
else
return true; /* input found */
end input$found;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/*********************************
* *
* M A I N P R O G R A M *
* *
*********************************/
plm:
do;
if (low(version) < cpmversion) or (high(version)=1) then do;
call print$buf(.('Requires CP/M 3.0$'));
call mon1(0,0);
end;
if not input$found(.tbuff(1)) then do; /* just GET */
call print$buf(.('CP/M 3 GET Version 3.0',cr,lf,'$'));
call print$buf(.('Get console input from a file',cr,lf,'$'));
call print$buf(.('Enter file: $'));
no$chars = read$console$buf(.tbuff(0),128);
call crlf;
tbuff(1) = ' '; /* blank out nc field */
tbuff(no$chars+2) = 0; /* mark eoln */
if not input$found(.tbuff(1)) then /* quit, no file name */
call mon1(0,0);
do i=1 to no$chars; /* make input capitals */
tbuff(i+1) = ucase(tbuff(i+1));
end;
begin$buffer = .tbuff(2);
buf$length = no$chars;
buf$ptr = .tbuff(2);
call process$file(.tbuff(2));
end;
else do; /* Get with input */
i = 1; /* skip over leading spaces */
do while (tbuff(i) = ' ');
i = i + 1;
end;
begin$buffer = .tbuff(1); /* note beginning of input */
buf$length = tbuff(0); /* note length of input */
buf$ptr = .tbuff(i); /* set up for scanner */
index = 0;
delimiter = 1;
call opt$scanner(.options(0),.options$offset(0),.index);
if (index=10) or (index=11) or (index=14) then do; /* AUX */
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 1 then /* INPUT */
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 2 then /* FROM */
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 3 then do; /* FILE */
getpb.input$type=aux$type;
call process$file(buf$ptr);
end;
else do;
if (index=10) or (index=11) or (index=14) then /* AUX */
call kill$rsx;
else
call error(3);
end;
end;
else do; /* not AUX */
if index = 12 then /* END */
call end$rsx;
if (index=8) or (index=9) or (index=13) then do; /* CONSOLE */
if delimiter = 9 then
call kill$rsx;
else
call opt$scanner(.options(0),.options$offset(0),.index);
end;
if index = 1 then /* INPUT */
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 2 then /* FROM */
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 3 then /* FILE */
call process$file(buf$ptr);
if (index=8) or (index=9) or (index=13) then /* CONIN:, CONSOLE */
call kill$rsx;
else
call error(3);
end;
end;
end;
end get;


339
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/GETDEF.PLM Normal file
View File

@@ -0,0 +1,339 @@
$title('GENCPM Token File parser')
get$sys$defaults:
do;
/*
Copyright (C) 1982
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
*/
/*
Revised:
20 Sept 82 by Bruce Skidmore
*/
declare true literally '0FFH';
declare false literally '0';
declare forever literally 'while true';
declare boolean literally 'byte';
declare cr literally '0dh';
declare lf literally '0ah';
declare tab literally '09h';
/*
D a t a S t r u c t u r e s
*/
declare data$fcb (36) byte external;
declare quest (156) boolean external;
declare display boolean external;
declare symbol (8) byte;
declare lnbfr (14) byte external;
declare buffer (128) byte at (.memory);
declare symtbl (20) structure(
token(8) byte,
len byte,
flags byte,
qptr byte,
ptr address) external;
mon1:
procedure (func,info) external;
declare func byte;
declare info address;
end mon1;
mon2:
procedure (func,info) byte external;
declare func byte;
declare info address;
end mon2;
/*
B D O S P r o c e d u r e & F u n c t i o n C a l l s
*/
system$reset:
procedure external;
end system$reset;
write$console:
procedure (char) external;
declare char byte;
end write$console;
print$console$buffer:
procedure (buffer$address) external;
declare buffer$address address;
end print$console$buffer;
open$file:
procedure (fcb$address) byte external;
declare fcb$address address;
declare fcb based fcb$address (1) byte;
end open$file;
close$file:
procedure (fcb$address) external;
declare fcb$address address;
end close$file;
set$DMA$address:
procedure (DMA$address) external;
declare DMA$address address;
end set$DMA$address;
crlf:
procedure external;
end crlf;
dsply$dec$adr:
procedure (val) external;
declare val address;
end dsply$dec$adr;
/*
M a i n G E T D E F P r o c e d u r e
*/
getdef:
procedure public;
declare buffer$index byte;
declare index byte;
declare end$of$file byte;
declare line$count address;
err:
procedure(term$code,msg$adr);
declare (term$code,save$display) byte;
declare msg$adr address;
save$display = display;
display = true;
call print$console$buffer(.('ERROR: $'));
call print$console$buffer(msg$adr);
call print$console$buffer(.(' at line $'));
call dsply$dec$adr(line$count);
if term$code then
call system$reset;
call crlf;
display = save$display;
end err;
inc$ptr:
procedure;
if buffer$index = 127 then
do;
buffer$index = 0;
if mon2(20,.data$fcb) <> 0 then
end$of$file = true;
end;
else
buffer$index = buffer$index + 1;
end inc$ptr;
get$char:
procedure byte;
declare char byte;
call inc$ptr;
char = buffer(buffer$index);
do while (char = ' ') or (char = tab) or (char = lf);
if char = lf then
line$count = line$count + 1;
call inc$ptr;
char = buffer(buffer$index);
end;
if (char >= 'a') and (char <= 'z') then
char = char and 0101$1111b; /* force upper case */
if char = 1ah then
end$of$file = true;
return char;
end get$char;
get$sym:
procedure;
declare (i,sym$char) byte;
declare got$sym boolean;
got$sym = false;
do while (not got$sym) and (not end$of$file);
do i = 0 to 7;
symbol(i) = ' ';
end;
sym$char = get$char;
i = 0;
do while (i < 8) and (sym$char <> '=') and
(sym$char <> cr) and (not end$of$file);
symbol(i) = sym$char;
sym$char = get$char;
i = i + 1;
end;
do while (sym$char <> '=') and (sym$char <> cr) and (not end$of$file);
sym$char = get$char;
end;
if not end$of$file then
do;
if (sym$char = '=') and (i > 0) then
got$sym = true;
else
do;
if (sym$char = '=') then
call err(false,.('Missing parameter variable$'));
else
if i <> 0 then
call err(false,.('Equals (=) delimiter missing$'));
do while (sym$char <> cr) and (not end$of$file);
sym$char = get$char;
end;
end;
end;
end;
end get$sym;
get$val:
procedure;
declare (flags,i,val$char) byte;
declare val$adr address;
declare val based val$adr byte;
declare (base,inc,lnbfr$index) byte;
val$char = get$char;
i = 0;
do while (i < lnbfr(0)) and (val$char <> cr) and (not end$of$file);
lnbfr(i+2) = val$char;
i = i + 1;
lnbfr(1) = i;
val$char = get$char;
end;
do while (val$char <> cr) and (not end$of$file);
val$char = get$char;
end;
inc = 0;
lnbfr$index = 2;
if i > 0 then
do;
val$adr = symtbl(index).ptr;
flags = symtbl(index).flags;
if (flags and 8) <> 0 then
do;
if (flags and 10h) <> 0 then
inc = symbol(7) - 'A';
else
if (symbol(7) >= '0') and (symbol(7) <= '9') then
inc = symbol(7) - '0';
else
inc = 10 + (symbol(7) - 'A');
val$adr = val$adr + (inc * symtbl(index).len);
end;
if lnbfr(lnbfr$index) = '?' then
do;
quest(inc+symtbl(index).qptr) = true;
display = true;
lnbfr$index = lnbfr$index + 1;
lnbfr(1) = lnbfr(1) - 1;
end;
if lnbfr(1) > 0 then
do;
if (flags and 1) <> 0 then
do;
if (lnbfr(lnbfr$index) >= 'A') and
(lnbfr(lnbfr$index) <= 'P') then
val = lnbfr(lnbfr$index) - 'A';
else
call err(false,.('Invalid drive ignored$'));
end;
else
if (flags and 2) <> 0 then
do;
val = (lnbfr(lnbfr$index) = 'Y');
end;
else
do;
base = 16;
val = 0;
do i = 0 to lnbfr(1) - 1;
val$char = lnbfr(i+lnbfr$index);
if val$char = ',' then
do;
val$adr = val$adr + 1;
val = 0;
base = 16;
end;
else
do;
if val$char = '#' then
base = 10;
else
do;
val$char = val$char - '0';
if (base = 16) and (val$char > 9) then
do;
if val$char > 16 then
val$char = val$char - 7;
else
val$char = 0ffh;
end;
if val$char < base then
val = val * base + val$char;
else
call err(false,.('Invalid character$'));
end;
end;
end;
end;
end;
end;
end get$val;
compare$sym:
procedure byte;
declare (i,j) byte;
declare found boolean;
found = false;
i = 0;
do while ((i < 22) and (not found));
j = 0;
do while ((j < 7) and (symtbl(i).token(j) = symbol(j)));
j = j + 1;
end;
if j = 7 then
found = true;
else
i = i + 1;
end;
if not found then
return 0ffh;
else
return i;
end compare$sym;
line$count = 1;
call set$dma$address(.buffer);
buffer$index = 127;
end$of$file = false;
do while (not end$of$file);
call get$sym;
if not end$of$file then
do;
index = compare$sym;
if index <> 0ffh then
call get$val;
else
call err(false,.('Invalid parameter variable$'));
end;
end;
end getdef;
end get$sys$defaults;


487
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/GETF.ASM Normal file
View File

@@ -0,0 +1,487 @@
$title('GETF - CP/M 3.0 Input Redirection - August 1982')
name getf
;******************************************************************
;
; get 'Input Redirection Initializer' version 3.0
;
; 11/30/82 - Doug Huskey
;******************************************************************
;
;
; Copyright (c) 1982
; Digital Research
; P.O. Box 579
; Pacific Grove, Ca.
; 93950
;
;
; generation procedure
;
; seteof get.plm
; seteof getscan.dcl
; seteof getf.asm
; seteof getscan.plm
; seteof parse.asm
; is14
; asm80 getf.asm debug
; asm80 mcd80a.asm debug
; asm80 parse.asm debug
; plm80 get.plm pagewidth(100) debug optimize
; link mcd80a.obj,get.obj,parse.obj,getf.obj,plm80.lib to get.mod
; locate get.mod code(0100H) stacksize(100)
; era get.mod
; cpm
; objcpm get
; rmac getrsx
; link getrsx[op]
; era get.rsx
; ren get.rsx=getrsx.prl
; gencom get.com
; gencom get.com get.rsx
;
;
;
; This module is called as an external routine by the
; PL/M routines GET and SUBMIT. It is passed a structure
; with the following format:
;
;
; declare getpb structure
; (input$type byte,
; echo$flag byte,
; filtered$flag byte,
; program$flag byte);
;
; input$type = 0 > console input (default)
; = 1 > auxiliary output
;
; echo = true > echo input to real device
; (default)
; = false > don't echo input (output is
; still echoed)
; filtered = true > convert control characters
; to a printable form
; preceeded by an ^ in echo
; (default)
; = false > no character conversions
; program = false > continue until EOF or
; GET INPUT FROM CONSOLE
; command
; = true > active only until program
; termination
;
public getf
extrn mon1,fcb,memsiz
;
;
true equ 0ffffh
false equ 00000h
;
biosfunctions equ true ;intercept BIOS conin & constat
;
;
; low memory locations
;
wboot equ 0000h
wboota equ wboot+1
;
; equates for non graphic characters
;
cr equ 0dh ; carriage return
lf equ 0ah ; line feed
;
; BDOS function equates
;
cinf equ 1 ;read character
coutf equ 2 ;output character
crawf equ 6 ;raw console I/O
creadf equ 10 ;read buffer
cstatf equ 11 ;status
pchrf equ 5 ;print character
pbuff equ 9 ;print buffer
openf equ 15 ;open file
closef equ 16 ;close file
delf equ 19 ;delete file
dreadf equ 20 ;disk read
dmaf equ 26 ;set dma function
curdrv equ 25
userf equ 32 ;set/get user number
scbf equ 49 ;set/get system control block word
rsxf equ 60 ;RSX function call
initf equ 128 ;GET initialization sub-function no.
killf equ 129 ;GET delete sub-function no.
jkillf equ 141 ;JOURNAL delete sub-function no.
;
; System Control Block definitions
;
scba equ 03ah ;offset of scbadr from SCB base
ccpflg2 equ 0b4h ;offset of 2nd ccp flag byte from pg bound
errflg equ 0aah ;offset of error flag from page boundary
conmode equ 0cfh ;offset of console mode from page boundary
listcp equ 0d4h ;offset of ^P flag from page boundary
common equ 0f9h ;offset of common memory base from pg. bound
wbootfx equ 068h ;offset of warm boot jmp from page. bound
constfx equ 06eh ;offset of constat jmp from page. bound
coninfx equ 074h ;offset of conin jmp from page. bound
conoufx equ 07ah ;offset of conout jmp from page. bound
listfx equ 080h ;offset of list jmp from page. bound
realdos equ 098h ;offset of real BDOS entry from pg. bound
;
; Restore mode equates (used with inr a, rz, rm, rpe, ret)
;
norestore equ 0ffh ;no BIOS interception
biosonly equ 07fh ;restore BIOS jump table only
stfix equ 080h ;restore BIOS jump table and
;restore JMP in RESBDOS for constat
everything equ 0 ;restore BIOS jump table and jmps in
;RESBDOS (default mode)
;
; Instructions
;
lxih equ 21h ;LXI H, instruction
jmpi equ 0c3h ;JMP instruction
shldi equ 22h ;SHLD instruction
;
;******************************************************************
; START OF INITIALIZATION CODE
;******************************************************************
cseg
getf:
;get parameters
mov h,b
mov l,c ;HL = .(parameter block)
mov a,m ;input type 0=con:,1=aux:
cpi 1 ;is it aux?
jz notimp ;error if so
inx h
mov a,m ;echo/noecho mode
sta echo
inx h
mov a,m ;cooked/raw mode
sta cooked
inx h
mov a,m
sta program
;
;check if enough memory
;
lhld memsiz
mov a,h
cpi 20h
jc nomem
;
;close to get those blocks in the directory
;
lxi d,fcb
mvi c,closef
call mon1
;
;check if drive specified
lxi h,fcb
mov a,m ;drive code
ora a ;default?
jnz movfcb
;
;set to current drive, if not
;
push h ;save .fcb
mvi c,curdrv
call mon1
pop h ;a=current drive, hl=.fcb
inr a
mov m,a ;set fcb to force drive select
;
movfcb: ;copy default fcb up into data area for move to RSX
;
lxi d,subfcb
lxi b,32 ;length of fcb
call ldir ;move it to subfcb
;
;initialize other variables to be moved to RSX
;
call getusr ;get current user number
sta subusr ;save for redirection file I/O
call getscbadr
shld scbadr ;System Control Block address
;
;get real BDOS address (bypass chain to check for user break)
;
mvi l,realdos
mov e,m
inx h
mov d,m
xchg
shld realbdos+1
;
;check for user abort
;
xchg
mvi l,conmode
mov a,m
ori 1 ;set ^C status mode
mov m,a
mvi c,cstatf
call realbdos ;check for user abort
ora a
jnz error1 ;abort if so
;
;get address of initialization table in RSX
;
mvi c,rsxf
lxi d,journkill
call mon1 ;terminate any PUT INPUT commands
mvi c,rsxf
lxi d,rsxinit
call mon1 ;call GET.RSX initialization routine
push h ;save for move at end of setup
mov e,m
inx h
mov d,m ;DE = .RSXKILL flag
push d ;set flag to zero if successfull
inx h ;HL = .(real bios status routine)
push h
;
if biosfunctions
;
;check if BIOS jump table looks valid (jmp in right places)
lhld wboota
lxi d,3
dad d ;HL = .(jmp constat address)
mov a,m
cpi jmpi ;should be a jump
jnz bioserr ;skip bios redirection if not
dad d ;HL = .(jmp conin address)
mov a,m
cpi jmpi
jnz bioserr ;skip bios redirection if not
;
;fix up RESBDOS to do BIOS calls to intercepted functions
;
lhld scbadr
mvi l,common+1
mov a,m ;get high byte of common base
ora a
jnz fix0 ;high byte = zero if non-banked
mvi a,biosonly
sta biosmode
jmp trap ;skip code that fixes resbdos
;fix BIOS constat
fix0: mvi l,constfx ;hl = .constfx in SCB
mov a,m
cpi jmpi ;is it a jump instruction?
jz fix1 ;jump if so
mvi a,biosonly ;whoops already changed
sta biosmode ;restore jump table only
fix1: mvi m,lxih
;fix BIOS conin
mvi l,coninfx ;hl = .coninfx in SCB
mov a,m
cpi jmpi ;is it a jump instruction?
lda biosmode
jz fix2 ;jump if so
cpi biosonly
jnz bioserr ;error if conin is LXI but not constat
xra a ;zero accumulator to jnz below
fix2: cpi biosonly ;was const already an LXI h?
jnz fix3 ;jmp if not
mvi a,stfix ;restore constat jmp but not conin
sta biosmode
fix3: mvi m,lxih
;get addresses of RSX const and conin traps
trap: pop h
mov c,m ;HL = .(.bios constat trap)
inx h
mov b,m ;BC = .bios constat trap in RSX
inx h
push h ;save for CONIN setup
;
;patch RSX constat entry into BIOS jump table
;save real constat address in RSX exit table
;
lhld wboota
lxi d,4
dad d ;HL = .(jmp constat address)
shld constjmp ;save for RSX restore at end
mov e,m
mov m,c
inx h
mov d,m ;DE = constat address
mov m,b ;BIOS constat jumps to RSX
xchg
shld biosta ;save real constat address
;
;get address of RSX bios conin entry point
;
pop h ;HL = .(RSX BIOS conin trap)
mov c,m
inx h
mov b,m
;
;patch RSX conin entry into BIOS jump table
;save real conin address in RSX exit table
;
xchg
inx h ;past jmp instruction
inx h ;HL = .(conin address)
shld coninjmp
mov e,m
mov m,c
inx h
mov d,m ;DE = conin address
mov m,b ;BIOS conin jumps to RSX
xchg
shld biosin ;save real conin address
endif
;
;move data area to RSX
;
rsxmov:
pop h ;HL = .Kill flag in RSX
inr m ;switch from FF to 0
lxi h,movstart
pop d ;RSX data area address
lxi b,movend-movstart
call ldir
mvi c,crawf
mvi e,0fdh ;raw console input
call mon1 ;prime RSX by reading a char
jmp wboot
if biosfunctions
;
; can't do BIOS redirection
;
bioserr:
lxi d,nobios
mvi c,pbuff
call mon1
lxi h,biosmode
mvi m,norestore ;no bios redirection
pop h ;throw away bios constat trap adr
jmp rsxmov
endif
;
; auxiliary redirection
;
notimp:
lxi d,notdone
error:
mvi c,pbuff
call mon1
error1: mvi c,closef
lxi d,fcb
call mon1
mvi c,delf
lxi d,fcb
call mon1
jmp wboot
;
; insufficient memory
;
nomem: lxi d,memerr
jmp error
;
; get/set user number
;
getusr: mvi a,0ffh ;get current user number
setusr: mov e,a ;set current user number (in A)
mvi c,userf
jmp mon1
;
; get system control block address
; (BDOS function #49)
;
; exit: hl = system control block address
;
getscbadr:
mvi c,scbf
lxi d,data49
jmp mon1
;
data49: db scba,0 ;data structure for getscbadd
;
; copy memory bytes (emulates z80 ldir instruction)
;
ldir: mov a,m ;get byte
stax d ;store it at destination
inx h ;advance pointers
inx d
dcx b ;decrement byte count
mov a,c ;loop if non-zero
ora b
jnz ldir
ret
;
;******************************************************************
; DATA AREA
;******************************************************************
;
journkill: db jkillf
rsxinit: db initf
nobios: db 'WARNING: Cannot redirect from BIOS',cr,lf,'$'
notdone:
db 'ERROR: Auxiliary device redirection not implemented',cr,lf,'$'
memerr:
db 'ERROR: Insufficient Memory',cr,lf,'$'
;
;******************************************************************
; Following variables are initialized by GET.COM
; and moved to the GET RSX - Their order must not be changed
;******************************************************************
;
;
;
movstart:
inittable: ;addresses used by GET.COM for
scbadr: dw 0 ;address of System Control Block
;
if biosfunctions ;GET.RSX initialization
;
biosta: dw 0 ;set to real BIOS routine
biosin: dw 0 ;set to real BIOS routine
;
;restore only if changed when removed.
biosmode:
db 0 ;if non-zero change LXI @jmpadr to JMP
;when removed.
restorebios:
;hl = real constat routine
;de = real conin routine
db shldi
constjmp:
dw 0 ;address of const jmp initialized by COM
xchg
db shldi
coninjmp:
dw 0 ;address of conin jmp initialized by COM
ret
endif
;
realbdos:
jmp 0 ;address filled in by COM
;
echo: db 1
cooked: db 0
;
program:
db 0 ;true if only program input
subusr: db 0 ;user number for redirection file
subfcb: db 1 ;a:
db 'SYSIN '
db 'SUB'
db 0,0
submod: db 0
subrc: db 0
ds 16 ;map
subcr: db 0
;
movend:
;*******************************************************************
end
EOF


870
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/GETRSX.ASM Normal file
View File

@@ -0,0 +1,870 @@
title 'GET.RSX 3.0 - CP/M 3.0 Input Redirection - August 1982'
;******************************************************************
;
; get 'Input Redirection Facility' version 3.0
;
; 11/30/82 - Doug Huskey
; This RSX redirects console input and status from a file.
;******************************************************************
;
;
true equ 0ffffh
false equ 00000h
;
submit equ false ;true if submit RSX
remove$rsx equ false ;true if RSX removes itself
; ;false if LOADER does removes
;
;
; generation procedure
;
; rmac getrsx
; xref getrsx
; link getrsx[op]
; ERA get.RSX
; REN get.RSX=getRSX.PRL
; GENCOM $1.COM get.RSX ($1 is either SUBMIT or GET)
;
;
; initialization procedure
;
; GETF makes a RSX function 60 call with a sub-function of
; 128. GETRSX returns the address of a data table containing:
;
; init$table:
; dw kill ;RSX remove flag addr in GET
; dw bios$constat ;bios entry point in GET
; dw bios$conin ;bios entry point in GET
;
; GETF initializes the data are between movstart: and movend:
; and moves it into GET.RSX. This means that data should not
; be reordered without also changing GETF.ASM.
;
bios$functions equ true ;intercept BIOS console functions
;
; low memory locations
;
wboot equ 0000h
bdos equ 0005h
bdosl equ bdos+1
buf equ 0080h
;
; equates for non graphic characters
;
ctlc equ 03h ; control c
ctle equ 05h ; physical eol
ctlh equ 08h ; backspace
ctlp equ 10h ; prnt toggle
ctlr equ 12h ; repeat line
ctls equ 13h ; stop/start screen
ctlu equ 15h ; line delete
ctlx equ 18h ; =ctl-u
if submit
ctlz equ 0ffh
else
ctlz equ 1ah ; end of file
endif
rubout equ 7fh ; char delete
tab equ 09h ; tab char
cr equ 0dh ; carriage return
lf equ 0ah ; line feed
ctl equ 5eh ; up arrow
;
; BDOS function equates
;
cinf equ 1 ;read character
coutf equ 2 ;output character
crawf equ 6 ;raw console I/O
creadf equ 10 ;read buffer
cstatf equ 11 ;status
pchrf equ 5 ;print character
pbuff equ 9 ;print buffer
openf equ 15 ;open file
closef equ 16 ;close file
delf equ 19 ;delete file
dreadf equ 20 ;disk read
dmaf equ 26 ;set dma function
userf equ 32 ;set/get user number
scbf equ 49 ;set/get system control block word
loadf equ 59 ;loader function call
rsxf equ 60 ;RSX function call
ginitf equ 128 ;GET initialization sub-function no.
gkillf equ 129 ;GET delete sub-function no.
gfcbf equ 130 ;GET file display sub-function no.
pinitf equ 132 ;PUT initialization sub-funct no.
pckillf equ 133 ;PUT CON: delete sub-function no.
pcfcbf equ 134 ;return PUT CON: fcb address
plkillf equ 137 ;PUT LST: delete sub-function no.
plfcbf equ 138 ;return PUT LST:fcb address
gsigf equ 140 ;signal GET without [SYSTEM] option
jinitf equ 141 ;JOURNAL initialization sub-funct no.
jkillf equ 142 ;JOURNAL delete sub-function no.
jfcbf equ 143 ;return JOURNAL fcb address
;
; System Control Block definitions
;
scba equ 03ah ;offset of scbadr from SCB base
ccpflg equ 0b3h ;offset of ccpflags word from page boundary
ccpres equ 020h ;ccp resident flag = bit 5
bdosoff equ 0feh ;offset of BDOS address from page boundary
errflg equ 0ach ;offset of error flag from page boundary
pg$mode equ 0c8h ;offset of page mode byte from pag. bound.
pg$def equ 0c9h ;offset of page mode default from pag. bound.
conmode equ 0cfh ;offset of console mode word from pag. bound.
listcp equ 0d4h ;offset of ^P flag from page boundary
dmaad equ 0d8h ;offset of DMA address from pg bnd.
usrcode equ 0e0h ;offset of user number from pg bnd.
dcnt equ 0e1h ;offset of dcnt, searcha & searchl from pg bnd.
constfx equ 06eh ;offset of constat JMP from page boundary
coninfx equ 074h ;offset of conin JMP from page boundary
;******************************************************************
; RSX HEADER
;******************************************************************
serial: db 0,0,0,0,0,0
trapjmp:
jmp trap ;trap read buff and DMA functions
next: jmp 0 ;go to BDOS
prev: dw bdos
kill: db 0FFh ;0FFh => remove RSX at wstart
nbank: db 0
rname: db 'GET ' ;RSX name
space: dw 0
patch: db 0
;******************************************************************
; START OF CODE
;******************************************************************
;
; ABORT ROUTINE
;
getout:
;
if bios$functions
;
;restore bios jumps
lda restore$mode ;may be FF, 7f, 80 or 0
inr a
rz ; FF = no bios interception
lhld biosin
xchg
lhld biosta
call restore$bios ;restore BIOS constat & conin jmps
rm ; 7f = RESBDOS jmps not changed
lhld scbadr
mvi l,constfx
mvi m,jmp
rpe ; 80 = conin jmp not changed
mvi l,coninfx
mvi m,jmp
endif
ret ; 0 = everything done
;
; ARRIVE HERE ON EACH BIOS CONIN OR CONSTAT CALL
;
;
bios$constat:
;
if bios$functions
;
;enter here from BIOS constat
lxi b,4*256+cstatf ;b=offset in exit table
jmp bios$trap
endif
;
bios$conin:
;
if bios$functions
;
;enter here from BIOS conin
lxi b,6*256+crawf ;b=offset in exit table
mvi e,0fdh
jmp biostrap
endif
;
; ARRIVE HERE AT EACH BDOS CALL
;
trap:
;
;
lxi h,excess
mvi b,0
mov m,b
biostrap:
;enter here on BIOS calls
pop h ;return address
push h ;back to stack
lda trapjmp+2 ;GET.RSX page address
cmp h ;high byte of return address
jc exit ;skip calls on bdos above here
mov a,c ;function number
;
;
cpi cstatf ;status
jz intercept
cpi crawf
jz intercept ;raw I/O
lxi h,statflg ;zero conditional status flag
mvi m,0
cpi cinf
jz intercept ;read character
cpi creadf
jz intercept ;read buffer
cpi rsxf
jz rsxfunc ;rsx function
cpi dmaf
jnz exit ;skip if not setting DMA
xchg
shld udma ;save user's DMA address
xchg
;
exit:
;go to real BDOS
if not bios$functions
;
jmp next ;go to next RSX or BDOS
else
mov a,b ;get type of call:
lxi h,exit$table ;0=BDOS call, 4=BIOS CONIN, 6=BIOS CONSTAT
call addhla
mov b,m ;low byte to b
inx h
mov h,m ;high byte to h
mov l,b ;HL = .exit routine
pchl ;gone to BDOS or BIOS
endif
;
;
rsxfunc: ;check for initialize or delete RSX functions
ldax d ;get RSX sub-function number
lxi h,init$table ;address of area initialized by COM file
cpi ginitf
rz
lda kill
ora a
jnz exit
ldax d
cpi gfcbf
lxi h,subfcb
rz
cksig:
cpi gsigf
jnz ckkill
lxi h,get$active
mvi a,gkillf
sub m ;toggle get$active flag
mov m,a ;gkillf->0 0->gkillf
ckkill:
cpi gkillf ;remove this instance of GET?
jnz exit ;jump if not
restor:
lda get$active
ora a
rz
call getout ;bios jump fixup
if submit
mvi c,closef
call subdos
mvi c,delf
call subdos ;delete SYSIN??.$$$ if not
endif
lxi h,kill
dcr m ;set to 0ffh, so we are removed
xchg ; D = base of this RSX
lhld scbadr
mvi l,ccpflg+1 ;hl = .ccp flag 2 in SCB
mov a,m
ani 0bfh
mov m,a ;turn off redirection flag
;we must remove this RSX if it is the lowest one
lda bdosl+1 ;location 6 high byte
cmp d ;Does location 6 point to us
RNZ ;return if not
if remove$rsx
xchg ;D = scb page
lhld next+1
shld bdosl
xchg ;H = scb page
mvi l,bdosoff ;HL = "BDOS" address in SCB
mov m,e ;put next address into SCB
inx h
mov m,d
xchg
mvi l,0ch ;HL = .previous RSX field in next RSX
mvi m,7
inx h
mvi m,0 ;put previous into previous
ret
else
; CP/M 3 loader does RSX removal if DE=0
mvi c,loadf
lxi d,0
jmp next ;ask loader to remove me
endif
;
;
; INTERCEPT EACH BDOS CONSOLE INPUT FUNCTION CALL HERE
;
; enter with funct in A, info in DE
;
intercept:
;
lda kill
ora a
jnz exit ;skip if remove flag turned on
;
;switch stacks
lxi h,0
dad sp
shld old$stack
lxi sp,stack
push b ;save function #
push d ;save info
;check redirection mode
call getmode ;returns with H=SCB page
cpi 2
jz skip ;skip if no redirection flag on
if submit
;
; SUBMIT PROCESSOR
;
;check if CCP is calling
ckccp: mvi l,pg$mode
mov m,H ;set to non-zero for no paging
mvi l,ccpflg+1 ;CCP FLAG 2 in SCB
mov a,m ;ccp flag byte 2 to A
ori 040h
mov m,a ;set redirection flag on
ani ccpres ;zero flag set if not CCP calling
lda ccp$line
jz not$ccp
;yes, CCP is calling
ora a
jnz redirect ;we have a CCP line
;CCP & not a CCP line
push h
call coninf ;throw away until next CCP line
lxi h,excess
mov a,m
ora a ;is this the first time?
mvi m,true
lxi d,garbage
mvi c,pbuff
cz next ;print the warning if so
pop h
lda kill
ora a
jz ckccp ;get next character (unless eof)
mov a,m
ani 7fh ;turn off disk reset (CCP) flag
mov m,a
jmp wboot ;skip if remove flag turned on
;
not$ccp:
;no, its not the CCP
ora a
jnz skip ;skip if no program line
else
lda program
ora a ;program input only?
mvi l,ccpflg+1 ;CCP FLAG 2 in SCB
mov a,m ;ccp flag byte 2 to A
jz set$no$page ;jump if [system] option
;check if CCP is calling
ani ccpres ;zero flag set if not CCP calling
jz redirect ;jump if not the CCP
lxi h,ccpcnt ;decrement once for each
dcr m ;time CCP active
cm restor ;if 2nd CCP appearance
lxi d,cksig+1
mvi c,rsxf ;terminate any GETs waiting for
call next ;us to finish
jmp skip
;
set$no$page:
ori 40h ;A=ccpflag2, HL=.ccpflag2
mov m,a ;set redirection flag on
mvi l,pg$mode
mov m,h ;set to non-zero for no paging
endif
;
; REDIRECTION PROCESSOR
;
redirect:
;break if control-C typed on console
call break
pop d
pop b ;recover function no. & info
push b ;save function
push d ;save info
mov a,c ;function no. to A
lxi h,retmon ;program return routine
push h ;push on stack
;
;
cpi creadf
jz func10 ;read buffer (returns to retmon)
cpi cinf
jz func1 ;read character (returns to retmon)
cpi cstatf
jz func11 ;status (returns to retmon)
;
func6:
;direct console i/o - read if 0ffh
;returns to retmon
mov a,e
inr a
jz dirinp ;0ffh in E for status/input
inr a
jz CONBRK ;0feh in E for status
lxi h,statflg
mvi m,0
inr a
jz coninf ;0fdh in E for input
;
;direct output function
;
jmp skip1
;
break: ;
;quit if ^C typed
mvi c,cstatf
call real$bdos
ora a ;was ^C typed?
rz
pop h ;throw away return address
call restor ;remove this RSX, if so
mvi c,crawf
mvi e,0ffh
call next ;eat ^C if not nested
;
skip: ;
;reset ^C status mode
call getmode ;returns .conmode+1
dcx h ;hl = .conmode in SCB
mov a,m
ani 0feh ;turn off control C status
mov m,a
;restore the BDOS call
pop d ;restore BDOS function no.
pop b ;restore BDOS parameter
;restore the user's stack
skip1: lhld old$stack
sphl
jmp exit ;goto BDOS
;
retmon:
;normal entry point, char in A
cpi ctlz
jz skip
lhld old$stack
sphl
mov l,a
ret ;to calling program
;******************************************************************
; BIOS FUNCTIONS (REDIRECTION ROUTINES)
;******************************************************************
;
; ;direct console input
dirinp:
call conbrk
ora a
rz
;
;
; get next character from file
;
;
coninf:
getc: ;return ^Z if end of file
xra a
lxi h,cbufp ;cbuf index
inr m ;next chr position
cm readf ;read a new record
ora a
mvi b,ctlz ;EOF indicator
jnz getc1 ;jump if end of file
lda cbufp
lxi h,cbuf
call addhla ;HL = .char
;one character look ahead
;new char in B, current char in nextchr
mov b,m ;new character in B
getc1: mov a,b
cpi ctlz
push b
cz restor
pop b
lxi h,nextchr
mov a,m ;current character
cpi cr
mov m,b ;save next character
rnz
mov a,b ;A=character after CR
cpi lf ;is it a line feed
cz getc ;eat line feeds after a CR
;this must return from above
;rnz because nextchr = lf
;
if submit
;
mov a,b ;get nextchr
sui '<' ;program line?
sta ccp$line ;zero if so
cz getc ;eat '<' char
;this must return from above
;rnz because nextchr = <
endif
mvi a,cr ;get back the cr
ret ;with character in a
;
; set DMA address in DE
;
setdma: mvi c,dmaf
jmp next
;
; read next record
;
readf: mvi c,dreadf ;read next record of input to cbuf
subdos: push b
lxi d,cbuf
call setdma ;set DMA to our buffer
lhld scbadr
lxi d,sav$area ;10 byte save area
pop b ;C = function no.
push h ;save for restore
push d ;save for restore
call mov7 ;save hash info in save area
mvi l,usrcode ;HL = .dcnt in SCB
call mov7 ;save dcnt, searcha & l, user# &
dcx h ;multi-sector I/O count
mvi m,1 ;set multi-sector count = 1
lxi d,subusr ;DE = .submit user #
mvi l,usrcode ;HL = .BDOS user number
ldax d
mov m,a
inx d
call next ;read next record
pop h ;HL = .sav$area
pop d ;DE = .scb
push psw ;save A (non-zero if error)
call mov7 ;restore hash info
mvi e,usrcode ;DE = .dcnt in scb
call mov7 ;restore dcnt search addr & len
lhld udma
xchg
call setdma ;restore DMA to program's buffer
xra a
sta cbufp ;reset buffer position to 0
pop psw
ora a
ret ;zero flag set, if successful
;
; reboot from ^C
;
rebootx:
;store 0fffeh in clp$errcode in SCB
lhld scbadr
mvi l,errflg
mvi m,0feh
inx h
mvi m,0ffh
jmp wboot
;
;
; get input redirection mode to A
; turn on ^C status mode for break
; return .conmode+1 in HL
; preserve registers BC and DE
;
getmode:
lhld scbadr
mvi l,conmode
mov a,m
ori 1 ;turn on ^C status
mov m,a
inx h
mov a,m
ani 3 ;mask off redirection bits
dcr a ;255=false, 0=conditional, 1=true,
ret ; 2=don't redirect input
;
; move routine
;
mov7: mvi b,7
; HL = source
; DE = destination
; B = count
move: mov a,m
stax d
inx h
inx d
dcr b
jnz move
ret
;
; add a to hl
;
addhla: add l
mov l,a
rnc
inr h
ret
;
;******************************************************************
; BDOS CONSOLE INPUT ROUTINES
;******************************************************************
;
; February 3, 1981
;
;
; console handlers
conin: equ coninf
;
conech:
;read character with echo
call conin! call echoc! rc ;echo character?
;character must be echoed before return
push psw! call conout! pop psw
ret ;with character in A
;
echoc:
;are we in cooked or raw mode?
lxi h,cooked! dcr m! inr m! rz ;return if raw
;echo character if graphic
;cr, lf, tab, or backspace
cpi cr! rz ;carriage return?
cpi lf! rz ;line feed?
cpi tab! rz ;tab?
cpi ctlh! rz ;backspace?
cpi ' '! ret ;carry set if not graphic
;
conbrk: ;STATUS - check for character ready
lxi h,statflg
mov b,m! mvi m,0ffh ;set conditional status flag true
call getmode ;check input redirection status mode
cpi 1! rz ;actual status mode => return true
ora a! rz ;false status mode => return false
;conditional status mode => false unless prev func was status
mov a,b! ret ; return false if statflg false
; return true if statflg true
;
;
ctlout:
;send character in A with possible preceding up-arrow
call echoc ;cy if not graphic (or special case)
jnc conout ;skip if graphic, tab, cr, lf, or ctlh
;send preceding up arrow
push psw! mvi a,ctl! call conout ;up arrow
pop psw! ori 40h ;becomes graphic letter
;(drop through to conout)
;
;
; send character in A to console
;
conout:
mov e,a
lda echo
ora a
rz
mvi c,coutf
jmp next
;
;
read: ;read to buffer address (max length, current length, buffer)
xchg ;buffer address to HL
mov c,m! inx h! push h! mvi b,0 ;save .(current length)
;B = current buffer length,
;C = maximum buffer length,
;HL= next to fill - 1
readnx:
;read next character, BC, HL active
push b! push h ;blen, cmax, HL saved
readn0:
call conin ;next char in A
pop h! pop b ;reactivate counters
cpi ctlz! jnz noteof ;end of file?
dcr b! inr b! jz readen ;skip if buffer empty
mvi a,cr ;otherwise return
noteof:
cpi cr! jz readen ;end of line?
cpi lf! jz readen ;also end of line
cpi ctlp! jnz notp ;skip if not ctlp
;list toggle - change parity
push h! push b ;save counters
lhld scbadr! mvi l,listcp ;hl =.listcp
mvi a,1! sub m ;True-listcp
mov m,a ;listcp = not listcp
pop b! pop h! jmp readnx ;for another char
notp:
;not a ctlp
;place into buffer
rdecho:
inx h! mov m,a ;character filled to mem
inr b ;blen = blen + 1
rdech1:
;look for a random control character
push b! push h ;active values saved
call ctlout ;may be up-arrow C
pop h! pop b! mov a,m ;recall char
cpi ctlc ;set flags for reboot test
mov a,b ;move length to A
jnz notc ;skip if not a control c
cpi 1 ;control C, must be length 1
jz rebootx ;reboot if blen = 1
;length not one, so skip reboot
notc:
;not reboot, are we at end of buffer?
cmp c! jc readnx ;go for another if not
readen:
;end of read operation, store blen
pop h! mov m,b ;M(current len) = B
push psw ;may be a ctl-z
mvi a,cr! call conout ;return carriage
pop psw ;restore character
ret
;
func1: equ conech
;return console character with echo
;
;func6: see intercept routine at front of module
;
func10: equ read
;read a buffered console line
;
func11: equ conbrk
;check console status
;
;
;******************************************************************
; DATA AREA
;******************************************************************
statflg: db 0 ;non-zero if prev funct was status
;
;
;******************************************************************
; Following variables and entry points are used by GET.COM
; Their order and contents must not be changed without also
; changing GET.COM.
;******************************************************************
;
if bios$functions
;
exit$table: ;addresses to go to on exit
dw next ;BDOS
endif
;
movstart:
init$table: ;addresses used by GET.COM for
scbadr: dw kill ;address of System Control Block
;
if bios$functions ;GET.RSX initialization
;
biosta dw bios$constat ;set to real BIOS routine
biosin dw bios$conin ;set to real BIOS routine
;
;restore only if changed when removed.
restore$mode
db 0 ;if non-zero change LXI @jmpadr to JMP
;when removed.
restore$bios:
;hl = real constat routine
;de = real conin routine
shld 0 ;address of const jmp initialized by COM
xchg
shld 0 ;address of conin jmp initialized by COM
ret
endif
;
real$bdos:
jmp bdos ;address filled in by COM
;
;
echo: db 1
cooked: db 0
;
program:
db 0 ;true if program input only
subusr: db 0 ;user number for redirection file
subfcb: db 1 ;a:
db 'SYSIN '
db 'SUB'
db 0,0
submod: db 0
subrc: ds 1
ds 16 ;map
subcr: ds 1
;
movend:
;*******************************************************************
cbufp db 128 ;current character position in cbuf
nextchr db cr ;next character (1 char lookahead)
if submit
ccp$line:
db false ;nonzero if line is for CCP
endif
cbuf: ;128 byte record buffer
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
udma: dw buf ;user dma address
get$active:
db gkillf
;
sav$area: ;14 byte save area (searchn)
db 68h,68h,68h,68h,68h, 68h,68h,68h,68h,68h
db 68h,68h,68h,68h
excess: db 0
old$stack:
dw 0
if submit
garbage:
; db cr,lf
db 'WARNING: PROGRAM INPUT IGNORED',cr,lf,'$'
else
ccpcnt: db 1
endif
patch$area:
ds 30h
db ' 151282 '
db ' COPYR ''82 DRI '
db 67h,67h,67h,67h,67h, 67h,67h,67h,67h,67h
db 67h,67h,67h,67h,67h, 67h,67h,67h,67h,67h
db 67h,67h,67h,67h,67h, 67h,67h,67h,67h,67h
;
stack: ;15 level stack
end


1090
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/HELP.PLM Normal file
View File

File diff suppressed because it is too large Load Diff

663
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/HEXCOM.ASM Normal file
View File

@@ -0,0 +1,663 @@
title 'CP/M 3 - HEXCOM - Oct 1982'
;
; Copyright (C) 1982
; Digital Research
; P.O. Box 579
; Pacific Grove, CA 93950
; Revised:
; 22 Oct 82 by Paul Lancaster
; 25 Oct 82 by Doug Huskey
;
;
; ********** HEXCOM **********
;
;PROGRAM TO CREATE A CP/M "COM" FILE FROM A "HEX" FILE.
;THIS PROGRAM IS VERY SIMILAR IN FUNCTION TO THE CP/M
;UTILITY CALLED "LOAD". IT IS OPTIMIZED WITH RESPECT TO
;EXECUTION SPEED AND MEMORY SPACE. IT RUNS ABOUT TWICE
;AS FAST AS THE CP/M COUNTERPART ON A LONG "HEX" FILE.
;IT IS ALSO ABOUT 700 BYTES SHORTER.
;ONE MINOR DIFFERENCE BETWEEN "HEXCOM" AND "LOAD" THAT MAY
;BE VISIBLE TO THE USER IS THAT VERY LARGE LOAD ADDRESS
;INVERSIONS ARE TOLERATED BY "HEXCOM", WHEREAS THE MAXIMUM
;ALLOWED INVERSION IN "LOAD" IS 80H. THE MAXIMUM IN "HEXCOM"
;IS A FUNCTION OF THE TPA SIZE.
;CAUTION SHOULD BE EXERCIZED WHEN USING AN INVERSION GREATER
;THAN 80H IN "HEXCOM" SINCE PART OF THE COMFILE MAY NOT
;GET CREATED IF THE FINAL LOAD ADDRESS IS INVERTED WITH
;RESPECT TO THE "LAST ADDRESS" IN THE "HEX" FILE.
;*******************************************************
;VERSION 1.00 6 MARCH 1979
;ORIGINAL VERSION.
;*******************************************************
;22 October 1982 - Changed assumed CCP length for CP/M-PLUS
;25 October 1982 - Changed version to 3.0
;
;
EQUATES
VERS EQU 300 ;VERSION TIMES 100
CR EQU 0DH
LF EQU 0AH
BDOS EQU 5
DEFAULT$FCB EQU 5CH
ORG 100H
; include file for use with ASM programs
;
;*********************************************
;* STANDARD DIGITAL RESEARCH COM FILE HEADER *
;*********************************************
;
JMP BEGIN ;LABEL CAN BE CHANGED
;
;*********************************************
;* Patch Area, Date, Version & Serial Number *
;*********************************************
;
dw 0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
db 0
db 'CP/M Version 3.0'
db 'COPYRIGHT 1982, '
db 'DIGITAL RESEARCH'
db '251082' ; version date day-month-year
db 0,0,0,0 ; patch bit map
db '654321' ; Serial no.
;
BEGIN:
; code starts here
LXI H,0
DAD SP ;GET CURRENT CCP STACK
SHLD STACK$SAVE ;SAVE IT
LXI SP,STACK ;INIT LOCAL STACK
LXI D,SIGNON$MSG ;POINT SIGN-ON MESSAGE
CALL PRINT$BUFFER ;SEND IT TO CONSOLE
LXI D,DEFAULT$FCB ;FILE NAME TO HEX FCB
LXI H,HEX$FCB
PUSH D ;SAVE COM FCB ADDR
PUSH H ;-AND HEX FCB ADDR
MVI C,33 ;MOVE ENTIRE FCB
MOVEFCB LDAX D ;GET BYTE FROM DFLT FCB
MOV M,A ;MOVE TO HEX FCB
INX D ;BUMP POINTERS
INX H
DCR C ;HIT COUNTER
JNZ MOVEFCB ;LOOP TILL DONE
LXI H,HEX$FCB+9 ;"HEX" TYPE NAME TO FCB
MVI M,'H'
INX H
MVI M,'E'
INX H
MVI M,'X'
LXI H,DEFAULT$FCB+9 ;"COM" TYPE NAME TO FCB
MVI M,'C'
INX H
MVI M,'O'
INX H
MVI M,'M'
POP D ;HEX$FCB TO <DE>
MVI C,15 ;OPEN FILE
CALL BDOS
INR A ;SEE IF -1 FOR ERROR
LXI D,COSMSG
JZ ERROR$ABORT ;CANNOT OPEN SOURCE
POP D ;COM FCB ADDR
PUSH D ;KEEP COPY ON STACK
MVI C,19 ;DELETE FILE
CALL BDOS ;DELETE OLD "COM" FILE
POP D ;GET COM FCB ADDR AGAIN
PUSH D ;SAVE IT STILL
MVI C,22 ;MAKE FILE
CALL BDOS ;CREATE "COM" FILE
INR A ;SEE IF -1 FOR ERROR
LXI D,NMDSMSG
JZ ERROR$ABORT ;NO MORE DIR SPACE
;DEFINE AND CLEAR THE COMFILE BUFFER
LDA 7 ;GET BDOS PAGE ADDRESS
SUI 16 ;ALLOW FOR UP TO 4K CCP
MOV H,A ;HI BYTE OF COM BUFFER TOP
MVI L,0 ;END ON PAGE BOUNDARY
SHLD CURR$COM$BUF$END
SUI (HIGH COMFILE$BUFFER)+1
MVI L,80H ;START IN MIDDLE OF PAGE
MOV H,A ;BUFFER LENGTH IN PAGES
SHLD CURR$COM$BUF$LEN
CALL CLEAR$COMBUFFER ;ZERO-OUT COM BUFFER
; HEX RECORD LOOP
SCAN$FOR$COLON:
CALL GET$HEXFILE$CHAR
CPI ':' ;DO WE HAVE COLON YET?
JNZ SCAN$FOR$COLON
CALL GET$BINARY$BYTE ;GOT COLON. GET LOAD COUNT
STA LOAD$COUNT ;STORE COUNT FOR THIS RECORD
JZ FINISH$UP ;ZERO MEANS ALL DONE
;INCREMENT BYTES-READ COUNTER BY NUMBER OF BYTES TO BE
;LOADED IN THIS RECORD.
LXI H,BYTES$READ$COUNT
ADD M ;ADD LO BYTE OF SUM
MOV M,A ;SAVE NEW LO BYTE
JNC FORM$LOAD$ADDRESS
INX H ;POINT HI BYTE OF SUM
INR M ;BUMP HI BYTE
;NOW SET NEW LOAD ADDRESS FROM THE
;HEX FILE RECORD.
FORM$LOAD$ADDRESS:
CALL GET$BINARY$BYTE
PUSH PSW
CALL GET$BINARY$BYTE
POP H ;HI BYTE TO <H>
MOV L,A ;AND LO BYTE TO <L>
SHLD LOAD$ADDRESS ;SAVE NEW LOAD ADDRESS
XCHG ;PUT IN <DE>
LHLD CURRENT$COM$BASE
;NEW LOAD ADDRESS MINUS THE CURRENT COMFILE BASE GIVES
;THE NEW COM BUFFER OFFSET.
MOV A,E
SUB L
MOV L,A
MOV A,D
SBB H
MOV H,A
SHLD COM$BUF$OFFSET ;STORE NEW OFFSET
LXI D,ILAMSG ;POINT ERR MSG
JC ERROR$ABORT ;FATAL INVERSION IF CY SET
;FIRST ADDRESS HAS ALREADY BEEN ESTABLISHED IF "FIRST$ADDRESS"
;IS NON-ZERO.
LDA FIRST$ADDRESS+1 ;--ONLY PAGE NO. NEED BE
ORA A ;--CHECKED SINCE 1ST ADDR
JNZ GET$ZERO$BYTE ;--CAN'T BE IN PAGE ZERO
LXI D,FAMSG ;POINT "1ST ADDR" MSG
CALL MSG$ON$NEW$LINE ;ANNOUNCE FIRST ADDRESS
LHLD LOAD$ADDRESS ;THIS IS FIRST ADDR
SHLD FIRST$ADDRESS ;SET FIRST ADDRESS
CALL WORD$OUT ;SEND IT TO CONSOLE
;SKIP OVER THE ZERO BYTE OF THE HEX RECORD. IT HAS NO
;SIGNIFICANCE TO THIS PROGRAM.
GET$ZERO$BYTE:
CALL GET$BINARY$BYTE
;THIS LOOP LOADS THE COM FILE WITH THE BYTE VALUES IN THE
;CURRENT HEX RECORD.
BYTE$LOAD$LOOP:
CALL GET$BINARY$BYTE ;GET BYTE TO LOAD
CALL PUT$TO$COMFILE ;LOAD IT TO COM FILE
LXI H,LOAD$COUNT
DCR M ;HIT LOAD COUNT
JNZ BYTE$LOAD$LOOP ;MORE LOADING IF NOT-ZERO
;UPDATE THE LAST ADDRESS IF CURRENT ABSOLUTE LOAD ADDRESS
;IS HIGHER THAN THE CURRENT VALUE OF "LAST$ADDRESS"
LHLD LAST$ADDRESS ;GET THE CURR VALUE
XCHG ;TO <DE>
CALL ABSOLUTE ;ABSOLUTE ADDR TO <HL>
MOV A,E ;--SUBTRACT ABSOLUTE
SUB L ;--ADDRESS FROM CURRENT
MOV A,D ;--LAST ADDRESS
SBB H
JNC CHECK$CHECKSUM ;LAST ADDR LARGER IF NC
DCX H ;DOWN 1 FOR LAST ACTUAL LOAD
SHLD LAST$ADDRESS ;UPDATE IT
;VERIFY THE CHECKSUM FOR THIS RECORD.
CHECK$CHECKSUM:
CALL GET$BINARY$BYTE ;GET CHECKSUM BYTE
JZ SCAN$FOR$COLON ;ZERO ON FOR CHECKSUM OK
LXI D,CSEMSG ;CHECKSUM ERROR
JMP HEXFILE$ERROR
;SEND PROCESSING SUMMARY TO THE CONSOLE AND FLUSH THE
;COM BUFFER OF ANY UNWRITTEN DATA.
FINISH$UP:
LXI D,LSTADDRMSG ;POINT "LAST ADDR" MSG
CALL MSG$ON$NEW$LINE ;SEND IT OUT
LHLD LAST$ADDRESS ;GET THE LAST ADDRESS
CALL WORD$OUT ;SEND IT TO CONSOLE
LXI D,BRMESSAGE ;POINT "BYTES READ" MSG
CALL MSG$ON$NEW$LINE ;SEND IT OUT
LHLD BYTES$READ$COUNT ;GET THE COUNT
CALL WORD$OUT ;SEND IT OUT
;THE FOLLOWING CODE PREPARES FOR AND MAKES THE FINAL CALL
;TO THE "PUT" ROUTINE IN ORDER TO FLUSH THE "COM" BUFFER.
;IT HAS BEEN "KLUGED" IN ORDER TO WORK AROUND THE BOUNDARY
;CONDITION OF HAVING AN OFFSET OF <100H AT FLUSH TIME.
;WE FORCE THE OFFSET AND LENGTH TO BE NON-ZERO SO THE
;INITIAL COMPARE IN THE "PUT" ROUTINE WON'T GET SCREWED
;UP. THE BUFFER END ADDRESS IS NOT PLAYED WITH, HOWEVER.
;THIS IS TO INSURE THAT THE CORRECT NUMBER OF RECORDS GET
;WRITTEN.
LHLD COM$BUF$OFFSET ;GET THE CURRENT OFFSET
PUSH H ;SAVE OFFSET FOR LATER
LXI D,COMFILE$BUFFER ;GET BUFFER ADDRESS
DAD D ;ADD TO OFFSET TO GET LEN
SHLD CURR$COM$BUF$END ;STORE NEW END ADDR
LXI H,CLEAR$FLAG ;POINT TO CLEAR FLAG
INR M ;DISABLE CLEAR WITH NON-ZERO
POP H ;GET OFFSET BACK
MVI H,1 ;FORCE HI BYTE NON-ZERO
SHLD COM$BUF$OFFSET ;FAKE OFFSET
SHLD CURR$COM$BUF$LEN ;AND FAKE LENGTH
CALL PUT$TO$COMFILE ;FLUSH THE BUFFER
LXI D,RWMSG ;POINT "REC WRIT" MSG
CALL MSG$ON$NEW$LINE ;SEND IT OUT
LDA RECORDS$WRITTEN ;GET THE COUNT
CALL BYTE$OUT ;SEND IT OUT
CALL CRLF ;SEND OUT CRLF
POP D ;COM FILE FCB ADDR
MVI C,16 ;CLOSE FILE
CALL BDOS ;COM FILE CLOSE
INR A ;SEE IF -1 FOR ERROR
LXI D,CCFMSG ;CANNOT CLOSE FILE
JZ ERROR$ABORT
CRLF$AND$EXIT:
CALL CRLF
EXIT:
LXI D,80H
MVI C,26 ;RE-SET DMA TO 80H
CALL BDOS
LHLD STACK$SAVE ;RECOVER CCP STACK POINTER
SPHL ;TO <SP>
RET ;RET TO CCP
; SUBROUTINES
;THIS ROUTINE GETS TWO CHARACTERS FROM THE HEX FILE
;AND CONVERTS TO AN 8-BIT BINARY VALUE, RETURNED IN <A>.
GET$BINARY$BYTE:
CALL GET$HEX$DIGIT ;GET HI NYBBLE FIRST
ADD A ;SHIFT UP 4 SLOTS
ADD A
ADD A
ADD A
PUSH PSW ;SAVE HI NYBBLE
CALL GET$HEX$DIGIT ;NOW GET LO NYBBLE
POP B ;HI NYBBLE TO <B>
ORA B ;COMBINE NYBBLES TO FORM BYTE
MOV B,A ;SAVE THE BYTE
LXI H,CHECKSUM
ADD M ;UPDATE THE CHECKSUM
MOV M,A ;AND STORE IT
MOV A,B ;GET BYTE BACK
RET ;ZERO SET MEANS CHECKSUM=0
;ROUTINE TO GET A HEX-ASCII CHARACTER FROM THE HEX FILE
;AND RETURN IT IN THE <A> REGISTER CONVERTED TO BINARY.
;A CHECK FOR LEGAL HEX VALUE IS MADE. PROGRAM ABORTS
;WITH APPROPRIATE MESSAGE IF ILLEGAL DIGIT ENCOUNTERED.
GET$HEX$DIGIT:
CALL GET$HEXFILE$CHAR
SUI '0' ;REMOVE ASCII BIAS
CPI 10 ;DECIMAL DIGIT?
RC
SUI 7 ;STRIP ADDITIONAL BIAS
CPI 10 ;MUST BE AT LEAST 10
JC ILLHEX
CPI 16 ;MUST BE 15 OR LESS
RC
ILLHEX LXI D,IHDMSG ;ILLEGAL HEX DIGIT
;ROUTINE TO INDICATE THAT AN ERROR HAS BEEN FOUND IN THE
;HEX FILE (EITHER CHECKSUM OR ILLEGAL HEX DIGIT).
;APPROPRIATE MESSAGES ARE PRINTED AND THE PROGRAM ABORTS.
HEXFILE$ERROR:
CALL MSG$ON$NEW$LINE ;PRINT ERROR TYPE
LXI D,LAMESSAGE ;POINT "LOAD ADDR" MSG
CALL MSG$ON$NEW$LINE ;SEND IT OUT
LHLD LOAD$ADDRESS ;GET LOAD ADDR
CALL WORD$OUT ;SEND IT OUT
LXI D,EAMSG ;POINT "ERR ADDR" MSG
CALL MSG$ON$NEW$LINE ;SEND IT OUT
CALL ABSOLUTE ;GET ABSOLUTE ADDR
CALL WORD$OUT ;THIS IS ERR ADDR
LXI D,BRMESSAGE ;POINT "BYTES READ" MSG
CALL MSG$ON$NEW$LINE ;SEND IT OUT
CALL PRINT$LOAD$ADDR ;SEND OUT CURR LOAD ADDR
;PRINT OUT ALL BYTES THAT WERE LOADED FROM THE CURRENT
;HEX RECORD UP TO THE POINT WHERE THE ERROR WAS DETECTED.
ERR$OUT$LOOP:
LHLD LOAD$ADDRESS ;POINT TO BYTE TO BE OUTPUT
XCHG ;TO <DE>
CALL ABSOLUTE ;GET ABSOLUTE ADDR
MOV A,E ;--SEE IF "LOAD ADDR"
SUB L ;--HAS REACHED ABSO ADDR
MOV A,D
SBB H
JNC CRLF$AND$EXIT ;DONE IF THEY'RE EQUAL
MOV A,E ;SEE IF MULTIPLE OF 16
ANI 0FH
CZ PRINT$LOAD$ADDR ;IF MULTIPLE OF 16
LHLD LOAD$ADDRESS ;GET LOAD ADDR AGAIN
XCHG ;TO <DE>
LHLD CURRENT$COM$BASE
MOV A,E ;--CALC OFFSET OF CURR
SUB L ;--BYTE TO GO OUT
MOV L,A ;LO BYTE OF OFFSET
MOV A,D ;HI BYTE OF LOAD ADDR
SBB H
MOV H,A ;HI BYTE OF OFFSET
LXI B,COMFILE$BUFFER
DAD B ;<HL> NOW POINTS TO BYTE TO GO
MOV A,M ;GET THE BYTE FROM BUFFER
CALL BYTE$OUT ;SEND IT OUT
LHLD LOAD$ADDRESS ;BUMP LOAD ADDRESS
INX H
SHLD LOAD$ADDRESS
MVI A,' ' ;SEND A SPACE BETWEEN BYTES
CALL CHAR$TO$CONSOLE
JMP ERR$OUT$LOOP ;BACK FOR MORE
;ROUTINE TO GET A CHARACTER FROM THE HEX FILE BUFFER.
;CHAR IS RETURNED IN <A>.
GET$HEXFILE$CHAR:
LDA HEX$BUFFER$OFFSET
INR A ;BUMP HEX OFFSET
JP GETCHAR ;PLUS IF NOT 80H YET
LXI D,HEX$BUFFER
MVI C,26 ;SET-DMA CODE
CALL BDOS ;SET DMA ADDR TO HEX BUFFER
LXI D,HEX$FCB ;POINT HEX FCB
MVI C,20 ;READ-NEXT-RECORD CODE
CALL BDOS ;GET NEXT HEXFILE RECORD
ORA A ;TEST FOR ERROR
LXI D,DRMSG ;ASSUME ERROR FOR NOW
JNZ ERROR$ABORT ;FATAL ERR IF NOT ZERO
GETCHAR:
STA HEX$BUFFER$OFFSET
MVI H,HIGH HEX$BUFFER
MOV L,A ;POINT TO NEXT CHAR
MOV A,M ;GET THE CHARACTER
RET
;
;THIS ROUTINE PUTS A DATA BYTE TO THE "COM" FILE.
;THE BYTE IS PASSED IN <A>.
;THE FIRST COMPARE IS DONE ON JUST THE HI BYTES FOR THE
;SAKE OF SPEED, SINCE WE ARE PROCESSING THE "HEX" FILE
;"ON THE FLY".
PUT$TO$COMFILE:
PUSH PSW ;SAVE BYTE TO LOAD
LHLD COM$BUF$OFFSET ;GET CURRENT OFFSET
XCHG ;TO <DE>
PTC LDA CURR$COM$BUF$LEN+1 ;PAGE NO. OF BUFF TOP
DCR A ;ONE LESS FOR COMPARE
CMP D ;TOP < OFFSET?
JNC STORE$BYTE ;STORE BYTE IF NOT
LHLD CURR$COM$BUF$LEN
MOV A,E ;SUBTRACT LEN FROM OFFSET--
SUB L ;--TO GET NEW OFFSET
MOV C,A ;<C> HAS LO BYTE OF DIFF
MOV A,D ;HI BYTE OF OFFSET
SBB H ;MINUS HI BYTE OF BUFF LENGTH
MOV B,A ;<BC> HAS NEW OFFSET
PUSH B ;SAVE NEW OFFSET
XCHG ;BUFFER LENGTH TO <DE>
LHLD CURRENT$COM$BASE ;COM BASE TO <HL>
DAD D ;INCREASE IT BY BUFFER LENGTH
SHLD CURRENT$COM$BASE ;STORE NEW BASE
LHLD CURR$COM$BUF$END
LXI D,COMFILE$BUFFER ;BUFFER ADDR TO <DE>
COMLOOP:
MOV A,E ;SUBTRACT BUFF END FROM POINTER
SUB L
MOV A,D
SBB H ;WRITTEN TO END OF BUFFER YET?
JNC STORE ;CY OFF MEANS WE'RE DONE
PUSH H ;SAVE BUFFER END ADDRESS
PUSH D ;SAVE WRITE POINTER
MVI C,26 ;SET DMA FUNCTION CODE
CALL BDOS ;SET NEW DMA ADDRESS
MVI C,21 ;WRITE-NEXT-RECORD CODE
LXI D,DEFAULT$FCB ;POINT COM FILE FCB
CALL BDOS ;WRITE NEXT COM RECORD
ORA A ;TEST FOR ERROR ON WRITE
LXI D,DWMSG ;POINT WRITE ERROR MSG
JNZ ERROR$ABORT ;BOMB IF WRITE ERROR
POP D ;RESTORE WRITE POINTER
LXI H,128 ;SECTOR SIZE
DAD D ;BUMP POINTER BY 128
XCHG ;NEW POINTER TO <DE>
LXI H,RECORDS$WRITTEN
INR M
POP H ;RESTORE BUFFER END ADDR
JMP COMLOOP ;SEE IF END OF BUFFER YET
STORE:
LDA CLEAR$FLAG ;GET CLEAR-BUFFER FLAG
ORA A ;SHALL WE CLEAR?
CZ CLEAR$COMBUFFER ;ZERO THE BUFFER
POP D ;GET BACK NEW OFFSET
JMP PTC ;SEE IF WE MUST FLUSH AGAIN
STORE$BYTE:
LXI H,COMFILE$BUFFER ;BUFFER ADDR TO <HL>
DAD D ;ADD TO CURRENT OFFSET
POP PSW ;RETRIEVE BYTE TO WRITE
MOV M,A ;STUFF IT
INX D ;BUMP OFFSET
XCHG ;TO <HL> FOR STORE
SHLD COM$BUF$OFFSET ;UPDATE OFFSET
RET ;ALL DONE
;
;ROUTINE TO CONVERT THE 2-BYTE VALUE IN <HL> TO
;TWO ASCII CHARACTERS AND SEND THEM TO THE CONSOLE.
;
WORD$OUT:
PUSH H ;SAVE WORD
MOV A,H ;HI WORD GOES OUT 1ST
CALL BYTE$OUT
POP H ;RESTORE WORD
MOV A,L ;LO BYTE GOES NEXT
BYTE$OUT:
PUSH PSW ;SAVE BYTE
RRC! RRC! RRC! RRC ;HI NYBBLE COMES DOWN
CALL NYBBLE$OUT
POP PSW ;RESTORE VALUE
NYBBLE$OUT:
ANI 0FH
ADI 90H
DAA
ACI 40H
DAA
CHAR$TO$CONSOLE:
MOV E,A
MVI C,2 ;WRITE CONSOLE CHAR FUNC CODE
JMP BDOS
;
;ROUTINE TO OUTPUT A "CRLF".
;
CRLF:
MVI A,CR
CALL CHAR$TO$CONSOLE
MVI A,LF
JMP CHAR$TO$CONSOLE
;
;ROUTINE TO PRINT A BUFFER TO THE CONSOLE.
;<DE> POINTS TO THE MESSAGE ON ENTRY.
;EARLIEST ENTRY POINT STARTS MESSAGE ON A NEW LINE
;
MSG$ON$NEW$LINE:
PUSH D ;SAVE MESSAGE POINTER
CALL CRLF ;START NEW LINE
POP D ;RESTORE MESSAGE POINTER
PRINT$BUFFER:
MVI C,9 ;OUTPUT BUFFER TO CONSOLE
JMP BDOS
;
;
;ERROR ABORT ROUTINE
;
ERROR$ABORT:
PUSH D ;SAVE MESSAGE POINTER
LXI D,ERRMSG ;POINT "ERROR" MSG
CALL MSG$ON$NEW$LINE ;SEND IT OUT
POP D ;RESTORE MESSAGE POINTER
CALL PRINT$BUFFER ;SEND OUT ERR TYPE
LXI D,LAMESSAGE ;POINT "LOAD ADDR" MSG
CALL MSG$ON$NEW$LINE ;SEND IT OUT
CALL ABSOLUTE ;GET ABSOLUTE ADDR
CALL WORD$OUT ;SEND IT OUT
JMP EXIT ;BAIL OUT
;THIS ROUTINE PRINTS THE LOAD ADDRESS OF THE CURRENT
;HEX RECORD ON A NEW LINE FOLLOWED BY A ':' AND SPACE.
PRINT$LOAD$ADDR:
CALL CRLF
LHLD LOAD$ADDRESS
CALL WORD$OUT
MVI A,':'
CALL CHAR$TO$CONSOLE
MVI A,' '
JMP CHAR$TO$CONSOLE
;ROUTINE TO CLEAR THE COMFILE BUFFER.
CLEAR$COMBUFFER:
LXI H,COMFILE$BUFFER
LDA CURR$COM$BUF$END+1 ;PAGE NO. OF BUF END
MVI C,0 ;GET ZERO
CLOOP MOV M,C ;ZERO TO BUFFER
INX H ;BUMP POINTER
CMP H ;END OF BUFFER YET?
JNZ CLOOP ;LOOP TILL DONE
RET
;ROUTINE TO COMPUTE CURRENT ABSOLUTE LOAD ADDRESS
;AND RETURN IT IN <HL>
ABSOLUTE:
LHLD CURRENT$COM$BASE ;GET BASE OF COM BUFFER
MOV B,H ;MOVE IT TO <BC>
MOV C,L
LHLD COM$BUF$OFFSET ;GET THE CURRENT OFFSET
DAD B ;SUM IS THE ABSO ADDR
RET
; MESSAGES
ERRMSG:
DB 'ERROR: $'
DRMSG:
DB 'DISK READ$'
ILAMSG:
DB 'LOAD ADDRESS LESS THAN 100$'
DWMSG:
DB 'DISK WRITE$'
LAMESSAGE:
DB 'LOAD ADDRESS $'
EAMSG:
DB 'ERROR ADDRESS $'
IHDMSG:
DB 'INVALID HEX DIGIT$'
CSEMSG:
DB 'CHECKSUM ERROR $'
FAMSG:
DB 'FIRST ADDRESS $'
LSTADDRMSG:
DB 'LAST ADDRESS $'
BRMESSAGE:
DB 'BYTES READ $'
RWMSG:
DB 'RECORDS WRITTEN $'
COSMSG:
DB 'CANNOT OPEN SOURCE FILE$'
NMDSMSG:
DB 'DIRECTORY FULL$'
CCFMSG:
DB 'CANNOT CLOSE FILE$'
SIGNON$MSG:
DB 'HEXCOM VERS: ',VERS/100+'0'
DB '.',VERS/10 MOD 10 +'0'
DB VERS MOD 10 + '0',CR,LF,'$'
; DATA AREA
HEX$BUFFER$OFFSET DB 127
FIRST$ADDRESS DW 0
LAST$ADDRESS DW 0
BYTES$READ$COUNT DW 0
RECORDS$WRITTEN DB 0
LOAD$ADDRESS DW 100H
CURRENT$COM$BASE DW 100H
CHECKSUM DB 0
COM$BUF$OFFSET DW 0
CLEAR$FLAG DB 0 ;CLEAR-COM-BUF FLAG
; STORAGE AREA
STACK$SAVE DS 2
HEX$FCB DS 33
LOAD$COUNT DS 1
CURR$COM$BUF$END DS 2 ;COM BUFFER TOP
CURR$COM$BUF$LEN DS 2 ;COM BUFFER LENGTH
DS 32 ;STACK AREA
STACK EQU $
ORG ((HIGH $)+1)*256
HEX$BUFFER DS 128
COMFILE$BUFFER EQU $
END

1163
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/INITDIR.PLI Normal file
View File

File diff suppressed because it is too large Load Diff

33
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/INPOUT.ASM Normal file
View File

@@ -0,0 +1,33 @@
$title ('INP:/OUT: Interface')
name inpout
cseg
;
; CP/M 3 PIP Utility INP: / OUT: Interface module
; Code org'd at 080h
; July 5, 1982
public inploc,outloc,inpd,outd
org 00h
inpd:
call inploc
ret
outd:
call outloc
ret
inploc:
mvi a,01Ah
ret
outloc:
ret
nop
nop
org 07fh
db 0
end
EOF


195
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/LDRLWR.ASM Normal file
View File

@@ -0,0 +1,195 @@
$title ('CP/M V3.0 Relocate and Fix Up File')
name relfix
;
;/*
; Copyright (C) 1979,1980,1981,1982
; Digital Research
; P.O. Box 579
; Pacific Grove, CA 93950
;
; Revised:
; 05 Aug 82 by Bruce Skidmore
;*/
cseg
extrn mon1 ;BDOS entry point
extrn FCBin ;FCB for input
extrn sctbfr ;sector buffer
extrn offset ;relocation offset
extrn prgsiz ;program size
extrn bufsiz ;buffer size
extrn bnkpg ;bnkbdos page
extrn respg ;resbdos page
extrn scbpg ;System Control Block page
extrn biospg ;Bios page
extrn reslen ;Resident System length
extrn bnkoff ;Banked System offset
extrn nonbnk ;Non Banked CP/M flag
public bitmap ;bitmap buffer
RelFix:
public RelFix
lxi d,bitmap
mvi c,26
call mon1 ;set DMA address to bit map
;
;file loaded, ready for relocation
lhld prgsiz
mov b,h
mov c,l ;BC = program size
mov a,l
ani 127
mov l,a
jnz nofill ;if program size is an even number
push h ;of sectors prefill the bitmap buffer
push b
lhld fcbin
xchg
mvi c,20
call mon1
pop b
pop h
ora a
jnz errtn
nofill:
mov e,l ;L = offset into bitmap buffer
mvi d,0
lxi h,bitmap
dad d ;HL = bit map base
mvi a,low(bitmap+128)
sta btmptp ;save number of relocation bytes
;in left in bitmap buffer
lxi d,sctbfr ;DE = base of program
push h ;save bit map base in stack
lda offset
mov h,a ;H = relocation offset
pgrel0:
mov a,b ;bc=0?
ora c
jz ExitRelFix
;
; not end of the relocation,
; may be into next byte of bit map
dcx b ;count length down
mov a,e
sui low(sctbfr)
ani 111b ;0 causes fetch of next byte
jnz pgrel3
; fetch bit map from stacked address
xthl
lda btmptp
cmp l
jnz pgrel2
push b
push d
lhld FCBin
xchg
mvi c,20
call mon1
pop d
pop b
lxi h,bitmap
ora a
jnz errtn ;return with error condition
pgrel2:
mov a,m ;next 8 bits of map
inx h
xthl ;base address goes back to stack
mov l,a ;l holds map as 8 bytes done
pgrel3:
mov a,l
ral ;cy set to 1 if reloc necessary
mov l,a ;back to l for next time around
jnc pgrel4 ;skip relocation if cy=0
;
; current address requires relocation
;
push h
ldax d ;if page = 0ffh
inr a
jnz test2
lda biospg ;then page = bios$page
jmp endt
test2: ;else
inr a ;if page = 0feh
jnz test3
lda scbpg ;then page = SCB$page
push psw
dcx d ;add 9ch to the offset(low byte)
ldax d
adi 09ch
stax d
inx d
pop psw
jmp endt
test3: ;else
inr a ;if page = 0fdh
jnz test4
lda respg ;then page = resbdos$page
jmp endt
test4: ;else
inr a ;if page = 0fch
jnz test5
lda bnkpg ;then page = bnkbdos$page
jmp endt
test5: ;else
inr a ;if page = 0fbh
jnz test6
lda scbpg ;then page = scb$page
jmp endt
test6: ;else
lda reslen
mov h,a ;if non$banked and page >= reslen
lda nonbnk
ora a
jz test7
ldax d
sub h
jc default ;then do;
dcx d ;page$adr = page$adr - 1;
mvi a,09ah
stax d ;page = 9ah;
inx d ;page$adr = page$adr + 1;
lda scbpg ;page = scb$pg;
jmp endt ;end;
test7: ;else
lda bnkoff
mov l,a ;if page >= reslen
ldax d
sub h
jc default
add l ;then page = page - reslen
jmp endt
default: ;else
lda offset ;page = page + offset
mov h,a
ldax d
add h
endt:
stax d
pop h
pgrel4:
inx d ;to next address
jmp pgrel0 ;for another byte to relocate
ExitRelFix:
pop h
lxi h,0
mov a,h
ret
errtn:
pop h ;discard return address
lxi h,0ffffh
mov a,h
ret ;return with error condition
;
; Local Data Segment
;
bitmap: ds 128 ;bit map buffer
btmptp: ds 1 ;bit low (bitmap+128)
end


47
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/LOAD.LIN Normal file
View File

@@ -0,0 +1,47 @@
0000 LOAD#
0000 LOAD#
023B 13 023B 14 023F 15 0240 16 0240 17
02D0 22 02D4 24 02DF 25 02E0 26 02E0 27
02E5 28 02EA 29 02EB 30 02EF 32 02F8 33
0306 34 030F 35 0310 36 0314 38 0321 39
032A 40 032B 41 0331 43 0339 44 0341 45
0342 46 0348 48 0351 49 0352 50 0358 52
035B 53 0363 54 0364 56 036A 58 0370 59
0378 60 037E 61 0386 62 0389 63 038A 65
0390 67 039C 68 039D 69 03A3 71 03AF 72
03B0 73 03B6 75 03C2 76 03C3 77 03C3 78
03CE 79 03CF 80 03D5 82 03DE 83 03DF 84
03E5 86 03EF 87 03EF 88 03F5 90 03FF 91
03FF 92 0405 94 0411 95 0412 96 0418 98
0421 99 0422 100 0431 102 043D 103 0447 104
044E 105 0455 106 0458 107 0459 108 0459 110
0469 111 0472 112 0497 113 04A5 114 04BA 116
04C2 117 04C8 118 04D1 119 04D7 120 04D7 121
04DA 122 04E0 123 04E4 124 04E4 126 05FD 129
0601 131 060D 132 0613 133 0624 134 0632 135
064A 136 0651 137 0658 138 065C 139 0667 141
066D 142 066D 143 0670 144 067F 145 0680 146
06E6 148 06E6 149 06E9 150 06F1 151 06F6 152
06FB 153 0680 154 0686 155 068E 156 0694 157
069C 158 06A2 159 06A5 160 06B1 161 06BC 162
06BF 163 06D0 164 06D7 165 06DC 166 06DF 167
06E2 168 06E5 169 06FC 170 06FC 172 070B 173
0711 174 071D 176 0723 177 0726 178 0726 179
072E 180 072E 181 072E 182 073D 183 073D 184
073D 186 0748 187 074C 188 074C 189 0752 191
0763 192 04E4 193 04F0 194 04F4 195 04FD 196
0502 197 0502 198 050A 199 050D 200 0512 201
051D 202 0520 203 052E 204 0541 205 054D 206
0553 207 0559 208 0565 209 056C 210 0573 211
0576 212 0582 213 0589 214 0595 216 059B 217
059E 218 059E 219 05A1 220 05A7 221 05B3 222
05B8 223 05BF 224 05C2 225 05C8 226 05D0 227
05D6 228 05DE 229 05E4 230 05EC 231 05F2 232
05F9 233 05FC 234 0240 236 0247 237 024B 238
0251 239 0257 240 0263 241 026F 242 0275 243
027D 244 0283 245 028F 246 0295 247 029B 248
02A1 249 02A9 250 02B2 252 02B5 253 02BB 254
02C3 255 02C9 256 02C9 257 02CC 258 02CF 259
0000 MODULE#


360
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/LOAD.PLM Normal file
View File

@@ -0,0 +1,360 @@
LOAD:
DO;
/* C P / M C O M M A N D F I L E L O A D E R
COPYRIGHT (C) 1976, 1977, 1978
DIGITAL RESEARCH
BOX 579 PACIFIC GROVE
CALIFORNIA 93950
*/
DECLARE
TPA LITERALLY '0100H', /* TRANSIENT PROGRAM AREA */
DFCBA LITERALLY '005CH', /* DEFAULT FILE CONTROL BLOCK */
DBUFF LITERALLY '0080H'; /* DEFAULT BUFFER ADDRESS */
/* JMP LOADCOM TO START LOAD */
DECLARE JUMP BYTE DATA(0C3H);
DECLARE JUMPA ADDRESS DATA(.LOADCOM);
DECLARE COPYRIGHT(*) BYTE DATA
(' COPYRIGHT (C) 1978, DIGITAL RESEARCH ');
MON1: PROCEDURE(F,A) EXTERNAL;
DECLARE F BYTE, A ADDRESS;
END MON1;
MON2: PROCEDURE(F,A) BYTE EXTERNAL;
DECLARE F BYTE, A ADDRESS;
END MON2;
DECLARE SP ADDRESS;
BOOT: PROCEDURE;
STACKPTR = SP;
RETURN;
END BOOT;
LOADCOM: PROCEDURE;
DECLARE FCB (33) BYTE AT (DFCBA),
FCBA LITERALLY 'DFCBA';
DECLARE BUFFER (128) BYTE AT (DBUFF),
BUFFA LITERALLY 'DBUFF';
DECLARE SFCB(33) BYTE, /* SOURCE FILE CONTROL BLOCK */
BSIZE LITERALLY '1024',
EOFILE LITERALLY '1AH',
SBUFF(BSIZE) BYTE, /* SOURCE FILE BUFFER */
RFLAG BYTE, /* READER FLAG */
SBP ADDRESS; /* SOURCE FILE BUFFER POINTER */
/* LOADCOM LOADS TRANSIENT COMMAND FILES TO THE DISK FROM THE
CURRENTLY DEFINED READER PERIPHERAL. THE LOADER PLACES THE MACHINE
CODE INTO A FILE WHICH APPEARS IN THE LOADCOM COMMAND */
DECLARE
TRUE LITERALLY '1',
FALSE LITERALLY '0',
FOREVER LITERALLY 'WHILE TRUE',
CR LITERALLY '13',
LF LITERALLY '10',
WHAT LITERALLY '63';
PRINTCHAR: PROCEDURE(CHAR);
DECLARE CHAR BYTE;
CALL MON1(2,CHAR);
END PRINTCHAR;
CRLF: PROCEDURE;
CALL PRINTCHAR(CR);
CALL PRINTCHAR(LF);
END CRLF;
PRINTNIB: PROCEDURE(N);
DECLARE N BYTE;
IF N > 9 THEN CALL PRINTCHAR(N+'A'-10); ELSE
CALL PRINTCHAR(N+'0');
END PRINTNIB;
PRINTHEX: PROCEDURE(B);
DECLARE B BYTE;
CALL PRINTNIB(SHR(B,4)); CALL PRINTNIB(B AND 0FH);
END PRINTHEX;
PRINTADDR: PROCEDURE(A);
DECLARE A ADDRESS;
CALL PRINTHEX(HIGH(A)); CALL PRINTHEX(LOW(A));
END PRINTADDR;
PRINTM: PROCEDURE(A);
DECLARE A ADDRESS;
CALL MON1(9,A);
END PRINTM;
PRINT: PROCEDURE(A);
DECLARE A ADDRESS;
/* PRINT THE STRING STARTING AT ADDRESS A UNTIL THE
NEXT DOLLAR SIGN IS ENCOUNTERED WITH PRECEDING CRLF */
CALL CRLF;
CALL PRINTM(A);
END PRINT;
DECLARE LA ADDRESS; /* CURRENT LOAD ADDRESS */
PERROR: PROCEDURE(A);
/* PRINT ERROR MESSAGE */
DECLARE A ADDRESS;
CALL PRINT(.('ERROR: $'));
CALL PRINTM(A);
CALL PRINTM(.(', LOAD ADDRESS $'));
CALL PRINTADDR(LA);
CALL BOOT;
END PERROR;
DECLARE DCNT BYTE;
OPEN: PROCEDURE(FCB);
DECLARE FCB ADDRESS;
DCNT = MON2(15,FCB);
END OPEN;
CLOSE: PROCEDURE(FCB);
DECLARE FCB ADDRESS;
DCNT = MON2(16,FCB);
END CLOSE;
SEARCH: PROCEDURE(FCB);
DECLARE FCB ADDRESS;
DCNT = MON2(17,FCB);
END SEARCH;
SEARCHN: PROCEDURE;
DCNT = MON2(18,0);
END SEARCHN;
DELETE: PROCEDURE(FCB);
DECLARE FCB ADDRESS;
CALL MON1(19,FCB);
END DELETE;
DISKREAD: PROCEDURE(FCB) BYTE;
DECLARE FCB ADDRESS;
RETURN MON2(20,FCB);
END DISKREAD;
DISKWRITE: PROCEDURE(FCB) BYTE;
DECLARE FCB ADDRESS;
RETURN MON2(21,FCB);
END DISKWRITE;
MAKE: PROCEDURE(FCB);
DECLARE FCB ADDRESS;
DCNT = MON2(22,FCB);
END MAKE;
RENAME: PROCEDURE(FCB);
DECLARE FCB ADDRESS;
CALL MON1(23,FCB);
END RENAME;
MOVE: PROCEDURE(S,D,N);
DECLARE (S,D) ADDRESS, N BYTE,
A BASED S BYTE, B BASED D BYTE;
DO WHILE (N:=N-1) <> 255;
B = A; S=S+1; D=D+1;
END;
END MOVE;
GETCHAR: PROCEDURE BYTE;
/* GET NEXT CHARACTER */
DECLARE I BYTE;
IF (SBP := SBP+1) <= LAST(SBUFF) THEN
RETURN SBUFF(SBP);
/* OTHERWISE READ ANOTHER BUFFER FULL */
DO SBP = 0 TO LAST(SBUFF) BY 128;
IF (I:=DISKREAD(.SFCB)) = 0 THEN
CALL MOVE(80H,.SBUFF(SBP),80H); ELSE
DO;
IF I<>1 THEN CALL PERROR(.('DISK READ$'));
SBUFF(SBP) = EOFILE;
SBP = LAST(SBUFF);
END;
END;
SBP = 0; RETURN SBUFF(0);
END GETCHAR;
DECLARE
STACKPOINTER LITERALLY 'STACKPTR';
/* INTEL HEX FORMAT LOADER */
RELOC: PROCEDURE;
DECLARE (RL, CS, RT) BYTE;
DECLARE
TA ADDRESS, /* TEMP ADDRESS */
SA ADDRESS, /* START ADDRESS */
FA ADDRESS, /* FINAL ADDRESS */
NB ADDRESS, /* NUMBER OF BYTES LOADED */
MBUFF(256) BYTE,
P BYTE,
L ADDRESS;
SETMEM: PROCEDURE(B);
/* SET MBUFF TO B AT LOCATION LA MOD LENGTH(MBUFF) */
DECLARE (B,I) BYTE;
IF LA < L THEN
CALL PERROR(.('INVERTED LOAD ADDRESS$'));
DO WHILE LA > L + LAST(MBUFF); /* WRITE A PARAGRAPH */
DO I = 0 TO 127; /* COPY INTO BUFFER */
BUFFER(I) = MBUFF(LOW(L)); L = L + 1;
END;
/* WRITE BUFFER ONTO DISK */
P = P + 1;
IF DISKWRITE(FCBA) <> 0 THEN
DO; CALL PERROR(.('DISK WRITE$'));
END;
END;
MBUFF(LOW(LA)) = B;
END SETMEM;
DIAGNOSE: PROCEDURE;
DECLARE M BASED TA BYTE;
NEWLINE: PROCEDURE;
CALL CRLF; CALL PRINTADDR(TA); CALL PRINTCHAR(':');
CALL PRINTCHAR(' ');
END NEWLINE;
/* PRINT DIAGNOSTIC INFORMATION AT THE CONSOLE */
CALL PRINT(.('LOAD ADDRESS $')); CALL PRINTADDR(TA);
CALL PRINT(.('ERROR ADDRESS $')); CALL PRINTADDR(LA);
CALL PRINT(.('BYTES READ:$')); CALL NEWLINE;
DO WHILE TA < LA;
IF (LOW(TA) AND 0FH) = 0 THEN CALL NEWLINE;
CALL PRINTHEX(MBUFF(TA-L)); TA=TA+1;
CALL PRINTCHAR(' ');
END;
CALL CRLF;
CALL BOOT;
END DIAGNOSE;
READHEX: PROCEDURE BYTE;
/* READ ONE HEX CHARACTER FROM THE INPUT */
DECLARE H BYTE;
IF (H := GETCHAR) - '0' <= 9 THEN RETURN H - '0';
IF H - 'A' > 5 THEN
DO; CALL PRINT(.('INVALID HEX DIGIT$'));
CALL DIAGNOSE;
END;
RETURN H - 'A' + 10;
END READHEX;
READBYTE: PROCEDURE BYTE;
/* READ TWO HEX DIGITS */
RETURN SHL(READHEX,4) OR READHEX;
END READBYTE;
READCS: PROCEDURE BYTE;
/* READ BYTE WHILE COMPUTING CHECKSUM */
DECLARE B BYTE;
CS = CS + (B := READBYTE);
RETURN B;
END READCS;
MAKE$DOUBLE: PROCEDURE(H,L) ADDRESS;
/* CREATE A BOUBLE BYTE VALUE FROM TWO SINGLE BYTES */
DECLARE (H,L) BYTE;
RETURN SHL(DOUBLE(H),8) OR L;
END MAKE$DOUBLE;
/* INITIALIZE */
SA, FA, NB = 0;
P = 0; /* PARAGRAPH COUNT */
TA,L = TPA; /* BASE ADDRESS OF TRANSIENT ROUTINES */
SBUFF(0) = EOFILE;
/* READ RECORDS UNTIL :00XXXX IS ENCOUNTERED */
DO FOREVER;
/* SCAN THE : */
DO WHILE GETCHAR <> ':';
END;
/* SET CHECK SUM TO ZERO, AND SAVE THE RECORD LENGTH */
CS = 0;
/* MAY BE THE END OF TAPE */
IF (RL := READCS) = 0 THEN
GO TO FIN;
NB = NB + RL;
TA, LA = MAKE$DOUBLE(READCS,READCS);
IF SA = 0 THEN SA = LA;
/* READ THE RECORD TYPE (NOT CURRENTLY USED) */
RT = READCS;
/* PROCESS EACH BYTE */
DO WHILE (RL := RL - 1) <> 255;
CALL SETMEM(READCS); LA = LA+1;
END;
IF LA > FA THEN FA = LA - 1;
/* NOW READ CHECKSUM AND COMPARE */
IF CS + READBYTE <> 0 THEN
DO; CALL PRINT(.('CHECK SUM ERROR $'));
CALL DIAGNOSE;
END;
END;
FIN:
/* EMPTY THE BUFFERS */
TA = LA;
DO WHILE L < TA;
CALL SETMEM(0); LA = LA+1;
END;
/* PRINT FINAL STATISTICS */
CALL PRINT(.('FIRST ADDRESS $')); CALL PRINTADDR(SA);
CALL PRINT(.('LAST ADDRESS $')); CALL PRINTADDR(FA);
CALL PRINT(.('BYTES READ $')); CALL PRINTADDR(NB);
CALL PRINT(.('RECORDS WRITTEN $')); CALL PRINTHEX(P);
CALL CRLF;
END RELOC;
/* ARRIVE HERE FROM THE SYSTEM MONITOR, READY TO READ THE HEX TAPE */
/* SET UP STACKPOINTER IN THE LOCAL AREA */
DECLARE STACK(16) ADDRESS;
SP = STACKPOINTER; STACKPOINTER = .STACK(LENGTH(STACK));
LA = TPA;
SBP = LENGTH(SBUFF);
/* SET UP THE SOURCE FILE */
CALL MOVE(FCBA,.SFCB,33);
CALL MOVE(.('HEX',0),.SFCB(9),4);
CALL OPEN(.SFCB);
IF DCNT = 255 THEN CALL PERROR(.('CANNOT OPEN SOURCE$'));
CALL MOVE(.('COM'),FCBA+9,3);
/* REMOVE ANY EXISTING FILE BY THIS NAME */
CALL DELETE(FCBA);
/* THEN OPEN A NEW FILE */
CALL MAKE(FCBA); CALL OPEN(FCBA);
IF DCNT = 255 THEN CALL PERROR(.('NO MORE DIRECTORY SPACE$')); ELSE
DO; CALL RELOC;
CALL CLOSE(FCBA);
IF DCNT = 255 THEN CALL PERROR(.('CANNOT CLOSE FILE$'));
END;
CALL CRLF;
CALL BOOT;
END LOADCOM;
END;


738
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/LOADER3.ASM Normal file
View File

@@ -0,0 +1,738 @@
title 'CP/M 3 - PROGRAM LOADER RSX - November 1982'
; version 3.0b Nov 04 1982 - Kathy Strutynski
; version 3.0c Nov 23 1982 - Doug Huskey
; Dec 22 1982 - Bruce Skidmore
;
;
; copyright (c) 1982
; digital research
; box 579
; pacific grove, ca.
; 93950
;
****************************************************
***** The following values must be placed in ***
***** equates at the front of CCP3.ASM. ***
***** ***
***** Note: Due to placement at the front these ***
***** equates cause PHASE errors which can be ***
***** ignored. ***
equ1 equ rsxstart +0100h ;set this equate in the CCP
equ2 equ fixchain +0100h ;set this equate in the CCP
equ3 equ fixchain1+0100h ;set this equate in the CCP
equ4 equ fixchain2+0100h ;set this equate in the CCP
equ5 equ rsx$chain+0100h ;set this equate in the CCP
equ6 equ reloc +0100h ;set this equate in the CCP
equ7 equ calcdest +0100h ;set this equate in the CCP
equ8 equ scbaddr +0100h ;set this equate in the CCP
equ9 equ banked +0100h ;set this equate in the CCP
equ10 equ rsxend +0100h ;set this equate in the CCP
ccporg equ CCP ;set origin to this in CCP
patch equ patcharea+0100h ;LOADER patch area
CCP equ 41Ah ;ORIGIN OF CCP3.ASM
****************************************************
; conditional assembly toggles:
true equ 0ffffh
false equ 0h
spacesaver equ true
stacksize equ 32 ;16 levels of stack
version equ 30h
tpa equ 100h
ccptop equ 0Fh ;top page of CCP
osbase equ 06h ;base page in BDOS jump
off$nxt equ 10 ;address in next jmp field
currec equ 32 ;current record field in fcb
ranrec equ 33 ;random record field in fcb
;
;
; dsect for SCB
;
bdosbase equ 98h ; offset from page boundary
ccpflag1 equ 0b3h ; offset from page boundary
multicnt equ 0e6h ; offset from page boundary
rsx$only$clr equ 0FDh ;clear load RSX flag
rsx$only$set equ 002h
rscbadd equ 3ah ;offset of scbadd in SCB
dmaad equ 03ch ;offset of DMA address in SCB
bdosadd equ 62h ;offset of bdosadd in SCB
;
loadflag equ 02H ;flag for LOADER in memory
;
; dsect for RSX
entry equ 06h ;RSX contain jump to start
;
nextadd equ 0bh ;address of next RXS in chain
prevadd equ 0ch ;address of previous RSX in chain
warmflg equ 0eh ;remove on wboot flag
endchain equ 18h ;end of RSX chain flag
;
;
readf equ 20 ;sequential read
dmaf equ 26 ;set DMA address
scbf equ 49 ;get/set SCB info
loadf equ 59 ;load function
;
;
maxread equ 64 ;maximum of 64 pages in MULTIO
;
;
wboot equ 0000h ;BIOS warm start
bdos equ 0005h ;bdos entry point
print equ 9 ;bdos print function
vers equ 12 ;get version number
module equ 200h ;module address
;
; DSECT for COM file header
;
comsize equ tpa+1h
scbcode equ tpa+3h
rsxoff equ tpa+10h
rsxlen equ tpa+12h
;
;
cr equ 0dh
lf equ 0ah
;
;
cseg
;
;
; ********* LOADER RSX HEADER ***********
;
rsxstart:
jmp ccp ;the ccp will move this loader to
db 0,0,0 ;high memory, these first 6 bytes
;will receive the serial number from
;the 6 bytes prior to the BDOS entry
;point
tojump:
jmp begin
next db 0c3h ;jump to next module
nextjmp dw 06
prevjmp dw 07
db 0 ;warm start flag
db 0 ;bank flag
db 'LOADER ' ;RSX name
db 0ffh ;end of RSX chain flag
db 0 ;reserved
db 0 ;patch version number
; ********* LOADER RSX ENTRY POINT ***********
begin:
mov a,c
cpi loadf
jnz next
beginlod:
pop b
push b ;BC = return address
lxi h,0 ;switch stacks
dad sp
lxi sp,stack ;our stack
shld ustack ;save user stack address
push b ;save return address
xchg ;save address of user's FCB
shld usrfcb
mov a,h ;is .fcb = 0000h
ora l
push psw
cz rsx$chain ;if so , remove RSXs with remove flag on
pop psw
cnz loadfile
pop d ;return address
lxi h,tpa
mov a,m
cpi ret
jz rsxfile
mov a,d ;check return address
dcr a ; if CCP is calling
ora e ; it will be 100H
jnz retuser1 ;jump if not CCP
retuser:
lda prevjmp+1 ;get high byte
ora a ;is it the zero page (i.e. no RSXs present)
jnz retuser1 ;jump if not
lhld nextjmp ;restore five....don't stay arround
shld osbase
shld newjmp
call setmaxb
retuser1:
lhld ustack ;restore the stack
sphl
xra a
mov l,a
mov h,a ;A,HL=0 (successful return)
ret ;CCP pushed 100H on stack
;
;
; BDOS FUNC 59 error return
;
reterror:
lxi d,0feh
reterror1:
;DE = BDOS error return
lhld ustack
sphl
pop h ;get return address
push h
dcr h ;is it 100H?
mov a,h
ora l
xchg ;now HL = BDOS error return
mov a,l
mov b,h
rnz ;return if not the CCP
;
;
loaderr:
mvi c,print
lxi d,nogo ;cannot load program
call bdos ;to print the message
jmp wboot ;warm boot
;
;
;;
;************************************************************************
;
; MOVE RSXS TO HIGH MEMORY
;
;************************************************************************
;
;
; RSX files are present
;
rsxf1: inx h
mov c,m
inx h
mov b,m ;BC contains RSX length
lda banked
ora a ;is this the non-banked system?
jz rsxf2 ;jump if so
inx h ;HL = banked/non-banked flag
inr m ;is this RSX only for non-banked?
jz rsxf3 ;skip if so
rsxf2: push d ;save offset
call calcdest ;calculate destination address and bias
pop h ;rsx offset in file
call reloc ;move and relocate file
call fixchain ;fix up rsx address chain
rsxf3: pop h ;RSX length field in header
rsxfile:
;HL = .RSX (n-1) descriptor
lxi d,10h ;length of RSX descriptor in header
dad d ;HL = .RSX (n) descriptor
push h ;RSX offset field in COM header
mov e,m
inx h
mov d,m ;DE = RSX offset
mov a,e
ora d
jnz rsxf1 ;jump if RSX offset is non-zero
;
;
;
comfile:
;RSXs are in place, now call SCB setting code
call scbcode ;set SCB flags for this com file
;is there a real COM file?
lda module ;is this an RSX only
cpi ret
jnz comfile2 ;jump if real COM file
lhld scbaddr
mvi l,ccpflag1
mov a,m
ori rsx$only$set ;set if RSX only
mov m,a
comfile2:
lhld comsize ;move COM module to 100H
mov b,h
mov c,l ;BC contains length of COM module
lxi h,tpa+100h ;address of source for COM move to 100H
lxi d,tpa ;destination address
call move
jmp retuser1 ;restore stack and return
;;
;************************************************************************
;
; ADD AN RSX TO THE CHAIN
;
;************************************************************************
;
;
fixchain:
lhld osbase ;next RSX link
mvi l,0
lxi b,6
call move ;move serial number down
mvi e,endchain
stax d ;set loader flag=0
mvi e,prevadd+1
stax d ;set previous field to 0007H
dcx d
mvi a,7
stax d ;low byte = 7H
mov l,e ;HL address previous field in next RSX
mvi e,nextadd ;change previous field in link
mov m,e
inx h
mov m,d ;current <-- next
;
fixchain1:
;entry: H=next RSX page,
; DE=.(high byte of next RSX field) in current RSX
xchg ;HL-->current DE-->next
mov m,d ;put page of next RSX in high(next field)
dcx h
mvi m,6
;
fixchain2:
;entry: H=page of lowest active RSX in the TPA
;this routine resets the BDOS address @ 6H and in the SCB
mvi l,6
shld osbase ;change base page BDOS vector
shld newjmp ;change SCB value for BDOS vector
;
;
setmaxb:
lxi d,scbadd2
scbfun:
mvi c,scbf
jmp bdos
;
;
;;
;************************************************************************
;
; REMOVE TEMPORARY RSXS
;
;************************************************************************
;
;
;
rsx$chain:
;
; Chase up RSX chain, removing RSXs with the
; remove flag on (0FFH)
;
lhld osbase ;base of RSX chain
mov b,h
rsx$chain1:
;B = current RSX
mov h,b
mvi l,endchain
inr m
dcr m ;is this the loader?
rnz ;return if so (m=0ffh)
mvi l,nextadd ;address of next node
mov b,m ;DE -> next link
;
;
check$remove:
;
mvi l,warmflg ;check remove flag
mov a,m ;warmflag in A
ora a ;FF if remove on warm start
jz rsx$chain1 ;check next RSX if not
;
remove:
;remove this RSX from chain
;
;first change next field of prior link to point to next RSX
;HL = current B = next
;
mvi l,prevadd
mov e,m ;address of previous RSX link
inx h
mov d,m
mov a,b ;A = next (high byte)
stax d ;store in previous link
dcx d ;previous RSX chains to next RSX
mvi a,6 ;initialize low byte to 6
stax d ;
inx d ;DE = .next (high byte)
;
;now change previous field of next link to address previous RSX
mov h,b ;next in HL...previous in DE
mvi l,prevadd
mov m,e
inx h
mov m,d ;next chained back to previous RSX
mov a,d ;check to see if this is the bottom
ora a ;RSX...
push b
cz fixchain2 ;reset BDOS BASE to page in H
pop b
jmp rsx$chain1 ;check next RSX in the chain
;
;
;;
;************************************************************************
;
; PROGRAM LOADER
;
;************************************************************************
;
;
;
loadfile:
; entry: HL = .FCB
push h
lxi d,scbdma
call scbfun
xchg
pop h ;.fcb
push h ;save .fcb
lxi b,currec
dad b
mvi m,0 ;set current record to 0
inx h
mov c,m ;load address
inx h
mov h,m
mov l,c
dcr h
inr h
jz reterror ;Load address < 100h
push h ;now save load address
push d ;save the user's DMA
push h
call multio1 ;returns A=multio
pop h
push psw ;save A = user's multisector I/O
mvi e,128 ;read 16k
;stack: |return address|
; |.FCB |
; |Load address |
; |users DMA |
; |users Multio |
;
loadf0:
;HL= next load address (DMA)
; E= number of records to read
lda osbase+1 ;calculate maximum number of pages
dcr a
sub h
jc endload ;we have used all we can
inr a
cpi maxread ;can we read 16k?
jnc loadf2
rlc ;change to sectors
mov e,a ;save for multi i/o call
mov a,l ;A = low(load address)
ora a
jz loadf2 ;load on a page boundary
mvi b,2 ;(to subtract from # of sectors)
dcr a ;is it greater than 81h?
jm subtract ;080h < l(adr) <= 0FFh (subtract 2)
dcr b ;000h < l(adr) <= 080h (subtract 1)
subtract:
mov a,e ;reduce the number of sectors to
sub b ;compensate for non-page aligned
;load address
jz endload ;can't read zero sectors
mov e,a
;
loadf2:
;read the file
push d ;save number of records to read
push h ;save load address
call multio ;set multi-sector i/o
pop h
push h
call readb ;read sector
pop h
pop d ;restore number of records
push psw ;zero flag set if no error
mov a,e ;number of records in A
inr a
rar ;convert to pages
add h
mov h,a ;add to load address
shld loadtop ;save next free page address
pop psw
jz loadf0 ;loop if more to go
loadf4:
;FINISHED load A=1 if successful (eof)
; A>1 if a I/O error occured
;
pop b ;B=multisector I/O count
dcr a ;not eof error?
mov e,b ;user's multisector count
call multio
mvi c,dmaf ;restore the user's DMA address
pop d
push psw ;zero flag => successful load
call bdos ; user's DMA now restored
pop psw
lhld bdosret ;BDOS error return
xchg
jnz reterror1
pop d ;load address
pop h ;.fcb
lxi b,9 ;is it a PRL?
dad b ;.fcb(type)
mov a,m
ani 7fh ;get rid of attribute bit
cpi 'P' ;is it a P?
rnz ;return if not
inx h
mov a,m
ani 7fh
cpi 'R' ;is it a R
rnz ;return if not
inx h
mov a,m
ani 7fh
sui 'L' ;is it a L?
rnz ;return if not
;load PRL file
mov a,e
ora a ;is load address on a page boundary
jnz reterror ;error, if not
mov h,d
mov l,e ;HL,DE = load address
inx h
mov c,m
inx h
mov b,m
mov l,e ;HL,DE = load address BC = length
; jmp reloc ;relocate PRL file at load address
;
;;
;************************************************************************
;
; PAGE RELOCATOR
;
;************************************************************************
;
;
reloc:
; HL,DE = load address (of PRL header)
; BC = length of program (offset of bit map)
inr h ;offset by 100h to skip header
push d ;save destination address
push b ;save length in bc
call move ;move rsx to correct memory location
pop b
pop d
push d ;save DE for fixchain...base of RSX
mov e,d ;E will contain the BIAS from 100h
dcr e ;base address is now 100h
;after move HL addresses bit map
;
;storage moved, ready for relocation
; HL addresses beginning of the bit map for relocation
; E contains relocation bias
; D contain relocation address
; BC contains length of code
rel0: push h ;save bit map base in stack
mov h,e ;relocation bias is in e
mvi e,0
;
rel1: mov a,b ;bc=0?
ora c
jz endrel
;
; not end of the relocation, may be into next byte of bit map
dcx b ;count length down
mov a,e
ani 111b ;0 causes fetch of next byte
jnz rel2
; fetch bit map from stacked address
xthl
mov a,m ;next 8 bits of map
inx h
xthl ;base address goes back to stack
mov l,a ;l holds the map as we process 8 locations
rel2: mov a,l
ral ;cy set to 1 if relocation necessary
mov l,a ;back to l for next time around
jnc rel3 ;skip relocation if cy=0
;
; current address requires relocation
ldax d
add h ;apply bias in h
stax d
rel3: inx d ;to next address
jmp rel1 ;for another byte to relocate
;
endrel: ;end of relocation
pop d ;clear stacked address
pop d ;restore DE to base of PRL
ret
;
;;
;************************************************************************
;
; PROGRAM LOAD TERMINATION
;
;************************************************************************
;
;;
;;
endload:
call multio1 ;try to read after memory is filled
lxi h,80h ;set load address = default buffer
call readb
jnz loadf4 ;eof => successful
lxi h,0feh ;set BDOSRET to indicate an error
shld bdosret
jmp loadf4 ;unsuccessful (file to big)
;
;;
;
;;
;************************************************************************
;
; SUBROUTINES
;
;************************************************************************
;
;
;
; Calculate RSX base in the top of the TPA
;
calcdest:
;
; calcdest returns destination in DE
; BC contains length of RSX
;
lda osbase+1 ;a has high order address of memory top
dcr a ;page directly below bdos
dcx b ;subtract 1 to reflect last byte of code
sub b ;a has high order address of reloc area
inx b ;add 1 back get bit map offset
cpi ccptop ;are we below the CCP
jc loaderr
lhld loadtop
cmp h ;are we below top of this module
jc loaderr
mov d,a
mvi e,0 ;d,e addresses base of reloc area
ret
;
;;
;;-----------------------------------------------------------------------
;;
;; move memory routine
move:
; move source to destination
; where source is in HL and destination is in DE
; and length is in BC
;
mov a,b ;bc=0?
ora c
rz
dcx b ;count module size down to zero
mov a,m ;get next absolute location
stax d ;place it into the reloc area
inx d
inx h
jmp move
;;
;;-----------------------------------------------------------------------
;;
;; Multi-sector I/O
;; (BDOS function #44)
;
multio1:
mvi e,1 ;set to read 1 sector
;
multio:
;entry: E = new multisector count
;exit: A = old multisector count
lhld scbaddr
mvi l,multicnt
mov a,m
mov m,e
ret
;;
;;-----------------------------------------------------------------------
;;
;; read file
;; (BDOS function #20)
;;
;; entry: hl = buffer address (readb only)
;; exit z = set if read ok
;;
readb: xchg
setbuf: mvi c,dmaf
push h ;save number of records
call bdos
mvi c,readf
lhld usrfcb
xchg
call bdos
shld bdosret ;save bdos return
pop d ;restore number of records
ora a
rz ;no error on read
mov e,h ;change E to number records read
ret
;
;
;************************************************************************
;
; DATA AREA
;
;************************************************************************
;
nogo db cr,lf,'Cannot load Program$'
patcharea:
ds 36 ;36 byte patch area
scbaddr dw 0
banked db 0
scbdma db dmaad
db 00h ;getting the value
scbadd2 db bdosadd ;current top of TPA
db 0feh ;set the value
;
if not spacesaver
newjmp ds 2 ;new BDOS vector
loadtop ds 2 ;page above loaded program
usrfcb ds 2 ;contains user FCB add
ustack: ds 2 ; user stack on entry
bdosret ds 2 ;bdos error return
;
rsxend :
stack equ rsxend+stacksize
else
rsxend:
newjmp equ rsxend
loadtop equ rsxend+2
usrfcb equ rsxend+4
ustack equ rsxend+6
bdosret equ rsxend+8
stack equ rsxend+10+stacksize
endif
end


633
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/MAIN.PLM Normal file
View File

@@ -0,0 +1,633 @@
/* C P / M - M P / M D I R E C T O R Y C O M M O N (SDIR) */
/* B E G I N N I N G O F C O M M O N M A I N M O D U L E */
/* This module is included in main80.plm or main86.plm. */
/* The differences between 8080 and 8086 versions are */
/* contained in the modules main80.plm, main86.plm and */
/* dpb80.plm, dpb86.plm and the submit files showing */
/* the different link and location addresses. */
$include (comlit.lit)
$include (mon.plm)
dcl patch (128) address;
/* Scanner Entry Points in scan.plm */
scan: procedure(pcb$adr) external;
declare pcb$adr address;
end scan;
scan$init: procedure(pcb$adr) external;
declare pcb$adr address;
end scan$init;
/* -------- Routines in other modules -------- */
search$init: procedure external; /* initialization of search.plm */
end search$init;
get$files: procedure external; /* entry to search.plm */
end get$files;
sort: procedure external; /* entry to sort.plm */
end sort;
mult23: procedure (num) address external; /* in sort.plm */
dcl num address;
end mult23;
display$files: procedure external; /* entry to disp.plm */
end display$files;
/* -------- Routines in util.plm -------- */
printb: procedure external;
end printb;
print$char: procedure(c) external;
dcl c byte;
end print$char;
print: procedure(string$adr) external;
dcl string$adr address;
end print;
crlf: procedure external;
end crlf;
p$decimal: procedure(value,fieldsize,zsup) external;
dcl value address,
fieldsize address,
zsup boolean;
end p$decimal;
/* ------------------------------------- */
dcl debug boolean public initial (false);
/* -------- version information -------- */
dcl (os,bdos) byte public;
$include (vers.lit)
$include (fcb.lit)
$include(search.lit)
dcl find find$structure public initial
(false,false,false,false, false,false,false,false);
dcl
num$search$files byte public initial(0),
no$page$mode byte public initial(0),
search (max$search$files) search$structure public;
dcl first$f$i$adr address external;
dcl get$all$dir$entries boolean public;
dcl first$pass boolean public;
dcl usr$vector address public initial(0), /* bits for user #s to scan */
active$usr$vector address public, /* active users on curdrv */
drv$vector address initial (0); /* bits for drives to scan */
$include (format.lit)
dcl format byte public initial (form$full),
page$len address public initial (0ffffh),
/* lines on a page before printing new headers, 0 forces initial hdrs */
message boolean public initial(false),/* show titles when no files found*/
formfeeds boolean public initial(false),/* use form feeds */
date$opt boolean public initial(false), /* dates display */
display$attributes boolean public initial(false); /* attributes display */
dcl file$displayed boolean external;
/* true if 1 or more files displayed by dsh.plm */
dcl sort$op boolean initial (true); /* default is to do sorting */
dcl sorted boolean external; /* if successful sort */
dcl cur$usr byte public, /* current user being searched */
cur$drv byte public; /* current drive " " */
/* -------- BDOS calls --------- */
get$version: procedure address; /* returns current version information */
return mon2(12,0);
end get$version;
select$drive: procedure(d);
declare d byte;
call mon1(14,d);
end select$drive;
search$first: procedure(d) byte external;
dcl d address;
end search$first;
search$next: procedure byte external;
end search$next;
get$cur$drv: procedure byte; /* return current drive number */
return mon2(25,0);
end get$cur$drv;
getlogin: procedure address; /* get the login vector */
return mon3(24,0);
end getlogin;
getusr: procedure byte; /* return current user number */
return mon2(32,0ffh);
end getusr;
getscbbyte: procedure (offset) byte;
declare offset byte;
declare scbpb structure
(offset byte,
set byte,
value address);
scbpb.offset = offset;
scbpb.set = 0;
return mon2(49,.scbpb);
end getscbbyte;
set$console$mode: procedure;
/* set console mode to control-c only */
call mon1(109,1);
end set$console$mode;
terminate: procedure public;
call mon1 (0,0);
end terminate;
/* -------- Utility routines -------- */
number: procedure (char) boolean;
dcl char byte;
return(char >= '0' and char <= '9');
end number;
make$numeric: procedure(char$adr,len,val$adr) boolean;
dcl (char$adr, val$adr, place) address,
chars based char$adr (1) byte,
value based val$adr address,
(i,len) byte;
value = 0;
place = 1;
do i = 1 to len;
if not number(chars(len - i)) then
return(false);
value = value + (chars(len - i) - '0') * place;
place = place * 10;
end;
return(true);
end make$numeric;
set$vec: procedure(v$adr,num) public;
dcl v$adr address, /* set bit number given by num */
vector based v$adr address, /* 0 <= num <= 15 */
num byte;
if num = 0 then
vector = vector or 1;
else
vector = vector or shl(double(1),num);
end set$vec;
bit$loc: procedure(vector) byte;
/* return location of right most on bit vector */
dcl vector address, /* 0 - 15 */
i byte;
i = 0;
do while i < 16 and (vector and double(1)) = 0;
vector = shr(vector,1);
i = i + 1;
end;
return(i);
end bit$loc;
get$nxt: procedure(vector$adr) byte;
dcl i byte,
(vector$adr,mask) address,
vector based vector$adr address;
/*
if debug then
do; call print(.(cr,lf,'getnxt: vector = $'));
call pdecimal(vector,10000,false);
end;
*/
if (i := bit$loc(vector)) > 15 then
return(0ffh);
mask = 1;
if i > 0 then
mask = shl(mask,i);
vector = vector xor mask; /* turn off bit */
/*
if debug then
do; call print(.(cr,lf,'getnxt: vector, i, mask $'));
call pdecimal(vector,10000,false);
call printb;
call pdecimal(i,10000,false);
call printb;
call pdecimal(mask,10000,false);
end;
*/
return(i);
end get$nxt; /* too bad plm rotates only work on byte values */
/* help: procedure; COMMENTED OUT - HELP PROGRAM REPLACE DISPLAY
call print(.(cr,lf,
tab,tab,tab,'DIR EXAMPLES',cr,lf,lf,
'dir file.one',tab,tab,tab,
'(find a file on current user and default drive)',cr,lf,
'dir *.com d:*.pli',tab,tab,'(find matching files on default and d: drive)',
cr,lf,
'dir [rw]',tab,tab,tab,'(find files that are read/write)',cr,lf,
'dir [ro dir sys]',tab,tab,'(same for read/only, directory, system)',cr,lf,
'dir [xfcb]',tab,tab,tab,'(find files with XFCB''s)',cr,lf,
'dir [nonxfcb]',tab,tab,tab,'(find files without XFCB''s)',cr,lf,
'dir [exclude] *.com',tab,tab,'(find files that don''t end in ''com'')',cr,lf,
'dir [nosort]',tab,tab,tab,'(don''t sort the files)',cr,lf,
'dir [full]',tab,tab,tab,'(show all file information)',cr,lf,
'dir [size]',tab,tab,tab,'(show name and size in kilobytes)',cr,lf,
'dir [short]',tab,tab,tab,'(show just the file names)',cr,lf,
'dir [drive = all]',tab,tab,'(search all logged in drives)',cr,lf,
'dir [drive = (a,b,p)]',tab,tab,
'(search specified drives, ''disk'' is synonym)',cr,lf,
'dir [user = all]',tab,tab,'(find files with any user number)',cr,lf,
'dir [user = (0,1,15), G12]',tab,'(find files with specified user number)',
cr,lf,
'dir [length = n]',tab,tab,'(print headers every n lines)',cr,lf,
'dir [ff]',tab,tab,tab,'(print form feeds between headers)',cr,lf,
'dir [message user=all]',tab,tab,'(show user/drive areas with no files)',
cr,lf,
'dir [help]',tab,tab,tab,'(show this message)',cr,lf,
'dir [dir sys rw ro sort xfcb nonxfcb full] d:*.*',tab,'(defaults)$'));
call terminate;
end help; */
/* -------- Scanner Info -------- */
$include (scan.lit)
dcl pcb pcb$structure
initial (0,.buff(0),.fcb,0,0,0,0) ;
dcl token based pcb.token$adr (12) byte;
dcl got$options boolean;
get$options: procedure;
dcl temp byte;
do while pcb.scan$adr <> 0ffffh and ((pcb.tok$typ and t$op) <> 0);
if pcb.nxt$token <> t$mod then do;
/* options with no modifiers */
if token(1) = 'A' then
display$attributes = true;
else if token(1) = 'D' and token(2) = 'I' then
find.dir = true;
else if token(1) = 'D' and token(2) = 'A' then do;
format = form$full;
date$opt = true;
end;
/*
else if token(1) = 'D' and token(2) = 'E' then
debug = true;
*/
else if token(1) = 'E' then
find.exclude = true;
else if token(1) = 'F'then do;
if token(2) = 'F' then
formfeeds = true;
else if token(2) = 'U' then
format = form$full;
else goto op$err;
end;
else if token(1) = 'G' then
do;
if pcb.token$len < 3 then
temp = token(2) - '0';
else
temp = (token(2) - '0') * 10 + (token(3) - '0');
if temp >= 0 and temp <= 15 then
call set$vec(.usr$vector,temp);
else goto op$err;
end;
/* else if token(1) = 'H' then
call help; */
else if token(1) = 'M' then
message = true;
else if token(1) = 'N' then
do;
if token(4) = 'X' then
find.nonxfcb = true;
else if token(3) = 'P' then
no$page$mode = 0FFh;
else if token(3) = 'S' then
sort$op = false;
else goto op$err;
end;
/* else if token(1) = 'P' then
find.pass = true; */
else if token(1) = 'R' and token(2) = 'O' then
find.ro = true;
else if token(1) = 'R' and token(2) = 'W' then
find.rw = true;
else if token(1) = 'S' then do;
if token(2) = 'Y' then
find.sys = true;
else if token(2) = 'I' then
format = form$size;
else if token(2) = 'O' then
sort$op = true;
else goto op$err;
end;
else if token(1) = 'X' then
find.xfcb = true;
else goto op$err;
call scan(.pcb);
end;
else
do; /* options with modifiers */
if token(1) = 'L' then
do;
call scan(.pcb);
if (pcb.tok$typ and t$numeric) <> 0 then
if make$numeric(.token(1),pcb.token$len,.page$len) then
if page$len < 5 then
goto op$err;
else call scan(.pcb);
else goto op$err;
else goto op$err;
end;
else if token(1) = 'U' then
do;
/*
if debug then
call print(.(cr,lf,'In User option$'));
*/
call scan(.pcb);
if (((pcb.tok$typ and t$mod) = 0) or (bdos < bdos20)) then
goto op$err;
do while (pcb.tok$typ and t$mod) <> 0 and
pcb.scan$adr <> 0ffffh;
if token(1) = 'A' and token(2) = 'L' then
usr$vector = 0ffffh;
else if (pcb.tok$typ and t$numeric) <> 0 and pcb.token$len < 3 then
do;
if pcb.token$len = 1 then
temp = token(1) - '0';
else
temp = (token(1) - '0') * 10 + (token(2) - '0');
if temp >= 0 and temp <= 15 then
call set$vec(.usr$vector,temp);
else goto op$err;
end;
else goto op$err;
call scan(.pcb);
end;
end; /* User option */
else if token(1) = 'D' and (token(2) = 'R' or token(2) = 'I') then
do; /* allow DRIVE or DISK */
call scan(.pcb);
if (pcb.tok$typ and t$mod) = 0 then
goto op$err;
do while (pcb.tok$typ and t$mod ) <> 0 and
pcb.scan$adr <> 0ffffh;
if token(1) = 'A' and token(2) = 'L' then
do;
drv$vector = 0ffffh;
drv$vector = drv$vector and get$login;
end;
else if token(1) >= 'A' and token(1) <= 'P' then
call set$vec(.drv$vector,token(1) - 'A');
else goto op$err;
call scan(.pcb);
end;
end; /* drive option */
else goto op$err;
end; /* options with modifiers */
end; /* do while */
got$options = true;
return;
op$err:
call print(.('ERROR: Illegal Option or Modifier.',
cr,lf,'$'));
call terminate;
end get$options;
get$file$spec: procedure;
dcl i byte;
if num$search$files < max$search$files then
do;
call move(f$namelen + f$typelen,.token(1),
.search(num$search$files).name(0));
if search(num$search$files).name(f$name - 1) = ' ' and
search(num$search$files).name(f$type - 1) = ' ' then
search(num$search$files).anyfile = true; /* match on any file */
else search(num$search$files).anyfile = false;/* speedier compare */
if token(0) = 0 then
search(num$search$files).drv = 0ffh; /* no drive letter with */
else /* file spec */
search(num$search$files).drv = token(0) - 1;
/* 0ffh in drv field indicates to look on all drives that will be */
/* scanned as set by the "drive =" option, see "match:" proc in */
/* search.plm module */
num$search$files = num$search$files + 1;
end;
else
do; call print(.('File Spec Limit is $'));
call p$decimal(max$search$files,100,true);
call crlf;
end;
call scan(.pcb);
end get$file$spec;
set$defaults: procedure;
/* set defaults if not explicitly set by user */
if not (find.dir or find.sys) then
find.dir, find.sys = true;
if not(find.ro or find.rw) then
find.rw, find.ro = true;
if find.xfcb or find.nonxfcb then
do; if format = form$short then
format = form$full;
end;
else /* both xfcb and nonxfcb are off */
find.nonxfcb, find.xfcb = true;
if num$search$files = 0 then
do;
search(num$search$files).anyfile = true;
search(num$search$files).drv = 0ffh;
num$search$files = 1;
end;
if drv$vector = 0 then
do i = 0 to num$search$files - 1;
if search(i).drv = 0ffh then search(i).drv = cur$drv;
call set$vec(.drv$vector,search(i).drv);
end;
else /* a "[drive =" option was found */
do i = 0 to num$search$files - 1;
if search(i).drv <> 0ffh and search(i).drv <> cur$drv then
do; call print(.('ERROR: Illegal Global/Local ',
'Drive Spec Mixing.',cr,lf,'$'));
call terminate;
end;
end;
if usr$vector = 0 then
call set$vec(.usr$vector,get$usr);
/* set up default page size for display */
if bdos > bdos30 then do;
if not formfeeds then do;
if page$len = 0ffffh then do;
page$len = getscbbyte(page$len$offset);
if page$len < 5 then
page$len = 24;
end;
end;
end;
end set$defaults;
dcl (save$uvec,temp) address;
dcl i byte;
declare last$dseg$byte byte
initial (0);
plm:
do;
os = high(get$version);
bdos = low(get$version);
if bdos < bdos30 or os = mpm then do;
call print(.('Requires CP/M 3',cr,lf,'$'));
call terminate; /* check to make sure function call is valid */
end;
else
call set$console$mode;
/* note - initialized declarations set defaults */
cur$drv = get$cur$drv;
call scan$init(.pcb);
call scan(.pcb);
no$page$mode = getscbbyte(nopage$mode$offset);
got$options = false;
do while pcb.scan$adr <> 0ffffh;
if (pcb.tok$typ and t$op) <> 0 then
if got$options = false then
call get$options;
else
do;
call print(.('ERROR: Options not grouped together.',
cr,lf,'$'));
call terminate;
end;
else if (pcb.tok$typ and t$filespec) <> 0 then
call get$file$spec;
else
do;
call print(.('ERROR: Illegal command tail.',cr,lf,'$'));
call terminate;
end;
end;
call set$defaults;
/* main control loop */
call search$init; /* set up memory pointers for subsequent storage */
do while (cur$drv := get$nxt(.drv$vector)) <> 0ffh;
call select$drive(cur$drv);
save$uvec = usr$vector; /* user numbers to search on each drive */
active$usr$vector = 0; /* users active on cur$drv */
cur$usr = get$nxt(.usr$vector); /* get first user num and mask */
get$all$dir$entries = false; /* off it off */
if usr$vector <> 0 and format <> form$short then
/* find high water mark if */
do; /* more than one user requested */
fcb(f$drvusr) = '?';
i = search$first(.fcb); /* get first directory entry */
temp = 0;
do while i <> 255;
temp = temp + 1;
i = search$next;
end; /* is there enough space in the */
/* worst case ? */
if maxb > mult23(temp) + shl(temp,1) then
get$all$dir$entries = true; /* location of last possible */
end; /* file info record and add */
first$pass = true; /* room for sort indices */
active$usr$vector = 0ffffh;
do while cur$usr <> 0ffh;
/*
if debug then
call print(.(cr,lf,'in user loop $'));
*/
call set$vec(.temp,cur$usr);
if (temp and active$usr$vector) <> 0 then
do;
if format <> form$short and
(first$pass or not get$all$dir$entries) then
do;
call get$files; /* collect files in memory and */
first$pass = false; /* build the active usr vector */
sorted = false; /* sort module will set sorted */
if sort$op then /* to true, if successful sort */
call sort;
end;
call display$files;
end;
cur$usr = get$nxt(.usr$vector);
end;
usr$vector = save$uvec; /* restore user vector for nxt */
end; /* do while drv$usr drive scan */
if not file$displayed and not message then
call print(.('No File',cr,lf,'$'));
call terminate;
end;
end sdir;


11
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/MAIN80.PLM Normal file
View File

@@ -0,0 +1,11 @@
$title ('SDIR 8080 - Main Module')
sdir: /* SDIR FOR 8080 */
do;
$include(copyrt.lit)
declare plm label public;
$include(main.plm)


84
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/MCD80A.ASM Normal file
View File

@@ -0,0 +1,84 @@
$title ('COM Externals')
name mcd80a
CSEG
; September 14, 1982
offset equ 0000h
EXTRN PLM
; EXTERNAL ENTRY POINTS
mon1 equ 0005h+offset
mon2 equ 0005h+offset
mon2a equ 0005h+offset
mon3 equ 0005h+offset
public mon1,mon2,mon2a,mon3
; EXTERNAL BASE PAGE DATA LOCATIONS
iobyte equ 0003h+offset
bdisk equ 0004h+offset
maxb equ 0006h+offset
memsiz equ maxb
cmdrv equ 0050h+offset
pass0 equ 0051h+offset
len0 equ 0053h+offset
pass1 equ 0054h+offset
len1 equ 0056h+offset
fcb equ 005ch+offset
fcba equ fcb
sfcb equ fcb
ifcb equ fcb
ifcba equ fcb
fcb16 equ 006ch+offset
dolla equ 006dh+offset
parma equ 006eh+offset
cr equ 007ch+offset
rr equ 007dh+offset
rreca equ rr
ro equ 007fh+offset
rreco equ ro
tbuff equ 0080h+offset
buff equ tbuff
buffa equ tbuff
cpu equ 0 ; 0 = 8080, 1 = 8086/88, 2 = 68000
public iobyte,bdisk,maxb,memsiz
public cmdrv,pass0,len0,pass1,len1
public fcb,fcba,sfcb,ifcb,ifcba,fcb16
public cr,rr,rreca,ro,rreco,dolla,parma
public buff,tbuff,buffa, cpu
;*******************************************************
; The interface should proceed the program
; so that TRINT becomes the entry point for the
; COM file. The stack is set and memsiz is set
; to the top of memory. Program termination is done
; with a return to preserve R/O diskettes.
;*******************************************************
; EXECUTION BEGINS HERE
lxi sp, stack
JMP PLM
; PATCH AREA, DATE, VERSION & SERIAL NOS.
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0
db 'CP/M Version 3.0'
db 'COPYRIGHT 1982, '
db 'DIGITAL RESEARCH'
db '151282' ; version date day-month-year
db 0,0,0,0 ; patch bit map
db '654321' ; Serial no.
END
EOF


92
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/MCD80F.ASM Normal file
View File

@@ -0,0 +1,92 @@
$title ('COM Externals')
name mcd80b
CSEG
; August 2, 1982
offset equ 0000h
EXTRN PLM
; EXTERNAL ENTRY POINTS
mon1 equ 0005h+offset
mon2 equ 0005h+offset
mon2a equ 0005h+offset
mon3 equ 0005h+offset
public mon1,mon2,mon2a,mon3
; EXTERNAL BASE PAGE DATA LOCATIONS
iobyte equ 0003h+offset
bdisk equ 0004h+offset
maxb equ 0006h+offset
memsiz equ maxb
cmdrv equ 0050h+offset
pass0 equ 0051h+offset
len0 equ 0053h+offset
pass1 equ 0054h+offset
len1 equ 0056h+offset
fcb equ 005ch+offset
fcba equ fcb
sfcb equ fcb
ifcb equ fcb
ifcba equ fcb
fcb16 equ 006ch+offset
dolla equ 006dh+offset
parma equ 006eh+offset
cr equ 007ch+offset
rr equ 007dh+offset
rreca equ rr
ro equ 007fh+offset
rreco equ ro
tbuff equ 0080h+offset
buff equ tbuff
buffa equ tbuff
cpu equ 0 ; 0 = 8080, 1 = 8086/88, 2 = 68000
public iobyte,bdisk,maxb,memsiz
public cmdrv,pass0,len0,pass1,len1
public fcb,fcba,sfcb,ifcb,ifcba,fcb16
public cr,rr,rreca,ro,rreco,dolla,parma
public buff,tbuff,buffa,cpu,reset
;*******************************************************
; The interface should proceed the program
; so that TRINT becomes the entry point for the
; COM file. The stack is set and memsiz is set
; to the top of memory.
;*******************************************************
bdos equ mon1
getalv equ 27
getdpb equ 31
; EXECUTION BEGINS HERE
reset:
trint:
lxi sp, stack
call plm ; call program
mvi c,0
call bdos
; PATCH AREA, DATE, VERSION & SERIAL NOS.
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
dw 0,0
db 0
db 'CP/M Version 3.0'
db 'COPYRIGHT 1982, '
db 'DIGITAL RESEARCH'
db '151282' ; version date day-month-year
db 0,0,0,0 ; patch bit map
db '654321' ; Serial no.
END
EOF


20
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/MON.PLM Normal file
View File

@@ -0,0 +1,20 @@
/* definitions for assembly interface module */
declare
fcb (33) byte external, /* default file control block */
maxb address external, /* top of memory */
buff(128)byte external; /* default buffer */
mon1: procedure(f,a) external;
declare f byte, a address;
end mon1;
mon2: procedure(f,a) byte external;
declare f byte, a address;
end mon2;
mon3: procedure(f,a) address external;
declare f byte, a address;
end mon3;


127
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/OS1BOOT.ASM Normal file
View File

@@ -0,0 +1,127 @@
title 'mds cold start loader at 3000h'
;
; MDS-800 Cold Start Loader for CP/M 2.0
;
; Version 2.0 August, 1979
;
false equ 0
true equ not false
testing equ false ;if true, then go to mon80 on errors
;
if testing
bias equ 03400h
endif
if not testing
bias equ 0000h
endif
cpmb equ bias ;base of dos load
bdos equ 806h+bias ;entry to dos for calls
bdose equ 1880h+bias ;end of dos load
boot equ 1600h+bias ;cold start entry point
rboot equ boot+3 ;warm start entry point
;
org 03000h ;loaded down from hardware boot at 3000h
;
bdosl equ bdose-cpmb
ntrks equ 2 ;number of tracks to read
bdoss equ bdosl/128 ;number of sectors in dos
bdos0 equ 25 ;number of bdos sectors on track 0
bdos1 equ bdoss-bdos0 ;number of sectors on track 1
;
mon80 equ 0f800h ;intel monitor base
rmon80 equ 0ff0fh ;restart location for mon80
base equ 078h ;'base' used by controller
rtype equ base+1 ;result type
rbyte equ base+3 ;result byte
reset equ base+7 ;reset controller
;
dstat equ base ;disk status port
ilow equ base+1 ;low iopb address
ihigh equ base+2 ;high iopb address
bsw equ 0ffh ;boot switch
recal equ 3h ;recalibrate selected drive
readf equ 4h ;disk read function
stack equ 100h ;use end of boot for stack
;
rstart:
lxi sp,stack;in case of call to mon80
; clear disk status
in rtype
in rbyte
; check if boot switch is off
coldstart:
in bsw
ani 02h ;switch on?
jnz coldstart
; clear the controller
out reset ;logic cleared
;
;
mvi b,ntrks ;number of tracks to read
lxi h,iopb0
;
start:
;
; read first/next track into cpmb
mov a,l
out ilow
mov a,h
out ihigh
wait0: in dstat
ani 4
jz wait0
;
; check disk status
in rtype
ani 11b
cpi 2
;
if testing
cnc rmon80 ;go to monitor if 11 or 10
endif
if not testing
jnc rstart ;retry the load
endif
;
in rbyte ;i/o complete, check status
; if not ready, then go to mon80
ral
cc rmon80 ;not ready bit set
rar ;restore
ani 11110b ;overrun/addr err/seek/crc/xxxx
;
if testing
cnz rmon80 ;go to monitor
endif
if not testing
jnz rstart ;retry the load
endif
;
;
lxi d,iopbl ;length of iopb
dad d ;addressing next iopb
dcr b ;count down tracks
jnz start
;
;
; jmp to boot to print initial message, and set up jmps
jmp boot
;
; parameter blocks
iopb0: db 80h ;iocw, no update
db readf ;read function
db bdos0 ;# sectors to read on track 0
db 0 ;track 0
db 2 ;start with sector 2 on track 0
dw cpmb ;start at base of bdos
iopbl equ $-iopb0
;
iopb1: db 80h
db readf
db bdos1 ;sectors to read on track 1
db 1 ;track 1
db 1 ;sector 1
dw cpmb+bdos0*128 ;base of second read
;
end


831
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/OS2CCP.ASM Normal file
View File

@@ -0,0 +1,831 @@
title 'console command processor (CCP), ver 2.0'
; assembly language version of the CP/M console command processor
;
; version 2.2 February, 1980
;
; Copyright (c) 1976, 1977, 1978, 1979, 1980
; Digital Research
; Box 579, Pacific Grove,
; California, 93950
;
false equ 0000h
true equ not false
testing equ false ;true if debugging
;
;
if testing
org 3400h
bdosl equ $+800h ;bdos location
else
org 000h
bdosl equ $+800h ;bdos location
endif
tran equ 100h
tranm equ $
ccploc equ $
;
; ********************************************************
; * Base of CCP contains the following code/data *
; * ccp: jmp ccpstart (start with command) *
; * jmp ccpclear (start, clear command) *
; * ccp+6 127 (max command length) *
; * ccp+7 comlen (command length = 00) *
; * ccp+8 ' ... ' (16 blanks) *
; ********************************************************
; * Normal entry is at ccp, where the command line given *
; * at ccp+8 is executed automatically (normally a null *
; * command with comlen = 00). An initializing program *
; * can be automatically loaded by storing the command *
; * at ccp+8, with the command length at ccp+7. In this *
; * case, the ccp executes the command before prompting *
; * the console for input. Note that the command is exe-*
; * cuted on both warm and cold starts. When the command*
; * line is initialized, a jump to "jmp ccpclear" dis- *
; * ables the automatic command execution. *
; ********************************************************
;
jmp ccpstart ;start ccp with possible initial command
jmp ccpclear ;clear the command buffer
maxlen: db 127 ;max buffer length
comlen: db 0 ;command length (filled in by dos)
; (command executed initially if comlen non zero)
combuf:
db ' ' ;8 character fill
db ' ' ;8 character fill
db 'COPYRIGHT (C) 1979, DIGITAL RESEARCH '; 38
ds 128-($-combuf)
; total buffer length is 128 characters
comaddr:dw combuf ;address of next to char to scan
staddr: ds 2 ;starting address of current fillfcb request
;
diska equ 0004h ;disk address for current disk
bdos equ 0005h ;primary bdos entry point
buff equ 0080h ;default buffer
fcb equ 005ch ;default file control block
;
rcharf equ 1 ;read character function
pcharf equ 2 ;print character function
pbuff equ 9 ;print buffer function
rbuff equ 10 ;read buffer function
breakf equ 11 ;break key function
liftf equ 12 ;lift head function (no operation)
initf equ 13 ;initialize bdos function
self equ 14 ;select disk function
openf equ 15 ;open file function
closef equ 16 ;close file function
searf equ 17 ;search for file function
searnf equ 18 ;search for next file function
delf equ 19 ;delete file function
dreadf equ 20 ;disk read function
dwritf equ 21 ;disk write function
makef equ 22 ;file make function
renf equ 23 ;rename file function
logf equ 24 ;return login vector
cself equ 25 ;return currently selected drive number
dmaf equ 26 ;set dma address
userf equ 32 ;set user number
;
; special fcb flags
rofile equ 9 ;read only file
sysfile equ 10 ;system file flag
;
; special characters
cr equ 13 ;carriage return
lf equ 10 ;line feed
la equ 5fh ;left arrow
eofile equ 1ah ;end of file
;
; utility procedures
printchar:
mov e,a! mvi c,pcharf! jmp bdos
;
printbc:
;print character, but save b,c registers
push b! call printchar! pop b! ret
;
crlf:
mvi a,cr! call printbc
mvi a,lf! jmp printbc
;
blank:
mvi a,' '! jmp printbc
;
print: ;print string starting at b,c until next 00 entry
push b! call crlf! pop h ;now print the string
prin0: mov a,m! ora a! rz ;stop on 00
inx h! push h ;ready for next
call printchar! pop h ;character printed
jmp prin0 ;for another character
;
initialize:
mvi c,initf! jmp bdos
;
select:
mov e,a! mvi c,self! jmp bdos
;
bdos$inr:
call bdos! sta dcnt! inr a! ret
;
open: ;open the file given by d,e
mvi c,openf! jmp bdos$inr
;
openc: ;open comfcb
xra a! sta comrec ;clear next record to read
lxi d,comfcb! jmp open
;
close: ;close the file given by d,e
mvi c,closef! jmp bdos$inr
;
search: ;search for the file given by d,e
mvi c,searf! jmp bdos$inr
;
searchn:
;search for the next occurrence of the file given by d,e
mvi c,searnf! jmp bdos$inr
;
searchcom:
;search for comfcb file
lxi d,comfcb! jmp search
;
delete: ;delete the file given by d,e
mvi c,delf! jmp bdos
;
bdos$cond:
call bdos! ora a! ret
;
diskread:
;read the next record from the file given by d,e
mvi c,dreadf! jmp bdos$cond
;
diskreadc:
;read the comfcb file
lxi d,comfcb! jmp diskread
;
diskwrite:
;write the next record to the file given by d,e
mvi c,dwritf! jmp bdos$cond
;
make: ;create the file given by d,e
mvi c,makef! jmp bdos$inr
;
renam: ;rename the file given by d,e
mvi c,renf! jmp bdos
;
getuser:
;return current user code in a
mvi e,0ffh ;drop through to setuser
;
setuser:
mvi c,userf! jmp bdos ;sets user number
;
saveuser:
;save user#/disk# before possible ^c or transient
call getuser ;code to a
add a! add a! add a! add a ;rot left
lxi h,cdisk! ora m ;4b=user, 4b=disk
sta diska ;stored away in memory for later
ret
;
setdiska:
lda cdisk! sta diska ;user/disk
ret
;
translate:
;translate character in register A to upper case
cpi 61h! rc ;return if below lower case a
cpi 7bh! rnc ;return if above lower case z
ani 5fh! ret ;translated to upper case
;
readcom:
;read the next command into the command buffer
;check for submit file
lda submit! ora a! jz nosub
;scanning a submit file
;change drives to open and read the file
lda cdisk! ora a! mvi a,0! cnz select
;have to open again in case xsub present
lxi d,subfcb! call open! jz nosub ;skip if no sub
lda subrc! dcr a ;read last record(s) first
sta subcr ;current record to read
lxi d,subfcb! call diskread ;end of file if last record
jnz nosub
;disk read is ok, transfer to combuf
lxi d,comlen! lxi h,buff! mvi b,128! call move0
;line is transferred, close the file with a
;deleted record
lxi h,submod! mvi m,0 ;clear fwflag
inx h! dcr m ;one less record
lxi d,subfcb! call close! jz nosub
;close went ok, return to original drive
lda cdisk! ora a! cnz select
;print to the 00
lxi h,combuf! call prin0
call break$key! jz noread
call del$sub! jmp ccp ;break key depressed
;
nosub: ;no submit file! call del$sub
;translate to upper case, store zero at end
call saveuser ;user # save in case control c
mvi c,rbuff! lxi d,maxlen! call bdos
call setdiska ;no control c, so restore diska
noread: ;enter here from submit file
;set the last character to zero for later scans
lxi h,comlen! mov b,m ;length is in b
readcom0: inx h! mov a,b! ora a ;end of scan?
jz readcom1! mov a,m ;get character and translate
call translate! mov m,a! dcr b! jmp readcom0
;
readcom1: ;end of scan, h,l address end of command
mov m,a ;store a zero
lxi h,combuf! shld comaddr ;ready to scan to zero
ret
;
break$key:
;check for a character ready at the console
mvi c,breakf! call bdos
ora a! rz
mvi c,rcharf! call bdos ;character cleared
ora a! ret
;
cselect:
;get the currently selected drive number to reg-A
mvi c,cself! jmp bdos
;
setdmabuff:
;set default buffer dma address
lxi d,buff ;(drop through)
;
setdma:
;set dma address to d,e
mvi c,dmaf! jmp bdos
;
del$sub:
;delete the submit file, and set submit flag to false
lxi h,submit! mov a,m! ora a! rz ;return if no sub file
mvi m,0 ;submit flag is set to false
xra a! call select ;on drive a to erase file
lxi d,subfcb! call delete
lda cdisk! jmp select ;back to original drive
;
serialize:
;check serialization
lxi d,serial! lxi h,bdosl! mvi b,6 ;check six bytes
ser0: ldax d! cmp m! jnz badserial
inx d! inx h! dcr b! jnz ser0
ret ;serial number is ok
;
comerr:
;error in command string starting at position
;'staddr' and ending with first delimiter
call crlf ;space to next line
lhld staddr ;h,l address first to print
comerr0: ;print characters until blank or zero
mov a,m! cpi ' '! jz comerr1; not blank
ora a! jz comerr1; not zero, so print it
push h! call printchar! pop h! inx h
jmp comerr0; for another character
comerr1: ;print question mark,and delete sub file
mvi a,'?'! call printchar
call crlf! call del$sub
jmp ccp ;restart with next command
;
; fcb scan and fill subroutine (entry is at fillfcb below)
;fill the comfcb, indexed by A (0 or 16)
;subroutines
delim: ;look for a delimiter
ldax d! ora a! rz ;not the last element
cpi ' '! jc comerr ;non graphic
rz ;treat blank as delimiter
cpi '='! rz
cpi la! rz ;left arrow
cpi '.'! rz
cpi ':'! rz
cpi ';'! rz
cpi '<'! rz
cpi '>'! rz
ret ;delimiter not found
;
deblank: ;deblank the input line
ldax d! ora a! rz ;treat end of line as blank
cpi ' '! rnz! inx d! jmp deblank
;
addh: ;add a to h,l
add l! mov l,a! rnc
inr h! ret
;
fillfcb0:
;equivalent to fillfcb(0)
mvi a,0
;
fillfcb:
lxi h,comfcb! call addh! push h! push h ;fcb rescanned at end
xra a! sta sdisk ;clear selected disk (in case A:...)
lhld comaddr! xchg ;command address in d,e
call deblank ;to first non-blank character
xchg! shld staddr ;in case of errors
xchg! pop h ;d,e has command, h,l has fcb address
;look for preceding file name A: B: ...
ldax d! ora a! jz setcur0 ;use current disk if empty command
sbi 'A'-1! mov b,a ;disk name held in b if : follows
inx d! ldax d! cpi ':'! jz setdsk ;set disk name if :
;
setcur: ;set current disk
dcx d ;back to first character of command
setcur0:
lda cdisk! mov m,a! jmp setname
;
setdsk: ;set disk to name in register b
mov a,b! sta sdisk ;mark as disk selected
mov m,b! inx d ;past the :
;
setname: ;set the file name field
mvi b,8 ;file name length (max)
setnam0: call delim! jz padname ;not a delimiter
inx h! cpi '*'! jnz setnam1 ;must be ?'s
mvi m,'?'! jmp setnam2 ;to dec count
;
setnam1: mov m,a ;store character to fcb! inx d
setnam2: dcr b ;count down length! jnz setnam0
;
;end of name, truncate remainder
trname: call delim! jz setty ;set type field if delimiter
inx d! jmp trname
;
padname: inx h! mvi m,' '! dcr b! jnz padname
;
setty: ;set the type field
mvi b,3! cpi '.'! jnz padty ;skip the type field if no .
inx d ;past the ., to the file type field
setty0: ;set the field from the command buffer
call delim! jz padty! inx h! cpi '*'! jnz setty1
mvi m,'?' ;since * specified! jmp setty2
;
setty1: ;not a *, so copy to type field
mov m,a! inx d
setty2: ;decrement count and go again
dcr b! jnz setty0
;
;end of type field, truncate
trtyp: ;truncate type field
call delim! jz efill! inx d! jmp trtyp
;
padty: ;pad the type field with blanks
inx h! mvi m,' '! dcr b! jnz padty
;
efill: ;end of the filename/filetype fill, save command address
;fill the remaining fields for the fcb
mvi b,3
efill0: inx h! mvi m,0! dcr b! jnz efill0
xchg! shld comaddr ;set new starting point
;
;recover the start address of the fcb and count ?'s
pop h! lxi b,11 ;b=0, c=8+3
scnq: inx h! mov a,m! cpi '?'! jnz scnq0
;? found, count it in b! inr b
scnq0: dcr c! jnz scnq
;
;number of ?'s in c, move to a and return with flags set
mov a,b! ora a! ret
;
intvec:
;intrinsic function names (all are four characters)
db 'DIR '
db 'ERA '
db 'TYPE'
db 'SAVE'
db 'REN '
db 'USER'
intlen equ ($-intvec)/4 ;intrinsic function length
serial: db 0,0,0,0,0,0
;
;
intrinsic:
;look for intrinsic functions (comfcb has been filled)
lxi h,intvec! mvi c,0 ;c counts intrinsics as scanned
intrin0: mov a,c! cpi intlen ;done with scan?! rnc
;no, more to scan
lxi d,comfcb+1 ;beginning of name
mvi b,4 ;length of match is in b
intrin1: ldax d! cmp m ;match?
jnz intrin2 ;skip if no match
inx d! inx h! dcr b
jnz intrin1 ;loop while matching
;
;complete match on name, check for blank in fcb
ldax d! cpi ' '! jnz intrin3 ;otherwise matched
mov a,c! ret ;with intrinsic number in a
;
intrin2: ;mismatch, move to end of intrinsic
inx h! dcr b! jnz intrin2
;
intrin3: ;try next intrinsic
inr c ;to next intrinsic number
jmp intrin0 ;for another round
;
ccpclear:
;clear the command buffer
xra a
sta comlen
;drop through to start ccp
ccpstart:
;enter here from boot loader
lxi sp,stack! push b ;save initial disk number
;(high order 4bits=user code, low 4bits=disk#)
mov a,c! rar! rar! rar! rar! ani 0fh ;user code
mov e,a! call setuser ;user code selected
;initialize for this user, get $ flag
call initialize ;0ffh in accum if $ file present
sta submit ;submit flag set if $ file present
pop b ;recall user code and disk number
mov a,c! ani 0fh ;disk number in accumulator
sta cdisk ;clears user code nibble
call select ;proper disk is selected, now check sub files
;check for initial command
lda comlen! ora a! jnz ccp0 ;assume typed already
;
ccp:
;enter here on each command or error condition
lxi sp,stack
call crlf ;print d> prompt, where d is disk name
call cselect ;get current disk number
adi 'A'! call printchar
mvi a,'>'! call printchar
call readcom ;command buffer filled
ccp0: ;(enter here from initialization with command full)
lxi d,buff! call setdma ;default dma address at buff
call cselect! sta cdisk ;current disk number saved
call fillfcb0 ;command fcb filled
cnz comerr ;the name cannot be an ambiguous reference
lda sdisk! ora a! jnz userfunc
;check for an intrinsic function
call intrinsic
lxi h,jmptab ;index is in the accumulator
mov e,a! mvi d,0! dad d! dad d ;index in d,e
mov a,m! inx h! mov h,m! mov l,a! pchl
;pc changes to the proper intrinsic or user function
jmptab:
dw direct ;directory search
dw erase ;file erase
dw type ;type file
dw save ;save memory image
dw rename ;file rename
dw user ;user number
dw userfunc;user-defined function
badserial:
lxi h,di or (hlt shl 8)
shld ccploc! lxi h,ccploc! pchl
;
;
;utility subroutines for intrinsic handlers
readerr:
;print the read error message
lxi b,rdmsg! jmp print
rdmsg: db 'READ ERROR',0
;
nofile:
;print no file message
lxi b,nofmsg! jmp print
nofmsg: db 'NO FILE',0
;
getnumber: ;read a number from the command line
call fillfcb0 ;should be number
lda sdisk! ora a! jnz comerr ;cannot be prefixed
;convert the byte value in comfcb to binary
lxi h,comfcb+1! lxi b,11 ;(b=0, c=11)
;value accumulated in b, c counts name length to zero
conv0: mov a,m! cpi ' '! jz conv1
;more to scan, convert char to binary and add
inx h! sui '0'! cpi 10! jnc comerr ;valid?
mov d,a ;save value! mov a,b ;mult by 10
ani 1110$0000b! jnz comerr
mov a,b ;recover value
rlc! rlc! rlc ;*8
add b! jc comerr
add b! jc comerr ;*8+*2 = *10
add d! jc comerr ;+digit
mov b,a! dcr c! jnz conv0 ;for another digit
ret
conv1: ;end of digits, check for all blanks
mov a,m! cpi ' '! jnz comerr ;blanks?
inx h! dcr c! jnz conv1
mov a,b ;recover value! ret
;
movename:
;move 3 characters from h,l to d,e addresses
mvi b,3
move0: mov a,m! stax d! inx h! inx d
dcr b! jnz move0
ret
;
addhcf: ;buff + a + c to h,l followed by fetch
lxi h,buff! add c! call addh! mov a,m! ret
;
setdisk:
;change disks for this command, if requested
xra a! sta comfcb ;clear disk name from fcb
lda sdisk! ora a! rz ;no action if not specified
dcr a! lxi h,cdisk! cmp m! rz ;already selected
jmp select
;
resetdisk:
;return to original disk after command
lda sdisk! ora a! rz ;no action if not selected
dcr a! lxi h,cdisk! cmp m! rz ;same disk
lda cdisk! jmp select
;
;individual intrinsics follow
direct:
;directory search
call fillfcb0 ;comfcb gets file name
call setdisk ;change disk drives if requested
lxi h,comfcb+1! mov a,m ;may be empty request
cpi ' '! jnz dir1 ;skip fill of ??? if not blank
;set comfcb to all ??? for current disk
mvi b,11 ;length of fill ????????.???
dir0: mvi m,'?'! inx h! dcr b! jnz dir0
;not a blank request, must be in comfcb
dir1: mvi e,0! push d ;E counts directory entries
call searchcom ;first one has been found
cz nofile ;not found message
dir2: jz endir
;found, but may be system file
lda dcnt ;get the location of the element
rrc! rrc! rrc! ani 110$0000b! mov c,a
;c contains base index into buff for dir entry
mvi a,sysfile! call addhcf ;value to A
ral! jc dir6 ;skip if system file
;c holds index into buffer
;another fcb found, new line?
pop d! mov a,e! inr e! push d
;e=0,1,2,3,...new line if mod 4 = 0
ani 11b! push psw ;and save the test
jnz dirhdr0 ;header on current line
call crlf
push b! call cselect! pop b
;current disk in A
adi 'A'! call printbc
mvi a,':'! call printbc
jmp dirhdr1 ;skip current line hdr
dirhdr0:call blank ;after last one
mvi a,':'! call printbc
dirhdr1:
call blank
;compute position of name in buffer
mvi b,1 ;start with first character of name
dir3: mov a,b! call addhcf ;buff+a+c fetched
ani 7fh ;mask flags
;may delete trailing blanks
cpi ' '! jnz dir4 ;check for blank type
pop psw! push psw ;may be 3rd item
cpi 3! jnz dirb ;place blank at end if not
mvi a,9! call addhcf ;first char of type
ani 7fh! cpi ' '! jz dir5
;not a blank in the file type field
dirb: mvi a,' ' ;restore trailing filename chr
dir4:
call printbc ;char printed
inr b! mov a,b! cpi 12! jnc dir5
;check for break between names
cpi 9! jnz dir3 ;for another char
;print a blank between names
call blank! jmp dir3
;
dir5: ;end of current entry
pop psw ;discard the directory counter (mod 4)
dir6: call break$key ;check for interrupt at keyboard
jnz endir ;abort directory search
call searchn! jmp dir2 ;for another entry
endir: ;end of directory scan
pop d ;discard directory counter
jmp retcom
;
;
erase:
call fillfcb0 ;cannot be all ???'s
cpi 11
jnz erasefile
;erasing all of the disk
lxi b,ermsg! call print!
call readcom
lxi h,comlen! dcr m! jnz ccp ;bad input
inx h! mov a,m! cpi 'Y'! jnz ccp
;ok, erase the entire diskette
inx h! shld comaddr ;otherwise error at retcom
erasefile:
call setdisk
lxi d,comfcb! call delete
inr a ;255 returned if not found
cz nofile ;no file message if so
jmp retcom
;
ermsg: db 'ALL (Y/N)?',0
;
type:
call fillfcb0! jnz comerr ;don't allow ?'s in file name
call setdisk! call openc ;open the file
jz typerr ;zero flag indicates not found
;file opened, read 'til eof
call crlf! lxi h,bptr! mvi m,255 ;read first buffer
type0: ;loop on bptr
lxi h,bptr! mov a,m! cpi 128 ;end buffer
jc type1! push h ;carry if 0,1,...,127
;read another buffer full
call diskreadc! pop h ;recover address of bptr
jnz typeof ;hard end of file
xra a! mov m,a ;bptr = 0
type1: ;read character at bptr and print
inr m ;bptr = bptr + 1
lxi h,buff! call addh ;h,l addresses char
mov a,m! cpi eofile! jz retcom
call printchar
call break$key! jnz retcom ;abort if break
jmp type0 ;for another character
;
typeof: ;end of file, check for errors
dcr a! jz retcom
call readerr
typerr: call resetdisk! jmp comerr
;
save:
call getnumber; value to register a
push psw ;save it for later
;
;should be followed by a file to save the memory image
call fillfcb0
jnz comerr ;cannot be ambiguous
call setdisk ;may be a disk change
lxi d,comfcb! push d! call delete ;existing file removed
pop d! call make ;create a new file on disk
jz saverr ;no directory space
xra a! sta comrec; clear next record field
pop psw ;#pages to write is in a, change to #sectors
mov l,a! mvi h,0! dad h!
lxi d,tran ;h,l is sector count, d,e is load address
save0: ;check for sector count zero
mov a,h! ora l! jz save1 ;may be completed
dcx h ;sector count = sector count - 1
push h ;save it for next time around
lxi h,128! dad d! push h ;next dma address saved
call setdma ;current dma address set
lxi d,comfcb! call diskwrite
pop d! pop h ;dma address, sector count
jnz saverr ;may be disk full case
jmp save0 ;for another sector
;
save1: ;end of dump, close the file
lxi d,comfcb! call close
inr a; 255 becomes 00 if error
jnz retsave ;for another command
saverr: ;must be full or read only disk
lxi b,fullmsg! call print
retsave:
;reset dma buffer
call setdmabuff
jmp retcom
fullmsg: db 'NO SPACE',0
;
;
rename:
;rename a file on a specific disk
call fillfcb0! jnz comerr ;must be unambiguous
lda sdisk! push psw ;save for later compare
call setdisk ;disk selected
call searchcom ;is new name already there?
jnz renerr3
;file doesn't exist, move to second half of fcb
lxi h,comfcb! lxi d,comfcb+16! mvi b,16! call move0
;check for = or left arrow
lhld comaddr! xchg! call deblank
cpi '='! jz ren1 ;ok if =
cpi la! jnz renerr2
ren1: xchg! inx h! shld comaddr ;past delimiter
;proper delimiter found
call fillfcb0! jnz renerr2
;check for drive conflict
pop psw! mov b,a ;previous drive number
lxi h,sdisk! mov a,m! ora a! jz ren2
;drive name was specified. same one?
cmp b! mov m,b! jnz renerr2
ren2: mov m,b ;store the name in case drives switched
xra a! sta comfcb! call searchcom ;is old file there?
jz renerr1
;
;everything is ok, rename the file
lxi d,comfcb! call renam
jmp retcom
;
renerr1:; no file on disk
call nofile! jmp retcom
renerr2:; ambigous reference/name conflict
call resetdisk! jmp comerr
renerr3:; file already exists
lxi b,renmsg! call print! jmp retcom
renmsg: db 'FILE EXISTS',0
;
user:
;set user number
call getnumber; leaves the value in the accumulator
cpi 16! jnc comerr; must be between 0 and 15
mov e,a ;save for setuser call
lda comfcb+1! cpi ' '! jz comerr
call setuser ;new user number set
jmp endcom
;
userfunc:
call serialize ;check serialization
;load user function and set up for execution
lda comfcb+1! cpi ' '! jnz user0
;no file name, but may be disk switch
lda sdisk! ora a! jz endcom ;no disk name if 0
dcr a! sta cdisk! call setdiska ;set user/disk
call select! jmp endcom
user0: ;file name is present
lxi d,comfcb+9! ldax d! cpi ' '! jnz comerr ;type ' '
push d! call setdisk! pop d! lxi h,comtype ;.com
call movename ;file type is set to .com
call openc! jz userer
;file opened properly, read it into memory
lxi h,tran ;transient program base
load0: push h ;save dma address
xchg! call setdma
lxi d,comfcb! call diskread! jnz load1
;sector loaded, set new dma address and compare
pop h! lxi d,128! dad d
lxi d,tranm ;has the load overflowed?
mov a,l! sub e! mov a,h! sbb d! jnc loaderr
jmp load0 ;for another sector
;
load1: pop h! dcr a! jnz loaderr ;end file is 1
call resetdisk ;back to original disk
call fillfcb0! lxi h,sdisk! push h
mov a,m! sta comfcb ;drive number set
mvi a,16! call fillfcb ;move entire fcb to memory
pop h! mov a,m! sta comfcb+16
xra a! sta comrec ;record number set to zero
lxi d,fcb! lxi h,comfcb! mvi b,33! call move0
;move command line to buff
lxi h,combuf
bmove0: mov a,m! ora a! jz bmove1! cpi ' '! jz bmove1
inx h! jmp bmove0 ;for another scan
;first blank position found
bmove1: mvi b,0! lxi d,buff+1! ;ready for the move
bmove2: mov a,m! stax d! ora a! jz bmove3
;more to move
inr b! inx h! inx d! jmp bmove2
bmove3: ;b has character count
mov a,b! sta buff
call crlf
;now go to the loaded program
call setdmabuff ;default dma
call saveuser ;user code saved
;low memory diska contains user code
call tran ;gone to the loaded program
lxi sp,stack ;may come back here
call setdiska! call select
jmp ccp
;
userer: ;arrive here on command error
call resetdisk! jmp comerr
;
loaderr:;cannot load the program
lxi b,loadmsg! call print
jmp retcom
loadmsg: db 'BAD LOAD',0
comtype: db 'COM' ;for com files
;
;
retcom: ;reset disk before end of command check
call resetdisk
;
endcom: ;end of intrinsic command
call fillfcb0 ;to check for garbage at end of line
lda comfcb+1! sui ' '! lxi h,sdisk! ora m
;0 in accumulator if no disk selected, and blank fcb
jnz comerr
jmp ccp
;
;
;
; data areas
ds 16 ;8 level stack
stack:
;
; 'submit' file control block
submit: db 0 ;00 if no submit file, ff if submitting
subfcb: db 0,'$$$ ' ;file name is $$$
db 'SUB',0,0 ;file type is sub
submod: db 0 ;module number
subrc: ds 1 ;record count filed
ds 16 ;disk map
subcr: ds 1 ;current record to read
;
; command file control block
comfcb: ds 32 ;fields filled in later
comrec: ds 1 ;current record to read/write
dcnt: ds 1 ;disk directory count (used for error codes)
cdisk: ds 1 ;current disk
sdisk: ds 1 ;selected disk for current operation
;none=0, a=1, b=2 ...
bptr: ds 1 ;buffer pointer
end ccploc


2179
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/OS3BDOS.ASM Normal file
View File

File diff suppressed because it is too large Load Diff

505
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/OS4BIOS.ASM Normal file
View File

@@ -0,0 +1,505 @@
; MDS-800 I/O Drivers for CP/M 2.2
; (four drive single density version)
;
; Version 2.2 February, 1980
;
vers equ 22 ;version 2.2
;
; Copyright (c) 1980
; Digital Research
; Box 579, Pacific Grove
; California, 93950
;
;
true equ 0ffffh ;value of "true"
false equ not true ;"false"
test equ false ;true if test bios
;
if test
bias equ 03400h ;base of CCP in test system
endif
if not test
bias equ 0000h ;generate relocatable cp/m system
endif
;
patch equ 1600h
;
org patch
cpmb equ $-patch ;base of cpm console processor
bdos equ 806h+cpmb ;basic dos (resident portion)
cpml equ $-cpmb ;length (in bytes) of cpm system
nsects equ cpml/128 ;number of sectors to load
offset equ 2 ;number of disk tracks used by cp/m
cdisk equ 0004h ;address of last logged disk on warm start
buff equ 0080h ;default buffer address
retry equ 10 ;max retries on disk i/o before error
;
; perform following functions
; boot cold start
; wboot warm start (save i/o byte)
; (boot and wboot are the same for mds)
; const console status
; reg-a = 00 if no character ready
; reg-a = ff if character ready
; conin console character in (result in reg-a)
; conout console character out (char in reg-c)
; list list out (char in reg-c)
; punch punch out (char in reg-c)
; reader paper tape reader in (result to reg-a)
; home move to track 00
;
; (the following calls set-up the io parameter block for the
; mds, which is used to perform subsequent reads and writes)
; seldsk select disk given by reg-c (0,1,2...)
; settrk set track address (0,...76) for subsequent read/write
; setsec set sector address (1,...,26) for subsequent read/write
; setdma set subsequent dma address (initially 80h)
;
; (read and write assume previous calls to set up the io parameters)
; read read track/sector to preset dma address
; write write track/sector from preset dma address
;
; jump vector for indiviual routines
jmp boot
wboote: jmp wboot
jmp const
jmp conin
jmp conout
jmp list
jmp punch
jmp reader
jmp home
jmp seldsk
jmp settrk
jmp setsec
jmp setdma
jmp read
jmp write
jmp listst ;list status
jmp sectran
;
maclib diskdef ;load the disk definition library
disks 4 ;four disks
diskdef 0,1,26,6,1024,243,64,64,offset
diskdef 1,0
diskdef 2,0
diskdef 3,0
; endef occurs at end of assembly
;
; end of controller - independent code, the remaining subroutines
; are tailored to the particular operating environment, and must
; be altered for any system which differs from the intel mds.
;
; the following code assumes the mds monitor exists at 0f800h
; and uses the i/o subroutines within the monitor
;
; we also assume the mds system has four disk drives
revrt equ 0fdh ;interrupt revert port
intc equ 0fch ;interrupt mask port
icon equ 0f3h ;interrupt control port
inte equ 0111$1110b ;enable rst 0(warm boot), rst 7 (monitor)
;
; mds monitor equates
mon80 equ 0f800h ;mds monitor
rmon80 equ 0ff0fh ;restart mon80 (boot error)
ci equ 0f803h ;console character to reg-a
ri equ 0f806h ;reader in to reg-a
co equ 0f809h ;console char from c to console out
po equ 0f80ch ;punch char from c to punch device
lo equ 0f80fh ;list from c to list device
csts equ 0f812h ;console status 00/ff to register a
;
; disk ports and commands
base equ 78h ;base of disk command io ports
dstat equ base ;disk status (input)
rtype equ base+1 ;result type (input)
rbyte equ base+3 ;result byte (input)
;
ilow equ base+1 ;iopb low address (output)
ihigh equ base+2 ;iopb high address (output)
;
readf equ 4h ;read function
writf equ 6h ;write function
recal equ 3h ;recalibrate drive
iordy equ 4h ;i/o finished mask
cr equ 0dh ;carriage return
lf equ 0ah ;line feed
;
signon: ;signon message: xxk cp/m vers y.y
db cr,lf,lf
if test
db '32' ;32k example bios
endif
if not test
db '00' ;memory size filled by relocator
endif
db 'k CP/M vers '
db vers/10+'0','.',vers mod 10+'0'
db cr,lf,0
;
boot: ;print signon message and go to ccp
; (note: mds boot initialized iobyte at 0003h)
lxi sp,buff+80h
lxi h,signon
call prmsg ;print message
xra a ;clear accumulator
sta cdisk ;set initially to disk a
jmp gocpm ;go to cp/m
;
;
wboot:; loader on track 0, sector 1, which will be skipped for warm
; read cp/m from disk - assuming there is a 128 byte cold start
; start.
;
lxi sp,buff ;using dma - thus 80 thru ff available for stack
;
mvi c,retry ;max retries
push b
wboot0: ;enter here on error retries
lxi b,cpmb ;set dma address to start of disk system
call setdma
mvi c,0 ;boot from drive 0
call seldsk
mvi c,0
call settrk ;start with track 0
mvi c,2 ;start reading sector 2
call setsec
;
; read sectors, count nsects to zero
pop b ;10-error count
mvi b,nsects
rdsec: ;read next sector
push b ;save sector count
call read
jnz booterr ;retry if errors occur
lhld iod ;increment dma address
lxi d,128 ;sector size
dad d ;incremented dma address in hl
mov b,h
mov c,l ;ready for call to set dma
call setdma
lda ios ;sector number just read
cpi 26 ;read last sector?
jc rd1
; must be sector 26, zero and go to next track
lda iot ;get track to register a
inr a
mov c,a ;ready for call
call settrk
xra a ;clear sector number
rd1: inr a ;to next sector
mov c,a ;ready for call
call setsec
pop b ;recall sector count
dcr b ;done?
jnz rdsec
;
; done with the load, reset default buffer address
gocpm: ;(enter here from cold start boot)
; enable rst0 and rst7
di
mvi a,12h ;initialize command
out revrt
xra a
out intc ;cleared
mvi a,inte ;rst0 and rst7 bits on
out intc
xra a
out icon ;interrupt control
;
; set default buffer address to 80h
lxi b,buff
call setdma
;
; reset monitor entry points
mvi a,jmp
sta 0
lxi h,wboote
shld 1 ;jmp wboot at location 00
sta 5
lxi h,bdos
shld 6 ;jmp bdos at location 5
if not test
sta 7*8 ;jmp to mon80 (may have been changed by ddt)
lxi h,mon80
shld 7*8+1
endif
; leave iobyte set
; previously selected disk was b, send parameter to cpm
lda cdisk ;last logged disk number
mov c,a ;send to ccp to log it in
ei
jmp cpmb
;
; error condition occurred, print message and retry
booterr:
pop b ;recall counts
dcr c
jz booter0
; try again
push b
jmp wboot0
;
booter0:
; otherwise too many retries
lxi h,bootmsg
call prmsg
jmp rmon80 ;mds hardware monitor
;
bootmsg:
db '?boot',0
;
;
const: ;console status to reg-a
; (exactly the same as mds call)
jmp csts
;
conin: ;console character to reg-a
call ci
ani 7fh ;remove parity bit
ret
;
conout: ;console character from c to console out
jmp co
;
list: ;list device out
; (exactly the same as mds call)
jmp lo
;
listst:
;return list status
xra a
ret ;always not ready
;
punch: ;punch device out
; (exactly the same as mds call)
jmp po
;
reader: ;reader character in to reg-a
; (exactly the same as mds call)
jmp ri
;
home: ;move to home position
; treat as track 00 seek
mvi c,0
jmp settrk
;
seldsk: ;select disk given by register c
lxi h,0000h ;return 0000 if error
mov a,c
cpi ndisks ;too large?
rnc ;leave HL = 0000
;
ani 10b ;00 00 for drive 0,1 and 10 10 for drive 2,3
sta dbank ;to select drive bank
mov a,c ;00, 01, 10, 11
ani 1b ;mds has 0,1 at 78, 2,3 at 88
ora a ;result 00?
jz setdrive
mvi a,00110000b ;selects drive 1 in bank
setdrive:
mov b,a ;save the function
lxi h,iof ;io function
mov a,m
ani 11001111b ;mask out disk number
ora b ;mask in new disk number
mov m,a ;save it in iopb
mov l,c
mvi h,0 ;HL=disk number
dad h ;*2
dad h ;*4
dad h ;*8
dad h ;*16
lxi d,dpbase
dad d ;HL=disk header table address
ret
;
;
settrk: ;set track address given by c
lxi h,iot
mov m,c
ret
;
setsec: ;set sector number given by c
lxi h,ios
mov m,c
ret
sectran:
;translate sector bc using table at de
mvi b,0 ;double precision sector number in BC
xchg ;translate table address to HL
dad b ;translate(sector) address
mov a,m ;translated sector number to A
sta ios
mov l,a ;return sector number in L
ret
;
setdma: ;set dma address given by regs b,c
mov l,c
mov h,b
shld iod
ret
;
read: ;read next disk record (assuming disk/trk/sec/dma set)
mvi c,readf ;set to read function
call setfunc
call waitio ;perform read function
ret ;may have error set in reg-a
;
;
write: ;disk write function
mvi c,writf
call setfunc ;set to write function
call waitio
ret ;may have error set
;
;
; utility subroutines
prmsg: ;print message at h,l to 0
mov a,m
ora a ;zero?
rz
; more to print
push h
mov c,a
call conout
pop h
inx h
jmp prmsg
;
setfunc:
; set function for next i/o (command in reg-c)
lxi h,iof ;io function address
mov a,m ;get it to accumulator for masking
ani 11111000b ;remove previous command
ora c ;set to new command
mov m,a ;replaced in iopb
; the mds-800 controller requires disk bank bit in sector byte
; mask the bit from the current i/o function
ani 00100000b ;mask the disk select bit
lxi h,ios ;address the sector select byte
ora m ;select proper disk bank
mov m,a ;set disk select bit on/off
ret
;
waitio:
mvi c,retry ;max retries before perm error
rewait:
; start the i/o function and wait for completion
call intype ;in rtype
call inbyte ;clears the controller
;
lda dbank ;set bank flags
ora a ;zero if drive 0,1 and nz if 2,3
mvi a,iopb and 0ffh ;low address for iopb
mvi b,iopb shr 8 ;high address for iopb
jnz iodr1 ;drive bank 1?
out ilow ;low address to controller
mov a,b
out ihigh ;high address
jmp wait0 ;to wait for complete
;
iodr1: ;drive bank 1
out ilow+10h ;88 for drive bank 10
mov a,b
out ihigh+10h
;
wait0: call instat ;wait for completion
ani iordy ;ready?
jz wait0
;
; check io completion ok
call intype ;must be io complete (00) unlinked
; 00 unlinked i/o complete, 01 linked i/o complete (not used)
; 10 disk status changed 11 (not used)
cpi 10b ;ready status change?
jz wready
;
; must be 00 in the accumulator
ora a
jnz werror ;some other condition, retry
;
; check i/o error bits
call inbyte
ral
jc wready ;unit not ready
rar
ani 11111110b ;any other errors? (deleted data ok)
jnz werror
;
; read or write is ok, accumulator contains zero
ret
;
wready: ;not ready, treat as error for now
call inbyte ;clear result byte
jmp trycount
;
werror: ;return hardware malfunction (crc, track, seek, etc.)
; the mds controller has returned a bit in each position
; of the accumulator, corresponding to the conditions:
; 0 - deleted data (accepted as ok above)
; 1 - crc error
; 2 - seek error
; 3 - address error (hardware malfunction)
; 4 - data over/under flow (hardware malfunction)
; 5 - write protect (treated as not ready)
; 6 - write error (hardware malfunction)
; 7 - not ready
; (accumulator bits are numbered 7 6 5 4 3 2 1 0)
;
; it may be useful to filter out the various conditions,
; but we will get a permanent error message if it is not
; recoverable. in any case, the not ready condition is
; treated as a separate condition for later improvement
trycount:
; register c contains retry count, decrement 'til zero
dcr c
jnz rewait ;for another try
;
; cannot recover from error
mvi a,1 ;error code
ret
;
; intype, inbyte, instat read drive bank 00 or 10
intype: lda dbank
ora a
jnz intyp1 ;skip to bank 10
in rtype
ret
intyp1: in rtype+10h ;78 for 0,1 88 for 2,3
ret
;
inbyte: lda dbank
ora a
jnz inbyt1
in rbyte
ret
inbyt1: in rbyte+10h
ret
;
instat: lda dbank
ora a
jnz insta1
in dstat
ret
insta1: in dstat+10h
ret
;
;
;
; data areas (must be in ram)
dbank: db 0 ;disk bank 00 if drive 0,1
; 10 if drive 2,3
iopb: ;io parameter block
db 80h ;normal i/o operation
iof: db readf ;io function, initial read
ion: db 1 ;number of sectors to read
iot: db offset ;track number
ios: db 1 ;sector number
iod: dw buff ;io address
;
;
; define ram areas for bdos operation
endef
end


15
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/OS5TRINT.SRC Normal file
View File

@@ -0,0 +1,15 @@
; PIP INTERFACE TO BDOS (CAN BE USED FOR OTHER TRANSIENTS)
PUBLIC BOOT,IOBYTE,BDISK,BDOS,MON1,MON2,MON3
PUBLIC MAXB,FCB,BUFF
BOOT EQU 0000H ;WARM START
IOBYTE EQU 0003H ;IO BYTE
BDISK EQU 0004H ;BOOT DISK #
BDOS EQU 0005H ;BDOS ENTRY
MON1 EQU 0005H ;BDOS ENTRY
MON2 EQU 0005H ;BDOS ENTRY
MON3 EQU 0005H ;BDOS ENTRY
MAXB EQU 0006H ;MAX MEM BASE
FCB EQU 005CH ;DEFAULT FCB
BUFF EQU 0080H ;DEFAULT BUFFER
END


234
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/PARSE.ASM Normal file
View File

@@ -0,0 +1,234 @@
$title ('Filename Parser')
name Parse
public parse
CSEG
; BC->.(.filename,.fcb)
;
; filename = [d:]file[.type][;password]
;
; fcb assignments
;
; 0 => drive, 0 = default, 1 = A, 2 = B, ...
; 1-8 => file, converted to upper case,
; padded with blanks
; 9-11 => type, converted to upper case,
; padded with blanks
; 12-15 => set to zero
; 16-23 => password, converted to upper case,
; padded with blanks
; 24-25 => address of password field in 'filename',
; set to zero if password length = 0
; 26 => length of password (0 - 8)
;
; Upon return, HL is set to FFFFH if BC locates
; an invalid file name;
; otherwise, HL is set to 0000H if the delimiter
; following the file name is a 00H (NULL)
; or a 0DH (CR);
; otherwise, HL is set to the address of the delimiter
; following the file name.
;
parse: lxi h,0
push h
push h
mov h,b
mov l,c
mov e,m
inx h
mov d,m
inx h
mov a,m
inx h
mov h,m
mov l,a
call deblnk
call delim
jnz parse1
mov a,c
ora a
jnz parse9
mov m,a
jmp parse3
parse1: mov b,a
inx d
ldax d
cpi ':'
jnz parse2
mov a,b
sui 'A'
jc parse9
cpi 16
jnc parse9
inr a
mov m,a
inx d
call delim
jnz parse3
cpi '.'
jz parse9
cpi ':'
jz parse9
cpi ';'
jz parse9
jmp parse3
parse2: dcx d
mvi m,0
parse3: mvi b,8
call setfld
mvi b,3
cpi '.'
jz parse4
call padfld
jmp parse5
parse4: inx d
call setfld
parse5: mvi b,4
parse6: inx h
mvi m,0
dcr b
jnz parse6
mvi b,8
cpi ';'
jz parse7
call padfld
jmp parse8
parse7: inx d
call pwfld
parse8: push d
call deblnk
call delim
jnz pars81
inx sp
inx sp
jmp pars82
pars81: pop d
pars82: mov a,c
ora a
pop b
mov a,c
pop b
inx h
mov m,c
inx h
mov m,b
inx h
mov m,a
xchg
rnz
lxi h,0
ret
parse9: pop h
pop h
lxi h,0ffffh
ret
setfld: call delim
jz padfld
inx h
cpi '*'
jnz setfd1
mvi m,'?'
dcr b
jnz setfld
jmp setfd2
setfd1: mov m,a
dcr b
setfd2: inx d
jnz setfld
setfd3: call delim
rz
pop h
jmp parse9
pwfld: call delim
jz padfld
inx sp
inx sp
inx sp
inx sp
inx sp
inx sp
push d
push h
mvi l,0
xthl
dcx sp
dcx sp
pwfld1: inx sp
inx sp
xthl
inr l
xthl
dcx sp
dcx sp
inx h
mov m,a
inx d
dcr b
jz setfd3
call delim
jnz pwfld1
;jmp padfld
padfld: inx h
mvi m,' '
dcr b
jnz padfld
ret
delim: ldax d
mov c,a
ora a
rz
mvi c,0
cpi 0dh
rz
mov c,a
cpi 09h
rz
cpi ' '
jc delim2
rz
cpi '.'
rz
cpi ':'
rz
cpi ';'
rz
cpi '='
rz
cpi ','
rz
cpi '/'
rz
cpi '['
rz
cpi ']'
rz
cpi '<'
rz
cpi '>'
rz
cpi 'a'
rc
cpi 'z'+1
jnc delim1
ani 05fh
delim1: ani 07fh
ret
delim2: pop h
jmp parse9
deblnk: ldax d
cpi ' '
jz dblnk1
cpi 09h
jz dblnk1
ret
dblnk1: inx d
jmp deblnk
END
EOF


1067
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/PATCH.ASM Normal file
View File

File diff suppressed because it is too large Load Diff

219
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/PIP.LIN Normal file
View File

@@ -0,0 +1,219 @@
0000 PIP#
0000 PIPMOD#
07E6 14 07EA 16 07F2 17 07F3 18 07F3 19
07FB 20 07FF 21 07FF 22 07FF 23 0804 24
0809 25 080A 42 080A 43 0813 44 0813 45
0813 46 081C 47 081C 49 0820 51 082D 52
082E 53 082E 54 0833 55 0838 56 0839 57
083F 59 0842 60 084B 61 084C 63 084C 64
0855 65 0855 66 0855 67 085D 68 085E 69
0862 71 086D 72 086E 73 0874 75 0880 76
0881 77 0887 79 0893 80 0894 81 089A 83
08A6 84 08A7 85 08A7 86 08B2 87 08B3 88
08B9 90 08C2 91 08C3 92 08C9 94 08D3 95
08D3 96 08D9 98 08E3 99 08E3 100 08E9 102
08F5 103 08F6 104 08FC 106 0905 107 0906 109
090C 111 0915 112 0916 113 0916 114 091F 115
091F 116 0923 118 092E 119 092F 120 092F 121
0936 122 0937 123 0937 124 093E 125 093F 126
0945 128 094F 129 094F 130 0955 132 095F 133
095F 134 0965 136 096E 137 096F 140 096F 141
0974 142 097C 143 097D 145 097D 146 0986 147
0986 149 098C 151 0995 152 0996 153 0996 155
099A 156 099E 157 09A7 158 09AA 159 09AF 160
09AF 162 09B5 164 09B8 165 09C0 166 09C5 167
09CA 168 09DA 169 09E4 170 09F1 171 09F8 172
09FD 173 0A03 174 0A0B 175 0A11 176 0A14 177
0A17 178 0A18 179 0A27 182 0A33 183 0A3D 184
0A44 185 0A4B 186 0A4E 187 0A4F 188 0A4F 190
0A55 191 0A5C 192 0A5F 193 0A6E 194 0A7B 195
0A89 197 0A91 198 0A97 199 0A9D 200 0AA4 201
0AAA 202 0AAD 203 0AB7 204 0ABE 205 0AC4 206
0AC7 207 0AC8 208 0AC8 212 0ADA 213 0ADB 214
0AE1 215 0AE8 216 0AEE 217 0AFD 218 0B07 219
0B0F 220 0B1A 221 0B20 222 0B2A 223 0B31 224
0B38 226 0B3E 227 0B44 228 0B53 229 0B61 230
0B68 231 0B6D 232 0B7B 233 0B9B 234 0B9F 235
0BA2 236 0BAC 237 0BB3 238 0BB9 239 0BC0 240
0BC9 241 0BC9 242 0BCF 243 0BD0 244 0BD4 246
0BDC 248 0BE0 249 0BE9 251 0BF3 252 0BF4 253
0BF4 254 0BF4 255 0BFA 256 0C0A 257 0C0A 258
0C16 259 0C19 260 0C24 261 0C2B 262 0C2E 263
0C31 264 0C34 265 0C37 266 0C3A 267 0C3D 268
0C46 269 0C50 270 0C50 271 0C55 272 0C58 273
0C5B 274 0C5B 275 0C60 276 0C63 277 0C66 278
0C66 279 0C6B 280 0C6E 281 0C71 282 0C7F 283
0C7F 284 0C84 285 0C87 286 0C8A 287 0C8A 288
0C8F 289 0C92 290 0C95 291 0C95 292 0C9A 293
0C9D 294 0CA0 295 0CAE 296 0CAE 297 0CB3 298
0CB6 299 0CB9 300 0CB9 301 0CBE 302 0CC1 303
0CC4 304 0CC4 305 0CC9 306 0CCC 307 0CCF 308
0CDD 309 0D05 310 0D0B 311 0D0C 312 0D10 314
0D18 315 0D22 316 0D2A 317 0D34 319 0D3A 320
0D44 321 0D4E 322 0D51 323 0D59 324 0D62 325
0D66 326 0D6B 327 0D6E 328 0D6E 329 0D76 330
0D7B 331 0D7C 332 0D80 334 0D91 335 0D99 336
0DA2 337 0DA3 338 0DA7 340 0DB4 341 0DBD 342
0DBE 343 0DBE 345 0DC3 346 0DCE 347 0DD6 348
0DDF 349 0DE8 350 0DEF 351 0DF6 352 0DFD 353
0E05 355 0E0A 356 0E0F 357 0E12 358 0E17 359
0E18 360 0E18 363 0E21 364 0E2A 365 0E2D 366
0E3C 367 0E44 368 0E45 369 0E49 371 0E50 373
0E58 374 0E59 375 0E59 376 0E60 378 0E68 380
0E73 382 0E7B 383 0E80 384 0E8E 386 0E93 387
0E98 388 0E98 389 0E98 390 0EA1 391 0EA4 392
0EA9 393 0EA9 394 0EA9 395 0EB0 397 0EC8 399
0ECB 400 0ECC 401 0ECC 402 0ECC 403 0ED4 404
0ED9 405 0EE0 406 0EE8 407 0EED 408 0EEE 409
0EF2 411 0F09 412 0F11 413 0F15 414 0F15 415
0F19 417 0F30 418 0F38 419 0F3C 420 0F3C 421
0F3C 423 0F47 425 0F59 427 0F61 428 0F64 429
0F6A 430 0F6D 431 0F6D 432 0F6D 433 0F72 434
0F78 435 0F88 436 0F88 437 0F94 438 0F97 439
0FA3 440 0FAA 441 0FAD 442 0FB6 443 0FBF 444
0FBF 445 0FC4 446 0FC7 447 0FCA 448 0FCA 449
0FCF 450 0FD2 451 0FD5 452 0FD5 453 0FDA 454
0FDD 455 0FE0 456 0FF0 457 0FF3 458 0FF6 459
0FF9 460 0FFC 461 0FFF 462 1002 463 1005 464
1008 465 1008 466 100E 467 1011 468 1011 469
1016 470 1019 471 101C 472 101C 473 1021 474
1024 475 1027 476 1027 477 102C 478 102F 479
1032 480 1032 481 1037 482 1042 483 1045 484
106D 485 1073 486 107A 488 1080 489 1085 490
108C 491 1092 492 1092 493 1099 495 10A0 496
10B2 497 10BD 498 10C4 500 10CB 502 10D3 503
10D6 504 10DC 505 10DC 506 10DC 507 10DC 508
10E3 509 10EB 510 10F2 511 10FA 512 1101 513
1109 514 110D 515 110D 516 11AD 518 11B1 520
11C9 522 11D6 523 11D9 524 11D9 525 11E3 526
11EA 527 11EF 528 11F2 529 110D 530 1116 532
1122 533 1125 534 1128 535 1128 536 1128 537
1131 539 1135 540 1141 541 1145 542 1146 543
1146 544 1151 545 1154 546 115D 548 1168 550
116E 551 1173 552 117A 553 117A 554 117D 555
1186 557 1191 559 1196 560 119B 561 119E 562
119E 563 11A2 564 11A5 565 11A9 566 11AC 567
11F2 569 11F2 570 1200 571 1203 572 1211 573
1211 574 1211 575 121C 576 121F 577 1220 578
1438 581 143C 584 144A 585 145A 586 145D 587
1464 588 1467 589 1467 590 1467 591 1479 592
1481 593 1486 594 1487 595 148B 597 1490 598
149A 599 149D 600 14A0 601 14A1 602 14A5 604
14B1 605 14B1 606 14B1 608 14B6 609 14BC 610
14C2 611 14DA 612 14E9 614 14F1 615 14FA 616
1500 617 1503 619 151B 621 1522 622 153D 623
1540 624 1546 625 1549 626 155B 627 1563 628
1575 629 158A 630 158D 631 159A 632 15A2 634
15AB 635 15B1 636 15B7 637 15B7 638 15B7 639
15BA 640 15C0 641 15C1 642 15C1 643 15C9 644
15CE 645 1226 646 122B 647 1230 648 1233 649
1238 650 1240 651 1248 652 124D 653 1250 654
1253 655 1256 656 125C 657 1267 659 126A 660
126F 661 1270 662 1270 663 1275 664 1283 665
128E 666 1295 667 129A 668 12A5 669 12A5 670
12AA 671 12B5 672 12BD 673 12BE 674 12C6 675
12CE 676 12D1 677 12D7 678 12DA 679 12E2 681
12EA 682 12EB 683 12F3 685 1305 686 1306 687
1309 688 1314 690 131C 691 131F 692 1323 693
1328 694 1329 695 1329 696 132C 697 1334 698
1335 701 133A 702 1346 703 134B 704 137B 705
137E 706 1386 708 138B 709 1393 710 1396 711
139A 712 13A0 713 13A1 714 13A1 715 13A9 716
13B0 717 13B1 718 13B1 719 13B9 720 13BC 721
13BF 723 13C7 724 13C8 725 13CD 726 13D5 727
13E3 728 13EB 729 13EC 730 13F4 731 13FC 732
13FF 733 1402 734 140A 735 140D 736 1411 737
1416 738 141E 739 1425 740 1433 741 1434 742
1434 743 1437 744 15CF 745 15CF 747 15DD 748
15E2 749 15E9 750 15EA 752 15F0 754 15FC 755
15FD 756 1607 758 1610 759 1623 760 1626 761
162D 762 1634 763 1637 764 163A 765 163A 766
163A 767 1640 768 1647 769 1652 770 165B 771
165B 772 1712 775 1718 777 171F 779 1724 780
172C 781 172C 782 172D 783 172D 784 1734 786
1739 787 173C 788 173C 789 173D 790 173D 792
1744 794 174F 795 1754 796 1757 797 1764 798
1770 799 1776 800 177A 801 177A 802 177D 803
177D 805 177D 807 178C 808 1792 809 179E 810
17A4 811 17AC 812 17AC 813 17AC 814 17BB 815
17BB 816 17BB 817 17C4 818 17C4 819 17C4 820
17DA 821 165B 822 1660 823 1665 824 1670 825
1675 826 167D 828 1683 829 168B 830 168E 831
1693 832 1693 833 1696 834 1699 835 169E 836
16A9 838 16B4 839 16B7 840 16BA 841 16C1 842
16C4 843 16C7 844 16C7 845 16CD 846 16D3 847
16E3 848 16E7 849 16ED 850 16F0 851 16FC 852
1702 853 1705 854 170C 855 170F 856 1712 857
17DA 858 17DA 860 17DA 861 17E7 862 17F7 863
1806 864 1815 865 181C 866 1821 867 1826 868
182E 869 182F 870 1832 871 1835 872 1840 873
1846 874 184C 875 184F 876 1857 877 1858 878
185B 879 185C 880 185C 881 1862 882 1863 883
1863 884 186A 885 1876 886 1882 887 188A 888
1892 889 1898 890 189E 891 18A4 892 18AC 893
18B2 894 18BD 895 18BE 896 18BE 897 18C4 898
18C7 899 18CE 900 18D4 901 18D7 902 18E7 903
18EC 904 18F4 905 18FA 906 18FF 907 190B 908
1911 909 1912 910 1912 911 191B 912 1921 913
192A 914 1930 915 1931 916 1935 918 193C 919
1945 920 194A 921 1955 922 1959 923 195E 924
1961 925 1964 926 1967 927 196E 928 1974 929
197C 930 1982 931 1988 932 198D 933 1993 934
199B 936 19A3 938 19AA 940 19B0 941 19BC 943
19C2 944 19C5 945 19CB 946 19D1 947 19D2 948
19D2 949 19D5 950 19D5 951 19DD 952 19E3 953
19E3 954 19E9 955 19E9 956 19F5 957 19FB 958
1A01 959 1A02 960 1A02 961 1A15 962 1A16 963
1A16 964 1A1C 965 1A28 966 1A31 967 1A3C 968
1A3F 969 1A40 970 1A40 971 1A56 972 1A68 973
1A6B 974 1A6C 975 1A6C 977 1A7F 978 1A82 979
1A8D 980 1A93 981 1A9A 982 1AA1 983 1AA4 984
1AAB 986 1AAE 987 1AB1 988 1AB1 989 1AB2 990
1B6A 992 1B6A 993 1B78 994 1AB2 995 1AB5 996
1ABB 997 1ABE 998 1AC1 999 1AC6 1000 1AD2 1001
1AE1 1003 1B1D 1004 1B22 1005 1B22 1006 1B29 1007
1B30 1009 1B33 1010 1B3A 1011 1B3D 1012 1B44 1013
1B4D 1014 1B53 1015 1B56 1016 1B59 1017 1B5C 1018
1B5F 1019 1B62 1020 1B69 1021 1B78 1022 1C49 1024
1C49 1026 1C4C 1027 1C5A 1028 1C6C 1030 1C74 1031
1C79 1032 1C80 1033 1C80 1034 1C87 1035 1B78 1036
1B81 1037 1B81 1038 1B84 1039 1B8B 1040 1B91 1041
1B97 1042 1B9D 1043 1BB7 1044 1BBE 1045 1BC1 1046
1BC4 1047 1BC7 1048 1BCF 1050 1BDB 1051 1BE1 1052
1BE4 1053 1BE5 1054 1BE5 1055 1BEC 1056 1C06 1057
1C0B 1058 1C10 1059 1C1C 1060 1C29 1062 1C39 1063
1C3F 1064 1C42 1065 1C45 1066 1C45 1067 1C48 1068
1C88 1069 1C88 1070 1C91 1071 1C9B 1072 1CA1 1073
1CA2 1074 1CA2 1075 1CA9 1076 1CAC 1077 1CB5 1078
1CBF 1079 1CC5 1080 1CC6 1081 1CC6 1082 1CD0 1083
1CD1 1084 1CDB 1085 1CDE 1086 1CDF 1087 1CDF 1088
1CE2 1089 1CEA 1090 1CED 1091 1CEE 1092 1CF4 1094
1CF7 1095 1CFA 1096 1D08 1097 1D0B 1098 1D0C 1099
1D0C 1100 1D12 1101 1D2A 1102 1D2D 1103 1D33 1104
04CE 1105 04DD 1106 04E8 1107 04F4 1109 04FA 1110
04FD 1111 04FD 1112 0503 1113 050E 1114 0514 1115
0514 1116 051A 1117 0525 1118 052A 1119 0532 1120
0535 1121 053C 1123 0541 1124 0544 1125 0547 1126
0547 1127 054C 1128 0554 1130 055B 1131 055E 1132
055E 1133 0570 1134 0576 1135 057E 1136 0581 1137
0589 1139 0590 1140 0593 1141 0599 1142 05A1 1143
05A4 1144 05AB 1146 05B1 1147 05B4 1148 05B7 1150
05BD 1151 05C0 1152 05C0 1153 05C3 1154 05C3 1155
05D3 1156 05D6 1157 05D9 1158 05DC 1159 05E2 1160
05EA 1162 05ED 1163 05F0 1164 05FC 1165 05FF 1166
0602 1167 0605 1168 0605 1169 060D 1171 0610 1172
0618 1173 061B 1174 061E 1175 0621 1176 0624 1177
0624 1178 0629 1179 062F 1180 063D 1181 0643 1182
0648 1183 0650 1185 0653 1186 0656 1187 065B 1188
065E 1189 0675 1190 067B 1191 0687 1192 068A 1193
0690 1194 06A8 1195 06AE 1196 06B3 1197 06BA 1198
06C0 1199 06C6 1200 06CB 1201 06DF 1203 06E2 1204
06E5 1205 06EA 1206 06ED 1207 070D 1208 0713 1209
071B 1210 0722 1211 072A 1212 0730 1213 0738 1214
0740 1216 074E 1217 0753 1218 075B 1220 0760 1221
0768 1222 076D 1223 0775 1224 077A 1225 077A 1226
077D 1227 077D 1228 0780 1229 0786 1230 07AA 1231
07B0 1232 07BB 1233 07BE 1234 07C6 1236 07CB 1237
07CE 1238 07CE 1239 07D6 1240 07DB 1241 07E1 1242
07E4 1243


1594
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/PIP.PLM Normal file
View File

File diff suppressed because it is too large Load Diff

10
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/PLIBIOS.DCL Normal file
View File

@@ -0,0 +1,10 @@
declare
seldsk entry (fixed(7)) returns(ptr),
settrk entry (fixed(15)),
setsec entry (fixed(15)),
rdsec entry returns(fixed(7)),
wrsec entry (fixed(7)) returns(fixed(7)),
sectrn entry (fixed(15), ptr) returns(fixed(15)),
bstdma entry (ptr);


147
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/PLIBIOS3.ASM Normal file
View File

@@ -0,0 +1,147 @@
name 'BIOSMOD'
title 'Direct BIOS Calls From PL/I-80 for CP/M 3.0'
;
;***********************************************************
;* *
;* bios calls from pl/i for track, sector io *
;* *
;***********************************************************
public settrk ;set track number
public setsec ;set sector number
public rdsec ;read sector
public wrsec ;write sector
public seldsk ;select disk & return the addr(DPH)
public sectrn ;translate sector # given translate table
public bstdma ;set dma
;
;
extrn ?boot ;system reboot entry point
extrn ?bdos ;bdos entry point
;
; utility functions
;
;***********************************************************
;***********************************************************
;* *
;* general purpose routines used upon entry *
;* *
;***********************************************************
;
;
getp2: ;get single word value to DE
mov e,m
inx h
mov d,m
inx h
push h
xchg
mov e,m
inx h
mov d,m
pop h
ret
;
;
;***********************************************************
;* *
;***********************************************************
settrk: ;set track number 0-76, 0-65535 in BC
;1-> track #
call getp2
xchg
shld BCREG
mvi a,0ah
jmp gobios
;
;***********************************************************
;* *
;***********************************************************
setsec: ;set sector number 1 - sectors per track
;1-> sector #
call getp2
xchg
shld BCREG
mvi a,0bh
jmp gobios
;
;***********************************************************
;* *
;***********************************************************
rdsec: ;read current sector into sector at dma addr
;returns 0 if no errors
; 1 non-recoverable error
mvi a,0dh
jmp gobios
;***********************************************************
;* *
;***********************************************************
wrsec: ;writes contents of sector at dma addr to current sector
;returns 0 errors occured
; 1 non-recoverable error
call getp2
xchg
shld BCREG
mvi a,0eh
jmp gobios
;
;***********************************************************
;* *
;***********************************************************
;
seldsk: ; selects disk
call getp2
mov a,e
sta BCREG
mvi a,9
jmp gobios
;
;***********************************************************
;* *
;***********************************************************
;
sectrn: ;translate sector #
call getp2
xchg
shld BCREG
xchg
call getp2
xchg
shld DEREG
mvi a,10h
jmp gobios
;
bstdma: ;set dma
call getp2
xchg
shld BCREG
mvi a,0ch
; jmp gobios
;
;***********************************************************
;***********************************************************
;***********************************************************
;* *
;* call BDOS *
;* *
;***********************************************************
;
;
gobios:
sta FUNC ;load BIOS function #
lxi h,FUNC
xchg ; address of BIOSPB in DE
mvi c,032h ; BDOS function 50 call
jmp ?bdos
;
;
BIOSPB: dw FUNC
FUNC: db 0
AREG: db 0
BCREG: dw 0
DEREG: dw 0
HLREG: dw 0
;
end


619
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/PLIDIO.ASM Normal file
View File

@@ -0,0 +1,619 @@
name 'DIOMOD'
title 'Direct CP/M Calls From PL/I-80'
;
;***********************************************************
;* *
;* cp/m calls from pl/i for direct i/o *
;* *
;***********************************************************
public memptr ;return pointer to base of free mem
public memsiz ;return size of memory in bytes
public memwds ;return size of memory in words
public dfcb0 ;return address of default fcb 0
public dfcb1 ;return address of default fcb 1
public dbuff ;return address of default buffer
public reboot ;system reboot (#0)
public rdcon ;read console character (#1)
public wrcon ;write console character(#2)
public rdrdr ;read reader character (#3)
public wrpun ;write punch character (#4)
public wrlst ;write list character (#5)
public coninp ;direct console input (#6a)
public conout ;direct console output (#6b)
public rdstat ;read console status (#6c)
public getio ;get io byte (#8)
public setio ;set i/o byte (#9)
public wrstr ;write string (#10)
public rdbuf ;read console buffer (#10)
public break ;get console status (#11)
public vers ;get version number (#12)
public reset ;reset disk system (#13)
public select ;select disk (#14)
public open ;open file (#15)
public close ;close file (#16)
public sear ;search for file (#17)
public searn ;search for next (#18)
public delete ;delete file (#19)
public rdseq ;read file sequential mode (#20)
public wrseq ;write file sequential mode (#21)
public make ;create file (#22)
public rename ;rename file (#23)
public logvec ;return login vector (#24)
public curdsk ;return current disk number (#25)
public setdma ;set DMA address (#26)
public allvec ;return address of alloc vector (#27)
public wpdisk ;write protect disk (#28)
public rovec ;return read/only vector (#29)
public filatt ;set file attributes (#30)
public getdpb ;get base of disk parm block (#31)
public getusr ;get user code (#32a)
public setusr ;set user code (#32b)
public rdran ;read random (#33)
public wrran ;write random (#34)
public filsiz ;random file size (#35)
public setrec ;set random record pos (#36)
public resdrv ;reset drive (#37)
public wrranz ;write random, zero fill (#40)
public sgscb ;set/get System Control Block byte/word
;
;
extrn ?begin ;beginning of free list
extrn ?boot ;system reboot entry point
extrn ?bdos ;bdos entry point
extrn ?dfcb0 ;default fcb 0
extrn ?dfcb1 ;default fcb 1
extrn ?dbuff ;default buffer
;
;***********************************************************
;* *
;* equates for interface to cp/m bdos *
;* *
;***********************************************************
cr equ 0dh ;carriage return
lf equ 0ah ;line feed
eof equ 1ah ;end of file
;
readc equ 1 ;read character from console
writc equ 2 ;write console character
rdrf equ 3 ;reader input
punf equ 4 ;punch output
listf equ 5 ;list output function
diof equ 6 ;direct i/o, version 2.0
getiof equ 7 ;get i/o byte
setiof equ 8 ;set i/o byte
printf equ 9 ;print string function
rdconf equ 10 ;read console buffer
statf equ 11 ;return console status
versf equ 12 ;get version number
resetf equ 13 ;system reset
seldf equ 14 ;select disk function
openf equ 15 ;open file function
closef equ 16 ;close file
serchf equ 17 ;search for file
serchn equ 18 ;search next
deletf equ 19 ;delete file
readf equ 20 ;read next record
writf equ 21 ;write next record
makef equ 22 ;make file
renamf equ 23 ;rename file
loginf equ 24 ;get login vector
cdiskf equ 25 ;get current disk number
setdmf equ 26 ;set dma function
getalf equ 27 ;get allocation base
wrprof equ 28 ;write protect disk
getrof equ 29 ;get r/o vector
setatf equ 30 ;set file attributes
getdpf equ 31 ;get disk parameter block
userf equ 32 ;set/get user code
rdranf equ 33 ;read random
wrranf equ 34 ;write random
filszf equ 35 ;compute file size
setrcf equ 36 ;set random record position
rsdrvf equ 37 ;reset drive function
wrrnzf equ 40 ;write random zero fill
scbf equ 49 ;set/get SCB
;
; utility functions
;***********************************************************
;* *
;* general purpose routines used upon entry *
;* *
;***********************************************************
;
getp1: ;get single byte parameter to register e
mov e,m ;low (addr)
inx h
mov d,m ;high(addr)
xchg ;hl = .char
mov e,m ;to register e
ret
;
getp2: ;get single word value to DE
getp2i: ;(equivalent to getp2)
call getp1
inx h
mov d,m ;get high byte as well
ret
;
getver: ;get cp/m or mp/m version number
push h ;save possible data adr
mvi c,versf
call ?bdos
pop h ;recall data addr
ret
;
chkv20: ;check for version 2.0 or greater
call getver
cpi 20
rnc ;return if > 2.0
; error message and stop
jmp vererr ;version error
;
chkv22: ;check for version 2.2 or greater
call getver
cpi 22h
rnc ;return if >= 2.2
vererr:
;version error, report and terminate
lxi d,vermsg
mvi c,printf
call ?bdos ;write message
jmp ?boot ;and reboot
vermsg: db cr,lf,'Later CP/M or MP/M Version Required$'
;
;***********************************************************
;* *
;***********************************************************
memptr: ;return pointer to base of free storage
lhld ?begin
ret
;
;***********************************************************
;* *
;***********************************************************
memsiz: ;return size of free memory in bytes
lhld ?bdos+1 ;base of bdos
xchg ;de = .bdos
lhld ?begin ;beginning of free storage
mov a,e ;low(.bdos)
sub l ;-low(begin)
mov l,a ;back to l
mov a,d ;high(.bdos)
sbb h
mov h,a ;hl = mem size remaining
ret
;
;***********************************************************
;* *
;***********************************************************
memwds: ;return size of free memory in words
call memsiz ;hl = size in bytes
mov a,h ;high(size)
ora a ;cy = 0
rar ;cy = ls bit
mov h,a ;back to h
mov a,l ;low(size)
rar ;include ls bit
mov l,a ;back to l
ret ;with wds in hl
;
;***********************************************************
;* *
;***********************************************************
dfcb0: ;return address of default fcb 0
lxi h,?dfcb0
ret
;
;***********************************************************
;* *
;***********************************************************
dfcb1: ;return address of default fcb 1
lxi h,?dfcb1
ret
;
;***********************************************************
;* *
;***********************************************************
dbuff: ;return address of default buffer
lxi h,?dbuff
ret
;
;***********************************************************
;* *
;***********************************************************
reboot: ;system reboot (#0)
jmp ?boot
;
;***********************************************************
;* *
;***********************************************************
rdcon: ;read console character (#1)
;return character value to stack
mvi c,readc
jmp chrin ;common code to read char
;
;***********************************************************
;* *
;***********************************************************
wrcon: ;write console character(#2)
;1->char(1)
mvi c,writc ;console write function
jmp chrout ;to write the character
;
;***********************************************************
;* *
;***********************************************************
rdrdr: ;read reader character (#3)
mvi c,rdrf ;reader function
chrin:
;common code for character input
call ?bdos ;value returned to A
pop h ;return address
push psw ;character to stack
inx sp ;delete flags
mvi a,1 ;character length is 1
pchl ;back to calling routine
;
;***********************************************************
;* *
;***********************************************************
wrpun: ;write punch character (#4)
;1->char(1)
mvi c,punf ;punch output function
jmp chrout ;common code to write chr
;
;***********************************************************
;* *
;***********************************************************
wrlst: ;write list character (#5)
;1->char(1)
mvi c,listf ;list output function
chrout:
;common code to write character
;1-> character to write
call getp1 ;output char to register e
jmp ?bdos ;to write and return
;
;***********************************************************
;* *
;***********************************************************
coninp: ;perform console input, char returned in stack
lxi h,chrstr ;return address
push h ;to stack for return
lhld ?boot+1 ;base of bios jmp vector
lxi d,2*3 ;offset to jmp conin
dad d
pchl ;return to chrstr
;
chrstr: ;create character string, length 1
pop h ;recall return address
push psw ;save character
inx sp ;delete psw
mvi a,1 ;string length is 1
pchl ;return to caller
;
;***********************************************************
;* *
;***********************************************************
conout: ;direct console output
;1->char(1)
call getp1 ;get parameter
mov c,e ;character to c
lhld ?boot+1 ;base of bios jmp
lxi d,3*3 ;console output offset
dad d ;hl = .jmp conout
pchl ;return through handler
;
;***********************************************************
;* *
;***********************************************************
rdstat: ;direct console status read
lxi h,rdsret ;read status return
push h ;return to rdsret
lhld ?boot+1 ;base of jmp vector
lxi d,1*3 ;offset to .jmp const
dad d ;hl = .jmp const
pchl
;
;***********************************************************
;* *
;***********************************************************
getio: ;get io byte (#8)
mvi c,getiof
jmp ?bdos ;value returned to A
;
;***********************************************************
;* *
;***********************************************************
setio: ;set i/o byte (#9)
;1->i/o byte
call getp1 ;new i/o byte to E
mvi c,setiof
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
wrstr: ;write string (#10)
;1->addr(string)
call getp2 ;get parameter value to DE
mvi c,printf ;print string function
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
rdbuf: ;read console buffer (#10)
;1->addr(buff)
call getp2i ;DE = .buff
mvi c,rdconf ;read console function
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
break: ;get console status (#11)
mvi c,statf
call ?bdos ;return through bdos
;
rdsret: ;return clean true value
ora a ;zero?
rz ;return if so
mvi a,0ffh ;clean true value
ret
;
;***********************************************************
;* *
;***********************************************************
vers: ;get version number (#12)
mvi c,versf
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
reset: ;reset disk system (#13)
mvi c,resetf
jmp ?bdos
;
;***********************************************************
;* *
;***********************************************************
select: ;select disk (#14)
;1->fixed(7) drive number
call getp1 ;disk number to E
mvi c,seldf
jmp ?bdos ;return through bdos
;***********************************************************
;* *
;***********************************************************
open: ;open file (#15)
;1-> addr(fcb)
call getp2i ;fcb address to de
mvi c,openf
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
close: ;close file (#16)
;1-> addr(fcb)
call getp2i ;.fcb to DE
mvi c,closef
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
sear: ;search for file (#17)
;1-> addr(fcb)
call getp2i ;.fcb to DE
mvi c,serchf
jmp ?bdos
;
;***********************************************************
;* *
;***********************************************************
searn: ;search for next (#18)
mvi c,serchn ;search next function
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
delete: ;delete file (#19)
;1-> addr(fcb)
call getp2i ;.fcb to DE
mvi c,deletf
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
rdseq: ;read file sequential mode (#20)
;1-> addr(fcb)
call getp2i ;.fcb to DE
mvi c,readf
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
wrseq: ;write file sequential mode (#21)
;1-> addr(fcb)
call getp2i ;.fcb to DE
mvi c,writf
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
make: ;create file (#22)
;1-> addr(fcb)
call getp2i ;.fcb to DE
mvi c,makef
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
rename: ;rename file (#23)
;1-> addr(fcb)
call getp2i ;.fcb to DE
mvi c,renamf
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
logvec: ;return login vector (#24)
mvi c,loginf
jmp ?bdos ;return through BDOS
;
;***********************************************************
;* *
;***********************************************************
curdsk: ;return current disk number (#25)
mvi c,cdiskf
jmp ?bdos ;return value in A
;
;***********************************************************
;* *
;***********************************************************
setdma: ;set DMA address (#26)
;1-> pointer (dma address)
call getp2 ;dma address to DE
mvi c,setdmf
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
allvec: ;return address of allocation vector (#27)
mvi c,getalf
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
wpdisk: ;write protect disk (#28)
call chkv20 ;must be 2.0 or greater
mvi c,wrprof
jmp ?bdos
;
;***********************************************************
;* *
;***********************************************************
rovec: ;return read/only vector (#29)
call chkv20 ;must be 2.0 or greater
mvi c,getrof
jmp ?bdos ;value returned in HL
;
;***********************************************************
;* *
;***********************************************************
filatt: ;set file attributes (#30)
;1-> addr(fcb)
call chkv20 ;must be 2.0 or greater
call getp2i ;.fcb to DE
mvi c,setatf
jmp ?bdos
;
;***********************************************************
;* *
;***********************************************************
getdpb: ;get base of current disk parm block (#31)
call chkv20 ;check for 2.0 or greater
mvi c,getdpf
jmp ?bdos ;addr returned in HL
;
;***********************************************************
;* *
;***********************************************************
getusr: ;get user code to register A
call chkv20 ;check for 2.0 or greater
mvi e,0ffh ;to get user code
mvi c,userf
jmp ?bdos
;
;***********************************************************
;* *
;***********************************************************
setusr: ;set user code
call chkv20 ;check for 2.0 or greater
call getp1 ;code to E
mvi c,userf
jmp ?bdos
;
;***********************************************************
;* *
;***********************************************************
rdran: ;read random (#33)
;1-> addr(fcb)
call chkv20 ;check for 2.0 or greater
call getp2i ;.fcb to DE
mvi c,rdranf
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
wrran: ;write random (#34)
;1-> addr(fcb)
call chkv20 ;check for 2.0 or greater
call getp2i ;.fcb to DE
mvi c,wrranf
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
filsiz: ;compute file size (#35)
call chkv20 ;must be 2.0 or greater
call getp2 ;.fcb to DE
mvi c,filszf
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
setrec: ;set random record position (#36)
call chkv20 ;must be 2.0 or greater
call getp2 ;.fcb to DE
mvi c,setrcf
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
resdrv: ;reset drive function (#37)
;1->drive vector - bit(16)
call chkv22 ;must be 2.2 or greater
call getp2 ;drive reset vector to DE
mvi c,rsdrvf
jmp ?bdos ;return through bdos
;
;***********************************************************
;* *
;***********************************************************
wrranz: ;write random, zero fill function
;1-> addr(fcb)
call chkv22 ;must be 2.2 or greater
call getp2i ;.fcb to DE
mvi c,wrrnzf
jmp ?bdos
;
;***********************************************************
;* *
;***********************************************************
sgscb: ;set/get SCB byte/word
;1-> addr(SCB structure)
call getp2
mvi c,scbf
jmp ?bdos
;
;***********************************************************
;* *
;***********************************************************
end


99
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/PRS0MOV.ASM Normal file
View File

@@ -0,0 +1,99 @@
VERSION EQU 30
; SID RELOCATOR PROGRAM, INCLUDED WITH THE MODULE TO PERFORM
; THE MOVE FROM 200H TO THE DESTINATION ADDRESS
ORG 100H
STACK EQU 200H
BDOS EQU 0005H
PRNT EQU 9 ;BDOS PRINT FUNCTION
MODULE EQU 200H ;MODULE ADDRESS
LXIM equ 01h
;
db LXIM
ds 2
; lxi b,00 ;set at merge
;
JMP START
; PATCH AREA, DATE, VERSION & SERIAL NOS.
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0
db 'CP/M Version 3.0'
db 'COPYRIGHT 1982, '
db 'DIGITAL RESEARCH'
db '151282' ; version date day-month-year
db 0,0,0,0 ; patch bit map
db '654321' ; Serial no.
SIGNON: DB 'CP/M 3 SID - Version '
DB VERSION/10+'0','.'
DB VERSION MOD 10 + '0','$'
START: LXI SP,STACK
PUSH B
PUSH B
LXI D,SIGNON
MVI C,PRNT
CALL BDOS
POP B ;RECOVER LENGTH OF MOVE
LXI H,BDOS+2;ADDRESS FIELD OF JUMP TO BDOS (TOP MEMORY)
MOV A,M ;A HAS HIGH ORDER ADDRESS OF MEMORY TOP
DCR A ;PAGE DIRECTLY BELOW BDOS
SUB B ;A HAS HIGH ORDER ADDRESS OF RELOC AREA
MOV D,A
MVI E,0 ;D,E ADDRESSES BASE OF RELOC AREA
PUSH D ;SAVE FOR RELOCATION BELOW
;
LXI H,MODULE;READY FOR THE MOVE
MOVE: MOV A,B ;BC=0?
ORA C
JZ RELOC
DCX B ;COUNT MODULE SIZE DOWN TO ZERO
MOV A,M ;GET NEXT ABSOLUTE LOCATION
STAX D ;PLACE IT INTO THE RELOC AREA
INX D
INX H
JMP MOVE
;
RELOC: ;STORAGE MOVED, READY FOR RELOCATION
; HL ADDRESSES BEGINNING OF THE BIT MAP FOR RELOCATION
POP D ;RECALL BASE OF RELOCATION AREA
POP B ;RECALL MODULE LENGTH
PUSH H ;SAVE BIT MAP BASE IN STACK
MOV H,D ;RELOCATION BIAS IS IN D
;
REL0: MOV A,B ;BC=0?
ORA C
JZ ENDREL
;
; NOT END OF THE RELOCATION, MAY BE INTO NEXT BYTE OF BIT MAP
DCX B ;COUNT LENGTH DOWN
MOV A,E
ANI 111B ;0 CAUSES FETCH OF NEXT BYTE
JNZ REL1
; FETCH BIT MAP FROM STACKED ADDRESS
XTHL
MOV A,M ;NEXT 8 BITS OF MAP
INX H
XTHL ;BASE ADDRESS GOES BACK TO STACK
MOV L,A ;L HOLDS THE MAP AS WE PROCESS 8 LOCATIONS
REL1: MOV A,L
RAL ;CY SET TO 1 IF RELOCATION NECESSARY
MOV L,A ;BACK TO L FOR NEXT TIME AROUND
JNC REL2 ;SKIP RELOCATION IF CY=0
;
; CURRENT ADDRESS REQUIRES RELOCATION
LDAX D
ADD H ;APPLY BIAS IN H
STAX D
REL2: INX D ;TO NEXT ADDRESS
JMP REL0 ;FOR ANOTHER BYTE TO RELOCATE
;
ENDREL: ;END OF RELOCATION
POP D ;CLEAR STACKED ADDRESS
MVI L,0
PCHL ;GO TO RELOCATED PROGRAM
END


1075
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/PRS1ASM.ASM Normal file
View File

File diff suppressed because it is too large Load Diff

3842
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/PRS2MON.ASM Normal file
View File

File diff suppressed because it is too large Load Diff

0
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/PRS2MON.REL Normal file
View File

976
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/PUT.PLM Normal file
View File

@@ -0,0 +1,976 @@
$ TITLE('CP/M 3.0 --- PUT user interface')
put:
do;
/*
Copyright (C) 1982
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
*/
/*
Written: 02 Aug 82 by John Knight
9/6/82 - changed RSX deletion & sub-function codes
- modified syntax & messages
- fixed password handling
9/11/82 - sign-on message
11/30/82 - interaction with SAVE
- PUT CONSOLE INPUT TO FILE
*/
/********************************************
* *
* LITERALS AND GLOBAL VARIABLES *
* *
********************************************/
declare
true literally '1',
false literally '0',
forever literally 'while true',
lit literally 'literally',
proc literally 'procedure',
dcl literally 'declare',
addr literally 'address',
cr literally '13',
lf literally '10',
ctrlc literally '3',
ctrlx literally '18h',
bksp literally '8',
con$type literally '0',
aux$type literally '1',
list$type literally '2',
input$type literally '3',
con$width$offset literally '1ah',
ccp$flag$offset literally '18h',
init$rsx literally '132',
kill$con$rsx literally '133',
kill$lst$rsx literally '137',
kill$journal$rsx literally '141',
get$con$fcb literally '134',
get$lst$fcb literally '138',
get$journal$fcb literally '142',
cpmversion literally '30h';
declare ccp$flag byte;
declare con$width byte;
declare i byte;
declare begin$buffer address;
declare buf$length byte;
declare no$chars byte;
declare rsx$kill$pb byte initial(kill$con$rsx);
declare rsx$fcb$pb byte initial(get$con$fcb);
declare
warning (*) byte data ('WARNING:',cr,lf,'$');
/* scanner variables and data */
declare
options(*) byte data
('OUTPUT~TO~FILE~CONSOLE~CONOUT:~AUXILIARY~',
'AUXOUT:~END~CON:~AUX:~LIST~LST:~PRINTER~INPUT',0FFH),
options$offset(*) byte data
(0,7,10,15,23,31,41,49,53,58,63,68,73,81,86),
put$options(*) byte data
('NOT~ECHO~RAW~FILTERED~SYSTEM~PROGRAM',0FFH),
put$options$offset(*) byte data
(0,4,9,13,22,29,36),
end$list byte data (0ffh),
delimiters(*) byte data (0,'[]=, ./;',0,0ffh),
SPACE byte data(5),
j byte initial(0),
buf$ptr address,
index byte,
endbuf byte,
delimiter byte;
declare end$of$string byte initial ('~');
declare scbpd structure
(offset byte,
set byte,
value address);
declare putpb structure
(output$type byte,
echo$flag byte,
filtered$flag byte,
program$flag byte)
initial(con$type,true,true,true);
declare parse$fn structure
(buff$adr address,
fcb$adr address);
declare passwd (8) byte;
declare plm label public;
/**************************************
* *
* B D O S INTERFACE *
* *
**************************************/
mon1:
procedure (func,info) external;
declare func byte;
declare info address;
end mon1;
mon2:
procedure (func,info) byte external;
declare func byte;
declare info address;
end mon2;
mon3:
procedure (func,info) address external;
declare func byte;
declare info address;
end mon3;
declare cmdrv byte external; /* command drive */
declare fcb (1) byte external; /* 1st default fcb */
declare fcb16 (1) byte external; /* 2nd default fcb */
declare pass0 address external; /* 1st password ptr */
declare len0 byte external; /* 1st passwd length */
declare pass1 address external; /* 2nd password ptr */
declare len1 byte external; /* 2nd passwd length */
declare tbuff (1) byte external; /* default dma buffer */
/**************************************
* *
* B D O S Externals *
* *
**************************************/
read$console:
procedure byte;
return mon2(1,0);
end read$console;
printchar:
procedure(char);
declare char byte;
call mon1(2,char);
end printchar;
conin:
procedure byte;
return mon2(6,0fdh);
end conin;
print$buf:
procedure (buffer$address);
declare buffer$address address;
call mon1 (9,buffer$address);
end print$buf;
read$console$buf:
procedure (buffer$address,max) byte;
declare buffer$address address;
declare new$max based buffer$address address;
declare max byte;
new$max = max;
call mon1(10,buffer$address);
buffer$address = buffer$address + 1;
return new$max; /* actually number of characters input */
end read$console$buf;
version: procedure address;
/* returns current cp/m version # */
return mon3(12,0);
end version;
check$con$stat: procedure byte;
return mon2(11,0);
end check$con$stat;
delete$file:
procedure (fcb$address) address;
declare fcb$address address;
return mon3(19,fcb$address);
end delete$file;
make$file: procedure (fcb) address;
declare fcb address;
return mon3(22,fcb);
end make$file;
set$dma: procedure(dma);
declare dma address;
call mon1(26,dma);
end set$dma;
/* 0ffh ==> return BDOS errors */
return$errors: procedure (mode);
declare mode byte;
call mon1(45,mode);
end return$errors;
getscbbyte: procedure (offset) byte;
declare offset byte;
scbpd.offset = offset;
scbpd.set = 0;
return mon2(49,.scbpd);
end getscbbyte;
setscbbyte:
procedure (offset,value);
declare offset byte;
declare value byte;
scbpd.offset = offset;
scbpd.set = 0ffh;
scbpd.value = double(value);
call mon1(49,.scbpd);
end setscbbyte;
rsx$call: procedure (rsxpb) address;
/* call Resident System Extension */
declare rsxpb address;
return mon3(60,rsxpb);
end rsx$call;
get$console$mode: procedure address;
/* returns console mode */
return mon3(6dh,0ffffh);
end get$console$mode;
set$console$mode: procedure (new$value);
declare new$value address;
call mon1(6dh,new$value);
end set$console$mode;
parse: procedure (pfcb) address external;
declare pfcb address;
end parse;
putf: procedure (param$block) external;
declare param$block address;
end putf;
/**************************************
* *
* S U B R O U T I N E S *
* *
**************************************/
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * Option scanner * * *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
separator: procedure(character) byte;
/* determines if character is a
delimiter and which one */
declare k byte,
character byte;
k = 1;
loop: if delimiters(k) = end$list then return(0);
if delimiters(k) = character then return(k); /* null = 25 */
k = k + 1;
go to loop;
end separator;
opt$scanner: procedure(list$ptr,off$ptr,idx$ptr);
/* scans the list pointed at by idxptr
for any strings that are in the
list pointed at by list$ptr.
Offptr points at an array that
contains the indices for the known
list. Idxptr points at the index
into the list. If the input string
is unrecognizable then the index is
0, otherwise > 0.
First, find the string in the known
list that starts with the same first
character. Compare up until the next
delimiter on the input. if every input
character matches then check for
uniqueness. Otherwise try to find
another known string that has its first
character match, and repeat. If none
can be found then return invalid.
To test for uniqueness, start at the
next string in the knwon list and try
to get another match with the input.
If there is a match then return invalid.
else move pointer past delimiter and
return.
P.Balma */
declare
buff based buf$ptr (1) byte,
idx$ptr address,
off$ptr address,
list$ptr address;
declare
i byte,
j byte,
list based list$ptr (1) byte,
offsets based off$ptr (1) byte,
wrd$pos byte,
character byte,
letter$in$word byte,
found$first byte,
start byte,
index based idx$ptr byte,
save$index byte,
(len$new,len$found) byte,
valid byte;
/*****************************************************************************/
/* internal subroutines */
/*****************************************************************************/
check$in$list: procedure;
/* find known string that has a match with
input on the first character. Set index
= invalid if none found. */
declare i byte;
i = start;
wrd$pos = offsets(i);
do while list(wrd$pos) <> end$list;
i = i + 1;
index = i;
if list(wrd$pos) = character then return;
wrd$pos = offsets(i);
end;
/* could not find character */
index = 0;
return;
end check$in$list;
setup: procedure;
character = buff(0);
call check$in$list;
letter$in$word = wrd$pos;
/* even though no match may have occurred, position
to next input character. */
i = 1;
character = buff(1);
end setup;
test$letter: procedure;
/* test each letter in input and known string */
letter$in$word = letter$in$word + 1;
/* too many chars input? 0 means
past end of known string */
if list(letter$in$word) = end$of$string then valid = false;
else
if list(letter$in$word) <> character then valid = false;
i = i + 1;
character = buff(i);
end test$letter;
skip: procedure;
/* scan past the offending string;
position buf$ptr to next string...
skip entire offending string;
ie., falseopt=mod, [note: comma or
space is considered to be group
delimiter] */
character = buff(i);
delimiter = separator(character);
/* No skip for PUT */
do while ((delimiter < 1) or (delimiter > 9));
i = i + 1;
character = buff(i);
delimiter = separator(character);
end;
endbuf = i;
buf$ptr = buf$ptr + endbuf + 1;
return;
end skip;
eat$blanks: procedure;
declare charac based buf$ptr byte;
do while ((delimiter := separator(charac)) = SPACE);
buf$ptr = buf$ptr + 1;
end;
end eat$blanks;
/*****************************************************************************/
/* end of internals */
/*****************************************************************************/
/* start of procedure */
if delimiter = 9 then
return; /* return if at end of buffer */
call eat$blanks;
start = 0;
call setup;
/* match each character with the option
for as many chars as input
Please note that due to the array
indices being relative to 0 and the
use of index both as a validity flag
and as a index into the option/mods
list, index is forced to be +1 as an
index into array and 0 as a flag*/
do while index <> 0;
start = index;
delimiter = separator(character);
/* check up to input delimiter */
valid = true; /* test$letter resets this */
do while delimiter = 0;
call test$letter;
if not valid then go to exit1;
delimiter = separator(character);
end;
go to good;
/* input ~= this known string;
get next known string that
matches */
exit1: call setup;
end;
/* fell through from above, did
not find a good match*/
endbuf = i; /* skip over string & return*/
call skip;
return;
/* is it a unique match in options
list? */
good: endbuf = i;
len$found = endbuf;
save$index = index;
valid = false;
next$opt:
start = index;
call setup;
if index = 0 then go to finished;
/* look at other options and check
uniqueness */
len$new = offsets(index + 1) - offsets(index) - 1;
if len$new = len$found then do;
valid = true;
do j = 1 to len$found;
call test$letter;
if not valid then go to next$opt;
end;
end;
else go to nextopt;
/* fell through...found another valid
match --> ambiguous reference */
index = 0;
call skip; /* skip input field to next delimiter*/
return;
finished: /* unambiguous reference */
index = save$index;
buf$ptr = buf$ptr + endbuf;
call eat$blanks;
if delimiter <> 0 then
buf$ptr = buf$ptr + 1;
else
delimiter = 5;
return;
end opt$scanner;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
crlf: proc;
call printchar(cr);
call printchar(lf);
end crlf;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* fill string @ s for c bytes with f */
fill: procedure(s,f,c);
declare s address;
declare (f,c) byte;
declare a based s byte;
do while (c:=c-1) <> 255;
a=f;
s=s+1;
end;
end fill;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* The error processor. This routine prints the command line
with a carot '^' under the offending delimiter, or sub-string.
The code passed to the routine determines the error message
to be printed beneath the command string. */
error: procedure (code);
declare (code,i,j,nlines,rem) byte;
declare (string$ptr,tstring$ptr) address;
declare chr1 based string$ptr byte;
declare chr2 based tstring$ptr byte;
declare carot$flag byte;
print$command: procedure (size);
declare size byte;
do j=1 to size; /* print command string */
call printchar(chr1);
string$ptr = string$ptr + 1;
end;
call crlf;
do j=1 to size; /* print carot if applicable */
if .chr2 = buf$ptr then do;
carot$flag = true;
call printchar('^');
end;
else
call printchar(' ');
tstring$ptr = tstring$ptr + 1;
end;
call crlf;
end print$command;
carot$flag = false;
string$ptr,tstring$ptr = begin$buffer;
con$width = getscbbyte(con$width$offset);
if con$width < 40 then con$width = 40;
nlines = buf$length / con$width; /* num lines to print */
rem = buf$length mod con$width; /* num extra chars to print */
if code <> 2 then do;
if ((code = 1) or (code = 4)) then /* adjust carot pointer */
buf$ptr = buf$ptr - 1; /* for delimiter errors */
else if code <> 5 then
buf$ptr = buf$ptr - endbuf - 1; /* all other errors */
end;
call crlf;
do i=1 to nlines;
tstring$ptr = string$ptr;
call print$command(con$width);
end;
call print$command(rem);
if carot$flag then
call print$buf(.('Error at the ''^'': $'));
else
call print$buf(.('Error at end of line: $'));
if con$width < 65 then
call crlf;
do case code;
call print$buf(.('Invalid option or modifier$'));
call print$buf(.('End of line expected$'));
call print$buf(.('Invalid file specification$'));
call print$buf(.('Invalid command$'));
call print$buf(.('Invalid delimiter$'));
call print$buf(.('File is Read Only$'));
end;
call mon1(0,0);
end error;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
user$abort: procedure (a);
declare a address;
declare response byte;
call print$buf(a);
call print$buf(.(' (Y/N)? $'));
response=read$console;
call crlf;
if not((response='y') or (response='Y')) then do;
call print$buf(.('PUT aborted$'));
call mon1(0,0);
end;
end user$abort;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ucase: procedure (char) byte;
declare char byte;
if char >= 'a' then
if char < '{' then
return (char-20h);
return char;
end ucase;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
getucase: procedure byte;
declare c byte;
c = ucase(conin);
return c;
end getucase;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
getpasswd: procedure;
declare (i,c) byte;
call crlf;
call crlf;
call print$buf(.('Enter Password: $'));
retry:
call fill(.passwd,' ',8);
do i=0 to 7;
nxtchr:
if (c:=getucase) >= ' ' then
passwd(i)=c;
if c = cr then
return;
if c = ctrlx then
go to retry;
if c = bksp then do;
if i < 1 then
goto retry;
else do;
passwd(i := i - 1) = ' ';
goto nxtchr;
end;
end;
if c = 3 then
call mon1(0,0);
end;
end getpasswd;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
put$msg: procedure;
call print$buf(.('Putting $'));
if putpb.output$type = list$type then
call print$buf(.('list$'));
else
call print$buf(.('console$'));
if putpb.output$type = input$type then
call print$buf(.(' input to $'));
else
call print$buf(.(' output to $'));
end put$msg;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
print$fn: procedure (fcb$ad);
declare k byte;
declare fcb$ad address;
declare driv based fcb$ad byte;
declare fn based fcb$ad (12) byte;
if getscbbyte(26) < 48 then
call crlf; /* console width */
call print$buf(.('file: $'));
if driv <> 0 then do;
call printchar('@'+driv);
call printchar(':');
end;
do k=1 to 11;
if k=9 then
call printchar('.');
if fn(k) <> ' ' then
call printchar(fn(k));
end;
end print$fn;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
try$open: procedure;
declare (error$code,a) address;
declare prog$flag based a byte;
declare code byte;
error$code = rsx$call(.rsx$fcb$pb);
if error$code <> 0ffh then do; /* ff means no active PUT file */
a = error$code - 2; /* program output only? */
if prog$flag then
a = rsx$call(.rsx$kill$pb); /* kill it if so */
else do;
call print$buf(.warning);
call put$msg;
call print$fn(error$code); /* print the file name */
call user$abort(.(cr,lf,'Do you want another file$'));
end;
end;
call return$errors(0ffh);
call setdma(.passwd); /* set dma to password */
if passwd(0) <> ' ' then
fcb(6) = fcb(6) or 80h;
error$code=make$file(.fcb);
if low(error$code)=0ffh then do; /* make failed? */
code = high(error$code);
if code = 8 then do; /* file already exists */
call print$buf(.warning);
call user$abort(.('File already exists; Delete it$'));
error$code = delete$file(.fcb);
if low(error$code) = 0ffh then do;
code = high(error$code);
if code = 3 then /* file is read only */
call error(5);
if code = 7 then do; /* Password protected */
call getpasswd;
call crlf;
end;
call return$errors(0);
error$code=delete$file(.fcb);
end;
end;
call return$errors(0);
if passwd(0) <> ' ' then
fcb(6) = fcb(6) or 80h;
error$code = make$file(.fcb);
end;
call return$errors(0);
call put$msg;
call print$fn(.fcb); /* print the file name */
call putf(.putpb); /* do PUT processing */
/*call mon1(0,0); debug exit */
end try$open;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
kill$rsx: procedure;
declare (fcb$adr,a) address;
if (delimiter <> 9) and (delimiter <> 2) then /* check for eoln or ']' */
call error(1);
/* remove PUT RSX */
do while (fcb$adr:=rsx$call(.rsx$fcb$pb)) <> 0ffh;
a = rsx$call(.rsx$kill$pb);
call print$buf(.('PUT completed for $'));
call print$fn(fcb$adr);
call crlf;
end;
call put$msg;
if putpb.output$type = list$type then
call print$buf(.('printer$'));
else
call print$buf(.('console$'));
call mon1(0,0);
end kill$rsx;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
output$options: procedure;
declare negate byte;
do while ((delimiter<>2) and (delimiter<>9));
negate = false;
call opt$scanner(.put$options(0),.put$options$offset(0),.index);
if index = 1 then do; /* NOT */
negate = true;
call opt$scanner(.put$options(0),.put$options$offset(0),.index);
end;
if (index=0) or (index=1) then
call error(0);
if index = 2 then do; /* ECHO */
if negate then
putpb.echo$flag = false;
else
putpb.echo$flag = true;
end;
if index = 3 then do; /* RAW output */
if negate then
putpb.filtered$flag = true;
else
putpb.filtered$flag = false;
end;
if index = 4 then do; /* FILTERED output */
if negate then
putpb.filtered$flag = false;
else
putpb.filtered$flag = true;
end;
if index = 5 then do; /* SYSTEM output */
if negate then
putpb.program$flag = true;
else
putpb.program$flag = false;
end;
if index = 6 then do; /* PROGRAM output */
if negate then
putpb.program$flag = false;
else
putpb.program$flag = true;
end;
end;
end output$options;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
process$file: procedure(buf$adr);
declare status address;
declare buf$adr address;
declare char based status byte;
parse$fn.buff$adr = buf$adr;
parse$fn.fcb$adr = .fcb;
status = parse(.parse$fn);
if status = 0ffffh then do;
buf$ptr = parse$fn.buff$adr;
call error(2); /* bad file */
end;
call move(8,.fcb16,.passwd);
if status = 0 then /* eoln */
call try$open;
else do;
buf$ptr = status + 1; /* position buf$ptr past '[' */
if char <> '[' then
call error(4); /* Invalid delimiter */
else do;
call output$options; /* process output options */
call try$open;
end;
end;
end process$file;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
input$found: procedure (buffer$adr) byte;
declare buffer$adr address;
declare char based buffer$adr byte;
do while (char = ' ') or (char = 9); /* tabs & spaces */
buffer$adr = buffer$adr + 1;
end;
if char = 0 then /* eoln */
return false; /* input not found */
else
return true; /* input found */
end input$found;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/*********************************
* *
* M A I N P R O G R A M *
* *
*********************************/
plm:
do;
if (low(version) < cpmversion) or (high(version)=1) then do;
call print$buf(.('Requires CP/M 3.0$'));
call mon1(0,0);
end;
/* default modes for putf call */
if not input$found(.tbuff(1)) then do; /* just PUT, no command tail */
call print$buf(.('CP/M 3 PUT Version 3.0',cr,lf,'$'));
call print$buf(.('Put console output to a file$'));
call print$buf(.(cr,lf,'Enter file: $'));
no$chars = read$console$buf(.tbuff(0),128);
call crlf;
tbuff(1) = ' '; /* blank out nc field */
tbuff(no$chars+2) = 0; /* mark eoln */
if not input$found(.tbuff(1)) then /* quit, no file name */
call mon1(0,0);
do i=1 to no$chars; /* make input capitals */
tbuff(i+1) = ucase(tbuff(i+1));
end;
begin$buffer = .tbuff(2);
buf$length = no$chars;
buf$ptr = .tbuff(2);
call process$file(.tbuff(2));
end;
else do; /* Put with input */
i = 1; /* skip over leading spaces */
do while (tbuff(i) = ' ');
i = i + 1;
end;
begin$buffer = .tbuff(1); /* note beginning of input */
buf$length = tbuff(0); /* note length of input */
buf$ptr = .tbuff(i); /* set up for scanner */
index = 0;
delimiter = 1;
call opt$scanner(.options(0),.options$offset(0),.index);
if (index=6) or (index=7) or (index=10) then do; /* AUX: */
putpb.output$type = aux$type;
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 1 then /* OUTPUT */
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 2 then /* TO */
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 3 then /* FILE */
call process$file(buf$ptr);
else do;
if (index=6) or (index=7) or (index=10) then /* AUX: */
call kill$rsx;
else
call error(3);
end;
end;
else do; /* not AUX, check LST */
if (index=11) or (index=12) or (index=13) then do; /* LIST */
putpb.output$type = list$type;
putpb.echo$flag = false; /* don't echo list output */
rsx$fcb$pb = get$lst$fcb;
rsx$kill$pb = kill$lst$rsx;
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 1 then /* OUTPUT */
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 2 then /* TO */
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 3 then /* FILE */
call process$file(buf$ptr);
if (index=11) or (index=12) or (index=13) then /* LIST */
call kill$rsx;
else
call error(3);
end;
else do; /* normal CONSOLE output */
/* if CONSOLE or CONOUT or CON: */
if (index=4) or (index=5) or (index=9) then do; /* CONSOLE */
if delimiter = 9 then
call kill$rsx;
else
call opt$scanner(.options(0),.options$offset(0),.index);
end;
if index = 1 then /* OUTPUT */
call opt$scanner(.options(0),.options$offset(0),.index);
else if index = 14 then do; /* INPUT */
putpb.output$type = input$type;
putpb.echo$flag = true;
putpb.filtered$flag = false;
rsx$fcb$pb = get$journal$fcb;
rsx$kill$pb = kill$journal$rsx;
call opt$scanner(.options(0),.options$offset(0),.index);
end;
if index = 2 then /* TO */
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 3 then /* FILE */
call process$file(buf$ptr);
if (index=4) or (index=5) or (index=9) then /* CONOUT: or CONSOLE */
call kill$rsx;
else
call error(3);
end;
end;
end;
end;
end put;


578
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/PUTF.ASM Normal file
View File

@@ -0,0 +1,578 @@
$title ('PUTF - CP/M 3.0 Output Redirection - August 1982')
;******************************************************************
;
; PUT 'Redirection Initializer' version 3.0
;
; 11/30/82 - Doug Huskey
;******************************************************************
;
;
; Copyright (c) 1982
; Digital Research
; P.O. Box 579
; Pacific Grove, Ca.
; 93950
;
;
; generation procedure
;
; seteof put.plm
; seteof getscan.dcl
; seteof putf.asm
; seteof getscan.plm
; seteof parse.asm
; is14
; asm80 putf.asm debug
; asm80 mcd80a.asm debug
; asm80 parse.asm debug
; plm80 put.plm pagewidth(100) debug optimize
; link mcd80a.obj,put.obj,parse.obj,putf.obj,plm80.lib to put.mod
; locate put.mod code(0100H) stacksize(100)
; era put.mod
; cpm
; objcpm put
; rmac putrsx
; link putrsx[op]
; era put.rsx
; ren put.rsx=putrsx.prl
; gencom put.com
; gencom put.com put.rsx
;
;
; This module is called as an external routine by the
; PL/M program PUT. The address of a the following
; structure is passed:
;
; declare putpb structure
; (output$type byte,
; echo$flag byte,
; filtered$flag byte,
; system$flag byte);
;
; output$type = 0 > console output (default)
; = 1 > auxiliary output
; = 2 > list output
; = 3 > console input
;
; echo = true > echo output to real device
; (default)
; = false > don't echo output (input is
; still echoed)
; filtered = true > convert control characters
; to a printable form
; preceeded by an ^
; = false > no character conversions
; program = true > continue until user uses
; PUT command to revert to
; console
; = false > active only until program
; termination
public putf
extrn mon1,fcb,memsiz
;
;
true equ 0ffffh
false equ 00000h
;
biosfunctions equ true ;intercept BIOS list or conout
;
;
; low memory locations
;
wboot equ 0000h
wboota equ wboot+1
;
; equates for non graphic characters
;
cr equ 0dh ; carriage return
lf equ 0ah ; line feed
;
; BDOS function equates
;
cinf equ 1 ;read character
coutf equ 2 ;output character
crawf equ 6 ;raw console I/O
creadf equ 10 ;read buffer
cstatf equ 11 ;status
lchrf equ 5 ;list character
pbuff equ 9 ;print buffer
resetf equ 13 ;disk reset
selectf equ 14 ;select disk
openf equ 15 ;open file
closef equ 16 ;close file
delf equ 19 ;delete file
dreadf equ 20 ;disk read
makef equ 22 ;make file
dmaf equ 26 ;set dma function
curdrv equ 25 ;get current drive
dpbf equ 31 ;get dpb address
userf equ 32 ;set/get user number
resdvf equ 37 ;reset drive
scbf equ 49 ;set/get system control block word
rsxf equ 60 ;RSX function call
resalvf equ 99 ;reset allocation vector
pblkf equ 111 ;print block to console
lblkf equ 112 ;print block to list device
ginitf equ 128 ;GET initialization sub-function no.
gkillf equ 129 ;GET delete sub-function no.
gfcbf equ 130 ;GET file display sub-function no.
pinitf equ 132 ;PUT initialization sub-funct no.
pckillf equ 133 ;PUT CON: delete sub-function no.
pcfcbf equ 134 ;return PUT CON: fcb address
plkillf equ 137 ;PUT LST: delete sub-function no.
plfcbf equ 138 ;return PUT LST:fcb address
jinitf equ 140 ;JOURNAL initialization sub-funct no.
jkillf equ 141 ;JOURNAL delete sub-function no.
jfcbf equ 142 ;return JOURNAL fcb address
skillf equ 144 ;SUBMIT delete sub-function no.
sfcbf equ 145 ;SUBMIT fcb address function
svkillf equ 160 ;SAVE delete sub-function no.
;
; System Control Block definitions
;
scba equ 03ah ;offset of scbadr from SCB base
ccpflg1 equ 0b3h ;offset of ccpflags word from page boundary
submit equ 040h ;mask for active submit or get test
errflg equ 0aah ;offset of error flag from page boundary
conmode equ 0cfh ;offset of console mode from page boundary
listcp equ 0d4h ;offset of ^P flag from page boundary
common equ 0f9h ;offset of common memory base from pg. bound
wbootfx equ 068h ;offset of warm boot jmp from page. bound
constfx equ 06eh ;offset of constat jmp from page. bound
coninfx equ 074h ;offset of conin jmp from page. bound
conoufx equ 07ah ;offset of conout jmp from page. bound
listfx equ 080h ;offset of list jmp from page. bound
cstjmp equ 003h ;offset of console status jmp from warm boot
cinjmp equ 006h ;offset of console input jmp from warm boot
coujmp equ 009h ;offset of console output jmp from warm boot
lstjmp equ 00ch ;offset of list output jmp from warm boot
;
; Restore mode equates (used with inr a, rz, rm, ret)
;
norestore equ 0ffh ;no BIOS interception
biosonly equ 07fh ;restore BIOS jump table only
everything equ 0 ;restore BIOS jump table and jmps in
;RESBDOS (default mode)
;
; Instructions
;
lxih equ 21h ;LXI H, instruction
jmpi equ 0c3h ;jump instruction
;
;******************************************************************
; START OF INITIALIZATION CODE
;******************************************************************
cseg
putf:
;get parameters
mov h,b
mov l,c ;HL = .(parameter block)
mov a,m ;output type 0=con:,1=aux:,2=lst:,3=conin:
cpi 1 ;is it aux?
jz notimp ;error if so
cpi 3 ;is it console input only
jnz setlst
sta input ;non-zero => console input
xra a
setlst: sta list ;non-zero => list device
inx h
mov a,m ;echo/noecho mode
sta echo
inx h
mov a,m ;cooked/raw mode
sta cooked
inx h
mov a,m ;system/program mode
sta program
;
;check if enough memory
;
lhld memsiz
mov a,h
cpi 20h
lxi d,memerr
jc error
;
;check if drive specified
lxi h,fcb
mov a,m ;drive code
dcr a ;drive specified?
jp movfcb ;jump if so
;
;set to current drive, if not
;
mvi c,curdrv
push h ;save .fcb
call mon1
pop h ;a=current drive, hl=.fcb
mov m,a ;set fcb to force drive select
inr m ;must be relative to 1
;
movfcb: ;copy default fcb up into data area for move to RSX
;
mov e,a
mvi c,selectf ;make sure drive is selected
push h ;save .fcb
call mon1 ;so we get the right DPB
pop h
lxi d,putfcb
lxi b,32 ;length of fcb
call ldir ;move it to putfcb
;
;initialize other variables to be moved to RSX
;
call getusr ;get current user number
sta putusr ;save for redirection file I/O
call getscbadr
shld scbadr ;System Control Block address
;
;initialize records per block (BLM)
;
mvi c,dpbf
call mon1 ;HL = .disk parameter block
inx h
inx h
inx h ;HL = .blm
mov a,m
sta blm
;
;initialize function table (functions to be intercepted)
;
lda list
ora a
lxi b,funcend-functbl ;count
lxi d,functbl ;destination
lxi h,pcfcbf*256+pckillf ;rsx function codes
jz ckinput
lxi h,listfunc ;list function table
call ldir
mvi a,lchrf
sta bdosfunc ;use list output for bios trap
mvi a,listfx
sta resoff ;offset of fixup for bios list
mvi a,lstjmp
sta biosoff ;offset of bios lst jmp
lxi h,plfcbf*256+plkillf
jmp getrsxadr
ckinput:
lda input
ora a
jz getrsxadr
lxi h,inputfunc
call ldir
mvi a,cinf
sta bdosfunc ;use console input
mvi a,coninfx
sta resoff ;offset of fixup for bios conin
mvi a,cinjmp
sta biosoff
sta echo ;must be non-zero for input
lhld scbadr
mvi l,ccpflg+1
mov a,m
ani submit ;SUBMIT or GET active?
lxi d,noget
jnz error ;error if so
lxi h,jfcbf*256+jkillf
;
;get address of initialization table in RSX
;
getrsxadr:
shld rsxfun
mvi c,rsxf ;PUT is not compatible with SAVE.RSX
lxi d,savkill ;as both SAVE & PUT trap warm starts
call mon1 ;eliminate SAVE.RSX if active
mvi c,rsxf
lxi d,rsxinit
call mon1 ;call PUT.RSX initialization routine
push h ;save address of destination for move
mov e,m
inx h
mov d,m ;DE = .kill flag
push d ;save for later set
;
if biosfunctions
;
inx h
inx h
inx h ;HL = .(.(bios entry in RSX))
push h ;save for getting RSX entry point
;later (in trap:)
;check if BIOS jump table looks valid (jmp in right places)
check: lhld biosoff
xchg
lhld wboota
mov a,m
cpi jmpi ;should be a jump
dad d ;HL = .(jmp address)
mov a,m
cpi jmpi ;should be a jump
jnz bioserr ;skip bios redirection if not
;
;fix up RESBDOS to do BIOS calls to intercepted functions
;
lhld scbadr
mvi l,common+1
mov a,m ;get high byte of common base
ora a
jnz fix0 ;high byte = zero if non-banked
mvi a,biosonly
sta biosmode
jmp trap ;skip code that fixes resbdos
;fix warmboot BIOS jmp in resbdos
fix0: mvi l,wbootfx ;HL = .warm boot fix in SCB
shld wmfix ;save for RSX restore at end
mov a,m
cpi jmpi ;is it a jump instruction?
jz fix1 ;jump if so
mvi a,biosonly ;whoops already traped
sta biosmode
fix1: mvi m,lxih ;change jump to an lxi h,
;fix list bios jmp in resbdos
lda resoff
mov l,a
shld biosfix
mov a,m
cpi jmpi ;is it a jump instruction?
jz biosck ;jump if so
mvi a,biosonly ;whoops already changed
sta biosmode ;restore jump table only
fix3: mvi m,lxih
;
;get address of list entry point
;
trap: pop h ;.(.(bios entry point in RSX))
mov c,m
inx h
mov b,m
push h
lhld biosoff
xchg
lhld wboota
dad d ;HL = .(jmp address)
inx h ;move past jmp instruction
shld biosjmp ;save for RSX restore at end
mov e,m
mov m,c
inx h
mov d,m ;DE = bios routine address
mov m,b ;BIOS jmp jumps to RSX
xchg
shld biosout ;save bios routine address
;get addresses of RSX bios trap
pop h
inx h
mov c,m ;HL = .(.(bios warm start in RSX))
inx h
mov b,m ;BC = .bios warmstart entry in RSX
;
;patch RSX wmboot entry into BIOS jump table
;save real wmboot address in RSX exit table
;
lhld wboota
inx h
shld wmjmp ;save for RSX restore at end
mov e,m
mov m,c
inx h
mov d,m
mov m,b
xchg
shld wmsta ;save real bios warm start routine
endif
;
;move data area to RSX
;
rsxmov:
pop h ;HL = .(kill flag = 0FFh)
inr m ;set to zero for redirection active
lxi h,movstart
pop d ;RSX data area address
lxi b,movend-movstart
call ldir
jmp wboot
;
; auxiliary redirection
;
notimp:
lxi d,notdone
error:
mvi c,pbuff
call mon1
mvi c,closef
lxi d,fcb
call mon1
mvi c,delf
lxi d,fcb
call mon1
jmp wboot
if biosfunctions
;
; check if warm boot was fixed up by someone
; and list or console output was not
;
biosck: lda biosmode
cpi biosonly
jnz fix3 ;warm boot not fixed up
;
; can't do BIOS redirection
;
bioserr:
lxi d,nobios
mvi c,pbuff
call mon1
lxi h,biosmode
mvi m,norestore
pop h ;throw away stacked bios entry
jmp rsxmov
endif
;
; get/set user number
;
getusr: mvi a,0ffh ;get current user number
setusr: mov e,a ;set current user number (in A)
mvi c,userf
jmp mon1
;
; get system control block address
; (BDOS function #49)
;
; exit: hl = system control block address
;
getscbadr:
mvi c,scbf
lxi d,data49
jmp mon1
;
data49: db scba,0 ;data structure for getscbadd
;
;
; copy memory bytes (emulates z80 ldir instruction)
;
ldir: mov a,m ;get byte
stax d ;store it at destination
inx h ;advance pointers
inx d
dcx b ;decrement byte count
mov a,c ;loop if non-zero
ora b
jnz ldir
ret
;
;******************************************************************
; DATA AREA
;******************************************************************
;
; equates function table
;
eot equ 0ffh ; end of function table
skipf equ 0feh ; skip this function
;
listfunc:
db lchrf, lblkf, coutf, cstatf, crawf
db pbuff, cinf, creadf, resetf, resdvf
db resalvf, pblkf, eot
; Note that the list routines precede the console
; routines so that the CKLIST: routine in PUTRSX
; can distinquish list functions from console
; functions.
inputfunc: ;preset for console input
db skipf, skipf, skipf, skipf, crawf
db skipf, cinf, creadf, resetf, resdvf
db resalvf, eot, skipf
;
savkill: db svkillf
rsxinit: db Pinitf
nobios: db cr,lf,'WARNING: Cannot redirect from BIOS',cr,lf,'$'
notdone:
db cr,lf
db 'ERROR: Auxiliary device redirection not implemented',cr,lf,'$'
memerr:
db cr,lf
db 'ERROR: Insufficient Memory',cr,lf,'$'
noget:
db cr,lf
db 'ERROR: You cannot PUT INPUT to a file',cr,lf
db ' when using GET or SUBMIT.',cr,lf,'$'
resoff: db conoufx
biosoff: dw coujmp
aux: db 0
;
;******************************************************************
; Following variables are initialized by PUT.COM
; and moved to the PUT RSX - Their order must not be changed
;******************************************************************
;
;
movstart:
inittable: ;addresses used by PUT.COM for
scbadr: dw 0 ;address of System Control Block
;
if biosfunctions ;PUT.RSX initialization
;
gobios: mov c,e
db jmpi
biosout:
dw 0 ;set to real BIOS routine
;
;restore only if changed when removed.
biosjmp:
dw 0 ;address of bios jmp initialized by COM
biosfix:
dw 0 ;address of jmp in resbdos to restore
db jmpi
wmsta: dw 0 ;address of real warm start routine
wmjmp: dw 0 ;address of jmp in bios to restore
wmfix: dw 0 ;address of jmp in resbdos to restore
bdosfunc:
db coutf
biosmode:
db 0 ;0FFh = no bios restore, 07fh = restore
;only bios jmp, 0 = restore bios jump and
;resbdos jmp when removed.
endif
functbl: ;preset for console output
db skipf, skipf, coutf, cstatf, crawf, pbuff
db cinf, creadf, resetf, resdvf, resalvf, pblkf, eot
funcend:
;
input: db 0 ;non-zero if putting input to a file
list: db 0 ;TRUE if list output redirection
echo: db 1 ;echo output to device
cooked: ;must be next after echo
db 0 ;TRUE if ctrl chars displayed with ^
rsxfun:
pkillf: db 255 ;put abort routine code
pfcbf: db 255 ;put FCB display function no.
; ********** remaining variables must be in this order
record: db 0 ;counts down records to block boundary
blm: db 0 ;block mask = records per block (rel 0)
program: ;This must be @ .putfcb-2
db 0
putusr: db 0 ;user number for redirection file
putfcb: db 1 ;a
db 'SYSOUT '
db '$$$'
db 0,0
putmod: db 0
putrc: db 0
ds 16 ;map
putcr: db 0
;
cbufp: db 0
movend:
;*******************************************************************
end


877
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/PUTRSX.ASM Normal file
View File

@@ -0,0 +1,877 @@
title 'PUT.RSX 3.0 - CP/M 3.0 Output Redirection - August 1982'
;******************************************************************
;
; PUT 'Output Redirection Facility' version 3.0
;
; 11/30/82 - Doug Huskey
; This RSX redirects console or list output to a file.
;******************************************************************
;
;
; generation procedure
;
; rmac putrsx
; xref putrsx
; link putrsx[op]
; ERA put.RSX
; REN put.RSX=putRSX.PRL
; GENCOM put.com put.rsx
;
; initialization procedure
;
; PUTF makes a RSX function 60 call with a sub-function of
; 128. PUTRSX returns the address of a data table containing:
;
; init$table:
; dw kill ;remove PUT at warmboot flg
; dw 0 ;reserved
; dw bios$output ;BIOS entry point into PUT
; dw putfcb ;FCB address
;
; PUTF initializes the data are between movstart: and movend:
; and moves it into PUT.RSX. This means that data should not
; be reordered without also changing PUTF.ASM.
;
;
true equ 0ffffh
false equ 00000h
;
bios$functions equ true ;intercept BIOS console functions
remove$rsx equ false ;this RSX does its own removal
;
; low memory locations
;
wboot equ 0000h
wboota equ wboot+1
bdos equ 0005h
bdosl equ bdos+1
buf equ 0080h
;
; equates for non graphic characters
;
ctlc equ 03h ; control c
ctle equ 05h ; physical eol
ctlh equ 08h ; backspace
ctlp equ 10h ; prnt toggle
ctlr equ 12h ; repeat line
ctls equ 13h ; stop/start screen
ctlu equ 15h ; line delete
ctlx equ 18h ; =ctl-u
ctlz equ 1ah ; end of file
rubout equ 7fh ; char delete
tab equ 09h ; tab char
cr equ 0dh ; carriage return
lf equ 0ah ; line feed
ctl equ 5eh ; up arrow
;
; BDOS function equates
;
cinf equ 1 ;read character
coutf equ 2 ;output character
crawf equ 6 ;raw console I/O
creadf equ 10 ;read buffer
cstatf equ 11 ;status
lchrf equ 5 ;print character
pbuff equ 9 ;print buffer
resetf equ 13 ;reset drive
openf equ 15 ;open file
closef equ 16 ;close file
delf equ 19 ;delete file
dreadf equ 20 ;disk read
writef equ 21 ;disk write
dmaf equ 26 ;set dma function
userf equ 32 ;set/PUT user number
resdvf equ 37 ;reset drive function
flushf equ 48 ;flush buffers function
scbf equ 49 ;set/PUT system control block word
loadf equ 59 ;Program load function
rsxf equ 60 ;RSX function call
resalvf equ 98 ;reset allocation vector
pblkf equ 111 ;print block to console
lblkf equ 112 ;print block to list device
ginitf equ 128 ;GET initialization sub-function no.
gkillf equ 129 ;GET delete sub-function no.
gfcbf equ 130 ;GET file display sub-function no.
pinitf equ 132 ;PUT initialization sub-function no.
pckillf equ 133 ;PUT console delete sub-function no.
plkillf equ 137 ;PUT list delete sub-function no.
pcfcbf equ 134 ;return PUT console fcb address
plfcbf equ 138 ;return PUT list fcb address
jinitf equ 140 ;JOURNAL initialization sub-function no.
jkillf equ 141 ;JOURNAL delete sub-function no.
jfcbf equ 142 ;return JOURNAL fcb address
;
; System Control Block definitions
;
scba equ 03ah ;offset of scbadr from SCB base
ccpflg equ 0b3h ;offset of ccpflags word from page boundary
ccpres equ 020h ;ccp resident flag = bit 5
bdosoff equ 0feh ;offset of BDOS address from page boundary
errflg equ 0aah ;offset of error flag from page boundary
conmode equ 0cfh ;offset of console mode word from pag. bound.
outdel equ 0d3h ;offset of print buffer delimiter
listcp equ 0d4h ;offset of ^P flag from page boundary
usrcode equ 0e0h ;offset of user number from pg bnd.
dcnt equ 0e1h ;offset of dcnt, searcha & searchl from pg bnd.
constfx equ 06eh ;offset of constat JMP from page boundary
coninfx equ 074h ;offset of conin JMP from page boundary
;
;
;******************************************************************
; RSX HEADER
;******************************************************************
serial: db 0,0,0,0,0,0
trapjmp:
jmp trap ;trap read buff and DMA functions
next: jmp 0 ;go to BDOS
prev: dw bdos
kill: db 0FFh ;Remove at wstart if not zero
nbank: db 0
rname: db 'PUT ' ;RSX name
space: dw 0
patch: db 0
;******************************************************************
; START OF CODE
;******************************************************************
;
; ABORT ROUTINE
;
puteof: ;close output file and abort
lda cbufp
ora a
jz restor
mvi e,ctlz
call putc
jmp puteof
;
;******************************************************************
; BIOS TRAP ENTRY POINT
;******************************************************************
;
;
; ARRIVE HERE ON EACH INTERCEPTED BIOS CALL
;
;
bios$output:
;
if bios$functions
;
;enter here from BIOS constat
mov e,c ;character in E
lda bdosfunc ;BDOS function to use
mov c,a
mvi a,1 ;offset in exit table = 1
jmp bios$trap
endif
;
;
;******************************************************************
; BDOS TRAP ENTRY POINT
;******************************************************************
;
;
; ARRIVE HERE AT EACH BDOS CALL
;
trap:
;
if bios$functions
;
xra a
biostrap:
;enter here on BIOS calls
sta exit$off
endif
pop h ;return address
push h ;back to stack
lda trapjmp+2 ;PUT.RSX page address
cmp h ;high byte of return address
jc exit ;skip calls on bdos above here
mov a,c
cpi rsxf
jz rsxfunc ;check for initialize or abort
cpi dmaf
jz dmafunc ;save users DMA address
cpi 14 ;reset function + 1
jc tbl$srch ;search if func < 14
cpi 98
jnc tbl$srch ;search if func >= 98
cpi resdvf
jz tbl$srch ;search if func = 37
;
; EXIT - FUNCTION NOT MATCHED
;
exit:
if not bios$functions
;
exit1: jmp next ;go to next RSX or BDOS
else
lda exit$off ;PUT type of call:
exit1: lxi h,exit$table ;0=BDOS call, 1=BIOS call
endif
tbl$jmp:
; a = offset (rel 0)
; hl = table address
add a ;double for 2 byte addresses
call addhla ;HL = .(exit routine)
mov b,m ;get low byte from table
inx h
mov h,m
mov l,b ;HL = exit routine
pchl ;gone to BDOS or BIOS
tbl$srch:
;
;CHECK IF THIS FUNCTION IS IN FUNCTION TABLE
;if matched b = offset in table (rel 0)
;FF terminates table
;FE is used to mark non-intercepted functions
;
lxi h,func$tbl ;list of intercepted functions
mvi b,0 ;start at beginning
tbl$srch1:
mov a,m ;get next table entry
cmp c ;is it the same?
jz intercept ;we found a match, B = offset
inr b
inx h
inr a ;0FFh terminates list
jnz tbl$srch1 ;try next one
jmp exit ;end of table - not found
;
;
;******************************************************************
; REDIRECTION PROCESSOR
;******************************************************************
;
;
; INTERCEPTED BDOS FUNCTIONS ARRIVE HERE
;
; enter with
; B = routine offset in table
; C = function number
; DE = BDOS parameters
intercept:
;switch to local stack
lxi h,0
dad sp
shld oldstack
lxi sp,stack
redirect:
push d ;save info
push b ;save function
lhld scbadr
;
;are we active now?
;
lda program
ora a ;program output only?
cnz ckccp ;if not, test if CCP is calling
jz cklist ;jump if not CCP or program output
mov a,c
cpi 0ah ;is it function 10?
jnz skip ;skip if not
lxi h,ccpcnt ;decrement once for each
dcr m ;CCP function 10
cm puteof ;if 2nd appearance of CCP
jmp skip ;if CCP is active
;
;check for list processing and ^P status
;
cklist:
lda list
ora a ;list redirection?
jz ckecho ;jump if not
mvi l,listcp ;HL = .^P flag
mov a,m
ora a ; ^P on?
jnz setecho ;set echo on if so
mov a,b
cpi 2 ;console function?
jnc skip ;skip if so
ckecho: lda echoflg ;echo parameter
setecho:
sta echo
;
;go to function trap routine
;
gofunct:
lxi h,retmon ;program return routine
push h ;push on stack
mov a,b ;offset
lxi h,trap$tbl
jmp tbl$jmp ;go to table address
;
;
rawio:
;direct console i/o - read if 0ffh
;returns to retmon
mov a,e
cpi 0fdh
jc putchr
cpi 0feh
rz ;make the status call (FE)
jc conin ;make the input call (FD)
call next ;call for input/status (FF)
ora a
jz retmon1
jmp conin1
;
;input function
;
conin:
call exit ;make the call
conin1: mov e,a ;put character in E
push psw ;save character
call conout ;put character into file
pop psw ;character in A
;
; RETURN FROM FUNCTION TRAP ROUTINE
;
cpi cr
jnz retmon1
retmon2:
;output linefeed before returning
push psw ;save character
lda echo
ora a ;no echo mode
mvi e,lf
mvi c,coutf
cz next ;output lf if so
lda input
ora a
cnz conout
pop psw ;restore character
retmon1:
;return to calling program
lhld old$stack
sphl
mov l,a
retmon0:
ret ;to calling program
;
retmon:
;echo before returning?
lda echo
ora a
jz retmon1 ;return to program if no echo
;otherwise continue
;
; PERFORM INTERCEPTED BDOS CALL
;
skip:
;restore BDOS call and stack
pop b ;restore BDOS function no.
pop d ;restore BDOS parameter
lhld old$stack
sphl
jmp exit ;goto BDOS
;******************************************************************
; BIOS FUNCTIONS (REDIRECTION ROUTINES)
;******************************************************************
;
putchr:
;put out character in E unless putting input
lda input! ora a! rnz ;return (retmon) if input redirection
listf:
conout:
conoutf:
ctlout:
;send E character with possible preceding up-arrow
mov a,e! cpi ctlz! jz ctlout1 ;always convert ^Z
call echoc ;cy if not graphic (or special case)
jnc putc ;skip if graphic, tab, cr, lf, or ctlh
ctlout1:
;send preceding up arrow
push psw! mvi e,ctl! call putc ;up arrow
pop psw! ori 40h ;becomes graphic letter
mov e,a ;ready to print
;(drop through to PUTC)
;
;
; put next character into file
;
;
putc: ;write sector if full, close in each physical block
;abort PUT if any disk error occurs
;character in E
lxi h,cbufp
mov a,m ; A = cbufp
push h
inx h ;HL = .cbuf
call addhla ;HL = .char
mov m,e ;store character
pop h
inr m ;next chr position
rp ;minus flag set after 128 chars
;
; WRITE NEXT RECORD
;
write:
mvi c,writef
call putdos
cnz restor ;abort RSX if error
xra a
sta cbufp ;reset buffer position to 0
lxi h,record
dcr m ;did we cross the block boundary?
rp ;return if not
call close ;close the file if so
cnz restor ;abort RSX if error
lxi h,blm ;HL = .blm
mov a,m
dcx h
mov m,a ;set record = blm
ret
;
; CLOSE THE FILE
;
close:
mvi c,closef
;
; PUT FILE OPERATION
;
putdos:
push b ;function no. in C
lxi d,cbuf
call setdma ;set DMA to our buffer
pop b ;function no. in C
lhld scbadr
push h ;save for restore
lxi d,sav$area ;10 byte save area
push d ;save for restore
call mov7 ;save hash info in save area
mvi l,usrcode ;HL = .BDOS user number in SCB
call mov7 ;save user, dcnt, search addr, len &
dcx h ; multi-sector count
mvi m,1 ;set multi-sector count=1
mvi l,usrcode ;HL = .BDOS user number
lxi d,putusr
ldax d
mov m,a ;set BDOS user = putusr
inx d ;DE = .putfcb
call next ;write next record or close file
pop h ;HL = .sav$area
pop d ;DE = .scb
push psw ;save A (non-zero if error)
call mov7 ;restore hash info
mvi e,usrcode ;DE = .user num in scb
call mov7 ;restore dcnt search addr & len
lhld udma
xchg
call setdma ;restore DMA to program's buffer
pop psw
ora a
ret ;zero flag set if successful
;
; CLOSE FILE AND TERMINATE RSX
;
restor:
call close
lxi d,close$err
cnz msg ;print message if close error
lxi h,0ffffh
shld rsxfunctions ;set killf and fcbf to inactive
;
;set RSX aborted flag
;
lxi h,kill ;0=active, 0ffh=aborted
mvi m,0ffh ;set to 0ffh (in-active)
;are we the bottom RSX, if so remove ourselves immediately
;to save memory
lda bdosl+1 ;get high byte of top of tpa
CMP H ;Does location 6 point to us
if remove$rsx
jnz bios$fixup ;done, if not
lhld next+1
shld bdosl
xchg
lhld scbadr
mvi l,bdosoff ;HL = "BDOS" address in SCB
mov m,e ;put next address into SCB
inx h
mov m,d
xchg
mvi l,0ch ;HL = .previous RSX field in next RSX
mvi m,7
inx h
mvi m,0 ;put previous into previous
else
mvi c,loadf
lxi d,0
cz next ;fixup RSX chain, if this RSX on bottom
endif
if bios$functions
bios$fixup:
;
;restore bios jumps
lda restore$mode ;may be FF, 7f or 0
inr a
rz ; FF = no bios interception
lhld wmsta ;real warm start routine
xchg
lhld wmjmp ;wboot jump in bios
mov m,e
inx h
mov m,d ;restore real routine in jump
lhld biosout ;conin,conout or list jmp
xchg
lhld biosjmp ;address of real bios routine
mov m,e
inx h
mov m,d
rm ; 7f = RESBDOS jmps not changed
lhld wmfix
mvi m,jmp ;replace jmp for warm start
lhld biosfix
mvi m,jmp ;replace jmp for other trapped jump
endif
ret ; 0 = everything done
;
; set DMA address in DE
;
setdma: mvi c,dmaf
jmp next
;
; print message to console
;
msg: mvi c,pbuff
jmp next
;
; move routine
;
mov7: mvi b,7
; HL = source
; DE = destination
; B = count
move: mov a,m
stax d
inx h
inx d
dcr b
jnz move
ret
;
; add a to hl
;
addhla: add l
mov l,a
rnc
inr h
ret
;
; check if CCP is calling
;
ckccp:
;returns zero flag set if not CCP
lhld scbadr
mvi l,ccpflg+1 ;HL = .ccp flag 2
mov a,m
ani ccpres ;is it the CCP?
ret
;
;******************************************************************
; BDOS FUNCTION HANDLERS
;******************************************************************
;
;
; FUNCTION 26 - SET DMA ADDRESS
;
dmafunc:
xchg ;dma to hl
shld udma ;save it
xchg
jmp next
;
;
; BIOS WARM START TRAP FUNCTION
;
warmtrap:
lxi sp,stack
call close ;close if wboot originated below RSX
jmp wstart
;
; BDOS FUNCTION 60 - RSX FUNCTION CALL
;
rsxfunc: ;check for initialize or delete RSX functions
ldax d ;get sub-function number
cpi pinitf ;is it a PUT initialization
lxi h,init$table
rz ;return to caller if init call
;check for FCB display functions
mov b,a
lda fcbf ;is it a a PUT fcb request
cmp b
lxi h,putfcb
rz ;return if so
;check for kill function
lda killf ;local kill (kill only this one)
cmp b
jz puteof ;kill and return to caller
jmp exit ;abort any higher PUTs
;
;
;******************************************************************
; BDOS OUTPUT ROUTINES
;******************************************************************
;
;
; July 1982
;
;
; Console handlers
;
echoc:
;are we in cooked or raw mode?
lda cooked! ora a! mov a,e! rz ;return if raw
;echo character if graphic
;cr, lf, tab, or backspace
cpi cr! rz ;carriage return?
cpi lf! rz ;line feed?
cpi tab! rz ;tab?
cpi ctlh! rz ;backspace?
cpi ' '! ret ;carry set if not graphic
;
;
print:
;print message until M(DE) = '$'
lhld scbadr
mvi l,OUTDEL
ldax d! CMP M! rz ;stop on delimiter
;more to print
inx d! push d! mov e,a ;char to E
call conout ;another character printed
pop d! jmp print
;
;
read:
;put prompt if in no echo mode
lda echo! ora a! jnz read1
push d
lxi d,prompt! call msg ;output prompt
pop d! mvi c,creadf ;set for read call
read1:
;read console buffer
pop h ;throw away return address
push d
call next ;make the call
pop h! inx h! mov b,m! inr b ;get the buffer length
putnxt: dcr b! jz read2
inx h! mov e,m! push b! push h
call conout! pop h! pop b ;put character
jmp putnxt
read2: lda input! ora a! push psw
mvi e,cr! cnz conout ;call if putting input
pop psw! mvi e,lf! cnz conout ;call if putting input
jmp retmon1
;
func1: equ conin
;
func2: equ conout
;write console character
;
func5: equ listf
;write list character
;write to list device
;
func6: equ rawio
;
func9: equ print
;write line until $ encountered
;
func10: equ read
;
func11: equ retmon0
;
func13: equ close
;
func37: equ close
;
func98: equ close
;
FUNC111: ;PRINT BLOCK TO CONSOLE
FUNC112: ;LIST BLOCK
XCHG! MOV E,M! INX H! MOV D,M! INX H
MOV C,M! INX H! MOV B,M! XCHG
;HL = ADDR OF STRING
;BC = LENGTH OF STRING
BLK$OUT:
MOV A,B! ORA C! RZ ;is length 0, return if so
PUSH B! PUSH H
mov e,m! call conout ;put character
POP H! INX H! POP B! DCX B
JMP BLK$OUT
; end of BDOS Console module
;******************************************************************
; DATA AREA
;******************************************************************
exit$off db 0 ;offset in exit$table of destination
trap$tbl:
;function dispatch table (must match func$tbl below)
; db lchrf, lblkf, coutf, cstatf, crawf
; db pbuff, cinf, creadf, resetf, resdvf
; db resalvf, pblkf, eot
dw func5 ;function 5 - list output
dw func112 ;function 112 - list block
dw func2 ;function 2 - console output
dw func11 ;function 11 - console status
dw func6 ;function 6 - raw console I/O
dw func9 ;function 9 - print string
dw func1 ;function 1 - console input
dw func10 ;function 10 - read console buffer
dw func13 ;function 13 - disk reset (close first)
dw func37 ;function 37 - drive reset (close first)
dw func98 ;function 98 - reset allocation vector
dw func111 ;function 111 - print block
;******************************************************************
; Following variables and entry points are used by PUT.COM
; Their order and contents must not be changed without also
; changing PUT.COM.
;******************************************************************
movstart:
init$table: ;addresses used by PUT.COM for initial.
scbadr: ;address of System Control Block
dw kill ;kill flag for error on file make
;(passed to PUT.COM by RSX init function)
;
if bios$functions ;PUT.RSX initialization
;
gobios: mov c,e
db jmp
biosout dw bios$output ;set to real BIOS routine
;(passed to PUT.COM by RSXFUNC)
biosjmp
dw warm$trap ;address of bios jmp initialized by COM
biosfix
dw 0 ;address of jmp in resbdos to restore
;restore only if changed when removed.
wstart: db jmp
wmsta: dw 0 ;address of real warm start routine
wmjmp: dw 0 ;address of jmp in bios to restore
wmfix: dw 0 ;address of jmp in resbdos to restore
bdosfunc:
db coutf
restore$mode
db 0 ;0FFh = no bios restore, 07fh = restore
;only bios jmp, 0 = restore bios jump and
;resbdos jmp when removed.
endif
;
; equates function table
;
eot equ 0ffh ; end of function table
skipf equ 0feh ; skip this function
;
;
func$tbl: ;no trapping until initialized by PUT.COM
db eot,0,0,0,0,0,0,0,0,0,0,0,0
; db lchrf, lblkf, coutf, cstatf, crawf
; db pbuff, cinf, creadf, resetf, resdvf
; db resalvf, pblkf, eot
;
input db 0 ;put console input to a file
list db 0 ;intercept list functions
echoflg:
db 1 ;echo output to device
cooked: ;must be next after echo
db 0 ;TRUE if ctrl chars (except ^Z) placed
;in the output file
rsxfunctions:
killf: db 0ffh ;not used until PUT initialized
fcbf: db 0ffh ;not used until PUT initialized
record: db 0 ;counts down records to block boundary
blm: db 0 ;block mask = records per block (rel 0)
program: ;this flag must be @ .PUTFCB-2
db 0 ;true if put program output only
putusr: db 0 ;user number for redirection file
putfcb: db 0ffh ;preset to 0ffh to indicate not active
db 'SYSOUT '
db '$$$'
db 0,0
putmod: db 0
putrc: ds 1
ds 16 ;map
putcr: ds 1
;
cbufp db 0 ;current character position in cbuf
movend:
;*******************************************************************
cbuf: ;128 byte buffer (could be ds 128)
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3
;
if bios$functions
;
exit$table: ;addresses to go to on exit
dw next ;BDOS
dw gobios
endif
;
udma: dw buf ;user dma
user: db 0 ;user user number
echo: db 0 ;echo output to console flag
ccpcnt: db 1 ;start at 1 (decremented each CCP)
sav$area: ;14 byte save area
db 68h,68h,68h,68h,68h, 68h,68h,68h,68h,68h
db 68h,68h,68h,68h
close$err:
db cr,lf,'PUT ERROR: FILE ERASED',cr,lf,'$'
prompt: db cr,lf,'PUT>$'
;
patch$area:
ds 30h
db ' 151282 '
db ' COPYR ''82 DRI '
db 67h,67h,67h,67h, 67h,67h,67h,67h, 67h,67h,67h,67h
db 67h,67h,67h,67h, 67h,67h,67h,67h, 67h,67h,67h,67h
db 67h,67h,67h,67h, 67h,67h,67h,67h
;
stack: ;16 level stack
oldstack:
dw 0
end


1
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/README.MARKDOWN Normal file
View File

@@ -0,0 +1 @@
CP/M 3.0 SOURCE

609
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/RENAME.PLM Normal file
View File

@@ -0,0 +1,609 @@
$ TITLE('CP/M 3.0 --- REN ')
ren:
do;
/*
Copyright (C) 1982
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
*/
/*
Revised:
19 Jan 80 by Thomas Rolander
14 Sept 81 by Doug Huskey
23 June 82 by John Knight
29 Sept 82 by Thomas J. Mason
03 Dec 82 by Bruce Skidmore
*/
declare
mpmproduct literally '01h', /* requires mp/m */
cpmversion literally '30h'; /* requires 3.0 cp/m */
declare
true literally '0FFh',
false literally '0',
forever literally 'while true',
lit literally 'literally',
proc literally 'procedure',
dcl literally 'declare',
addr literally 'address',
cr literally '13',
lf literally '10',
ctrlc literally '3',
ctrlx literally '18h',
bksp literally '8',
dcnt$offset literally '45h',
searcha$offset literally '47h',
searchl$offset literally '49h',
hash1$offset literally '00h',
hash2$offset literally '02h',
hash3$offset literally '04h';
declare plm label public;
/**************************************
* *
* B D O S INTERFACE *
* *
**************************************/
mon1:
procedure (func,info) external;
declare func byte;
declare info address;
end mon1;
mon2:
procedure (func,info) byte external;
declare func byte;
declare info address;
end mon2;
mon3:
procedure (func,info) address external;
declare func byte;
declare info address;
end mon3;
declare cmdrv byte external; /* command drive */
declare fcb (1) byte external; /* 1st default fcb */
declare fcb16 (1) byte external; /* 2nd default fcb */
declare pass0 address external; /* 1st password ptr */
declare len0 byte external; /* 1st passwd length */
declare pass1 address external; /* 2nd password ptr */
declare len1 byte external; /* 2nd passwd length */
declare tbuff (1) byte external; /* default dma buffer */
/**************************************
* *
* B D O S Externals *
* *
**************************************/
read$console:
procedure byte;
return mon2 (1,0);
end read$console;
conin:
procedure byte;
return mon2(6,0ffh);
end conin;
printchar:
procedure (char);
declare char byte;
call mon1 (2,char);
end printchar;
print$buf:
procedure (buffer$address);
declare buffer$address address;
call mon1 (9,buffer$address);
end print$buf;
read$console$buf:
procedure (buffer$address,max) byte;
declare buffer$address address;
declare new$max based buffer$address byte;
declare max byte;
new$max = max;
call mon1 (10,buffer$address);
buffer$address = buffer$address + 1;
return new$max; /* actually number of chars input */
end read$console$buf;
check$con$stat:
procedure byte;
return mon2 (11,0);
end check$con$stat;
version: procedure address;
/* returns current cp/m version # */
return mon3(12,0);
end version;
search$first:
procedure (fcb$address) byte;
declare fcb$address address;
return mon2 (17,fcb$address);
end search$first;
search$next:
procedure byte;
return mon2 (18,0);
end search$next;
delete$file:
procedure (fcb$address);
declare fcb$address address;
call mon1 (19,fcb$address);
end delete$file;
rename$file:
procedure (fcb$address) address;
declare fcb$address address;
return mon3 (23,fcb$address);
end rename$file;
setdma: procedure(dma);
declare dma address;
call mon1(26,dma);
end setdma;
/* 0ff => return BDOS errors */
return$errors:
procedure(mode);
declare mode byte;
call mon1 (45,mode);
end return$errors;
declare
parse$fn structure (
buff$adr address,
fcb$adr address);
parse: procedure (pfcb) address external;
declare pfcb address;
end parse;
declare scbpd structure
(offset byte,
set byte,
value address);
getscbbyte:
procedure (offset) byte;
declare offset byte;
scbpd.offset = offset;
scbpd.set = 0;
return mon2(49,.scbpd);
end getscbbyte;
getscbword:
procedure (offset) address;
declare offset byte;
scbpd.offset = offset;
scbpd.set = 0;
return mon3(49,.scbpd);
end getscbword;
setscbword:
procedure (offset,value);
declare offset byte;
declare value address;
scbpd.offset = offset;
scbpd.set = 0FEh;
scbpd.value = value;
call mon1(49,.scbpd);
end setscbword;
/**************************************
* *
* GLOBAL VARIABLES *
* *
**************************************/
/* Note: there are three fcbs used by
this program:
1) new$fcb: the new file name
(this can be a wildcard if it
has the same pattern of question
marks as the old file name)
Any question marks are replaced
with the corresponding filename
character in the old$fcb before
doing the rename function.
2) cur$fcb: the file to be renamed
specified in the rename command.
(any question marks must correspond
to question marks in new$fcb).
3) old$fcb: a fcb in the directory
matching the cur$fcb and used in
the bdos rename function. This
cannot contain any question marks.
*/
declare successful lit '0FFh';
declare failed (*) byte data(cr,lf,'ERROR: Not renamed, $'),
read$only (*) byte data(cr,lf,'ERROR: Drive read only.$'),
bad$wildcard (*) byte data('Invalid wildcard.$');
declare passwd (8) byte;
declare
new$fcb$adr address, /* new name */
new$fcb based new$fcb$adr (32) byte;
declare cur$fcb (33) byte; /* current fcb (old name) */
/**************************************
* *
* S U B R O U T I N E S *
* *
**************************************/
/* upper case character from console */
crlf: proc;
call printchar(cr);
call printchar(lf);
end crlf;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* fill string @ s for c bytes with f */
fill: proc(s,f,c);
dcl s addr,
(f,c) byte,
a based s byte;
do while (c:=c-1)<>255;
a = f;
s = s+1;
end;
end fill;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* error message routine */
error: proc(code);
declare
code byte;
if code = 0 then do;
call print$buf(.('ERROR: No such file to rename.$'));
call mon1(0,0);
end;
if code=1 then do;
call print$buf(.(cr,lf,'Disk I/O.$'));
call mon1(0,0);
end;
if code=2 then do;
call print$buf(.read$only);
call mon1(0,0);
end;
if code = 3 then
call print$buf(.read$only(15));
if code = 5 then
call print$buf(.('Currently Opened.$'));
if code = 7 then
call print$buf(.('Bad password.$'));
if code = 8 then
call print$buf(.('file already exists$'));
if code = 9 then do;
call print$buf(.bad$wildcard);
call mon1(0,0);
end;
end error;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* print file name */
print$file: procedure(fcbp);
declare k byte;
declare typ lit '9'; /* file type */
declare fnam lit '11'; /* file type */
declare
fcbp addr,
fcbv based fcbp (32) byte;
do k = 1 to fnam;
if k = typ then
call printchar('.');
call printchar(fcbv(k) and 7fh);
end;
end print$file;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* try to rename fcb at old$fcb$adr to name at new$fcb$adr
return error code if unsuccessful */
rename:
procedure(old$fcb$adr) byte;
declare
old$fcb$adr address,
old$fcb based old$fcb$adr (32) byte,
error$code address,
code byte;
call move (16,new$fcb$adr,old$fcb$adr+16);
call setdma(.passwd); /* password */
call return$errors(0FFh); /* return bdos errors */
error$code = rename$file (old$fcb$adr);
call return$errors(0); /* normal error mode */
if low(error$code) = 0FFh then do;
code = high(error$code);
if code < 3 then
call error(code);
return code;
end;
return successful;
end rename;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* upper case character from console */
ucase: proc(c) byte;
dcl c byte;
if c >= 'a' then
if c < '{' then
return(c-20h);
return c;
end ucase;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* get password and place at fcb + 16 */
getpasswd: proc;
dcl (i,c) byte;
call crlf;
call print$buf(.('Enter password: ','$'));
retry:
call fill(.passwd,' ',8);
do i = 0 to 7;
nxtchr:
if (c:=ucase(conin)) >= ' ' then
passwd(i)=c;
if c = cr then do;
call crlf;
go to exit;
end;
if c = ctrlx then
goto retry;
if c = bksp then do;
if i<1 then
goto retry;
else do;
passwd(i:=i-1)=' ';
goto nxtchr;
end;
end;
if c = ctrlc then
call mon1(0,0);
end;
exit:
c = check$con$stat; /* clear raw I/O mode */
end getpasswd;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* check for wildcard in rename command */
wildcard: proc byte;
dcl (i,wild) byte;
wild = false;
do i=1 to 11;
if cur$fcb(i) = '?' then
if new$fcb(i) <> '?' then do;
call print$buf(.failed);
call print$buf(.bad$wildcard);
call mon1(0,0);
end;
else
wild = true;
end;
return wild;
end wildcard;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* set up new name for rename function */
set$new$fcb: proc(old$fcb$adr);
dcl old$fcb$adr address,
old$fcb based old$fcb$adr (32) byte;
dcl i byte;
old$fcb(0) = cur$fcb(0); /* set up drive */
do i=1 to 11;
if cur$fcb(i) = '?' then
new$fcb(i) = old$fcb(i);
end;
end set$new$fcb;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* try deleting files one at a time */
single$file:
procedure;
declare (code,dcnt) byte;
declare (old$fcb$adr,savdcnt,savsearcha,savsearchl) addr;
declare old$fcb based old$fcb$adr (32) byte;
declare (hash1,hash2,hash3) address;
file$err: procedure(fcba);
dcl fcba address;
call print$buf(.failed);
call print$file(fcba);
call printchar(' ');
call error(code);
end file$err;
call setdma(.tbuff);
if (dcnt:=search$first(.cur$fcb)) = 0ffh then
call error(0);
do while dcnt <> 0ffh;
old$fcb$adr = shl(dcnt,5) + .tbuff;
savdcnt = getscbword(dcnt$offset);
savsearcha = getscbword(searcha$offset);
savsearchl = getscbword(searchl$offset);
/* save searched fcb's hash code (5 bytes) */
hash1 = getscbword(hash1$offset);
hash2 = getscbword(hash2$offset);
hash3 = getscbword(hash3$offset); /* saved one extra byte */
call set$new$fcb(old$fcb$adr);
if (code:=rename(old$fcb$adr)) = 8 then do;
call file$err(new$fcb$adr);
call print$buf(.(', delete (Y/N)?$'));
if ucase(read$console) = 'Y' then do;
call delete$file(new$fcb$adr);
code = rename(old$fcb$adr);
end;
else
go to next;
end;
if code = 7 then do;
call file$err(old$fcb$adr);
call getpasswd;
code = rename(old$fcb$adr);
end;
if code <> successful then
call file$err(old$fcb$adr);
else do;
call crlf;
call print$file(new$fcb$adr);
call printchar('=');
call print$file(old$fcb$adr);
end;
next:
call setdma(.tbuff);
call setscbword(dcnt$offset,savdcnt);
call setscbword(searcha$offset,savsearcha);
call setscbword(searchl$offset,savsearchl);
/* restore hash code */
call setscbword(hash1$offset,hash1);
call setscbword(hash2$offset,hash2);
call setscbword(hash3$offset,hash3);
if .cur$fcb <> savsearcha then /*restore orig fcb if destroyed*/
call move(16,.cur$fcb,savsearcha);
dcnt = search$next;
end;
end single$file;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* invalid rename command */
bad$entry: proc;
call print$buf(.failed);
call print$buf(.('ERROR: Invalid File.',cr,lf,'$'));
call mon1(0,0);
end bad$entry;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
finish$parse: procedure;
parse$fn.buff$adr = parse$fn.fcb$adr+1; /* skip delimiter */
parse$fn.fcb$adr = .cur$fcb;
parse$fn.fcb$adr = parse(.parse$fn);
call move(8,.cur$fcb+16,.passwd);
end finish$parse;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
input$found: procedure (buffer$adr) byte;
declare buffer$adr address;
declare char based buffer$adr byte;
do while (char = ' ') or (char = 9); /* tabs & spaces */
buffer$adr = buffer$adr + 1;
end;
if char = 0 then /* eoln */
return false; /* input not found */
else
return true; /* input found */
end input$found;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/**************************************
* *
* M A I N P R O G R A M *
* *
**************************************/
declare ver address;
declare i byte;
declare no$chars byte; /* number characters input */
declare second$string$ptr address; /* points to second filename input */
declare ptr based second$string$ptr byte;
declare last$dseg$byte byte
initial (0);
plm:
ver = version;
if (low(ver) < cpmversion) or (high(ver) = mpmproduct) then do;
call print$buf(.('Requires CP/M 3.0','$'));
call mon1(0,0);
end;
parse$fn.buff$adr = .tbuff(1);
new$fcb$adr, parse$fn.fcb$adr = .fcb;
if input$found(.tbuff(1)) then do;
if (parse$fn.fcb$adr:=parse(.parse$fn)) <> 0FFFFh then
call finish$parse;
end;
else do;
/* prompt for files */
call print$buf(.('Enter New Name: $'));
no$chars = read$console$buf(.tbuff(0),40);
if no$chars <= 0 then do;
call print$buf(.(cr,lf,'ERROR: Incorrect file specification.',cr,lf,'$'));
call mon1(0,0);
end; /* no$char check */
tbuff(1)= ' '; /* blank out nc field for file 1 */
second$string$ptr = .tbuff(no$chars + 2);
call crlf;
call print$buf(.('Enter Old Name: $'));
no$chars = read$console$buf(second$string$ptr,40);
call crlf;
ptr = ' '; /* blank out mx field */
second$string$ptr = second$string$ptr + 1;
ptr = '='; /* insert delimiter for parse */
second$string$ptr = second$string$ptr + no$chars + 1; /* eoln */
ptr = cr; /* put eoln delimeter in string */
parse$fn.buff$adr = .tbuff(1);
new$fcb$adr, parse$fn.fcb$adr = .fcb;
if (parse$fn.fcb$adr := parse(.parse$fn)) <> 0FFFFh then
call finish$parse;
end;
if parse$fn.fcb$adr = 0FFFFh then
call bad$entry;
if fcb(0) <> 0 then
if cur$fcb(0) <> 0 then do;
if fcb(0) <> cur$fcb(0) then
call bad$entry;
end;
else
cur$fcb(0) = new$fcb(0); /* set drive */
if wildcard then
call singlefile;
else if rename(.cur$fcb) <> successful then
call singlefile;
call mon1(0,0);
end ren;


710
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/RESBDOS.ASM Normal file
View File

@@ -0,0 +1,710 @@
title 'CP/M 3 Banked BDOS Resident Module, Dec 1982'
;***************************************************************
;***************************************************************
;** **
;** B a s i c D i s k O p e r a t i n g S y s t e m **
;** **
;** R e s i d e n t M o d u l e - B a n k e d B D O S **
;** **
;***************************************************************
;***************************************************************
;/*
; Copyright (C) 1978,1979,1980,1981,1982
; Digital Research
; P.O. Box 579
; Pacific Grove, CA 93950
;
; December, 1982
;
;*/
;
ssize equ 30
diskfx equ 12
conoutfxx equ 2
printfx equ 9
constatfx equ 11
setdmafx equ 26
chainfx equ 47
ioloc equ 3
org 0000h
base equ $
bnkbdos$pg equ base+0fc00h
resbdos$pg equ base+0fd00h
scb$pg equ base+0fe00h
bios$pg equ base+0ff00h
bnkbdos equ bnkbdos$pg+6
error$jmp equ bnkbdos$pg+7ch
bios equ bios$pg
bootf equ bios$pg ; 00. cold boot function
wbootf equ bios$pg+3 ; 01. warm boot function
constf equ bios$pg+6 ; 02. console status function
coninf equ bios$pg+9 ; 03. console input function
conoutf equ bios$pg+12 ; 04. console output function
listf equ bios$pg+15 ; 05. list output function
punchf equ bios$pg+18 ; 06. punch output function
readerf equ bios$pg+21 ; 07. reader input function
homef equ bios$pg+24 ; 08. disk home function
seldskf equ bios$pg+27 ; 09. select disk function
settrkf equ bios$pg+30 ; 10. set track function
setsecf equ bios$pg+33 ; 11. set sector function
setdmaf equ bios$pg+36 ; 12. set dma function
readf equ bios$pg+39 ; 13. read disk function
writef equ bios$pg+42 ; 14. write disk function
liststf equ bios$pg+45 ; 15. list status function
sectran equ bios$pg+48 ; 16. sector translate
conoutstf equ bios$pg+51 ; 17. console output status function
auxinstf equ bios$pg+54 ; 18. aux input status function
auxoutstf equ bios$pg+57 ; 19. aux output status function
devtblf equ bios$pg+60 ; 20. return device table address fx
devinitf equ bios$pg+63 ; 21. initialize device function
drvtblf equ bios$pg+66 ; 22. return drive table address
multiof equ bios$pg+69 ; 23. multiple i/o function
flushf equ bios$pg+72 ; 24. flush function
movef equ bios$pg+75 ; 25. memory move function
timef equ bios$pg+78 ; 26. get/set system time function
selmemf equ bios$pg+81 ; 27. select memory function
setbnkf equ bios$pg+84 ; 28. set dma bank function
xmovef equ bios$pg+78 ; 29. extended move function
sconoutf equ conoutf ; 31. escape sequence decoded conout
screenf equ 0ffffh ; 32. screen function
serial: db '654321'
jmp bdos
jmp move$out ;A = bank #
;HL = dest, DE = srce
jmp move$tpa ;A = bank #
;HL = dest, DE = srce
jmp search$hash ;A = bank #
;HL = hash table address
; on return, Z flag set for eligible DCNTs
; Z flag reset implies unsuccessful search
; Additional variables referenced directly by bnkbdos
hashmx: dw 0 ;max hash search dcnt
rd$dir: db 0 ;read directory flag
make$xfcb: db 0 ;Make XFCB flag
find$xfcb: db 0 ;Search XFCB flag
xdcnt: dw 0 ;current xdcnt
xdmaadd: dw common$dma
curdma: dw 0
copy$cr$only: db 0
user$info: dw 0
kbchar: db 0
jmp qconinx
bdos: ;arrive here from user programs
mov a,c ; c = BDOS function #
;switch to local stack
lxi h,0! shld aret
dad sp! shld entsp ; save stack pointer
lxi sp,lstack! lxi h,goback! push h
cpi diskfx! jnc disk$func
lxi h,functab! mvi b,0
dad b! dad b! mov a,m
inx h! mov h,m! mov l,a! pchl
db 'COPYRIGHT (C) 1982,'
db ' DIGITAL RESEARCH '
db '151282'
dw 0,0,0,0,0,0,0,0,0,0
functab:
dw wbootf, bank$bdos, bank$bdos, func3
dw func4, func5, func6, func7
dw func8, func9, func10, bank$bdos
func3:
call readerf! jmp sta$ret
func4:
mov c,e! jmp punchf
func5:
mov c,e! jmp listf
func6:
mov a,e! inr a! jz dirinp ;0ffh -> cond. input
inr a! jz dirstat ;0feh -> status
inr a! jz dirinp1 ;0fdh -> input
mov c,e! jmp conoutf ; output
dirstat:
call constx! jmp sta$ret
dirinp:
call constx! ora a! rz
dirinp1:
call conin! jmp sta$ret
constx:
lda kbchar! ora a! mvi a,0ffh! rnz
jmp constf
conin:
lxi h,kbchar! mov a,m! mvi m,0! ora a! rnz
jmp coninf
func7:
call auxinstf! jmp sta$ret
func8:
call auxoutstf! jmp sta$ret
func9:
mov b,d! mov c,e
print:
lxi h,outdelim
ldax b! cmp m! rz
inx b! push b! mov c,a
call blk$out0
pop b! jmp print
func10:
xchg
mov a,l! ora h! jnz func10a
lxi h,buffer+2! shld conbuffadd
lhld dmaad
func10a:
push h! lxi d,buffer! push d
mvi b,0! mov c,m! inx b! inx b! inx b
xchg! call movef! mvi m,0
pop d! push d! mvi c,10
call bank$bdos
lda buffer+1! mov c,a! mvi b,0
inx b! inx b
pop d! pop h! jmp movef
func111:
func112:
sta res$fx
xchg! mov e,m! inx h! mov d,m! inx h
mov c,m! inx h! mov b,m! xchg
; hl = addr of string
; bc = length of string
blk$out:
mov a,b! ora c! rz
push b! push h! mov c,m
lxi d,blk$out2! push d
lda res$fx! cpi 112! jz listf
blk$out0:
lda conmode! mov b,a! ani 2! jz blk$out1
mov a,b! ani 14h! jz blk$out1
ani 10h! jnz sconoutf
jmp conoutf
blk$out1:
mov e,c! mvi c,conoutfxx! jmp bank$bdos
blk$out2:
pop h! inx h! pop b! dcx b
jmp blk$out
qconinx:
; switch to bank 1
mvi a,1! call selmemf
; get character
mov b,m
; return to bank zero
xra a! call selmemf
; return with character in A
mov a,b! ret
switch1:
lxi d,switch0! push d
mvi a,1! call selmemf! pchl
switch0:
mov b,a! xra a! call selmemf
mov a,b! ret
disk$func:
cpi ndf! jc OKdf ;func < ndf
cpi 98! jc badfunc ;ndf < func < 98
cpi nxdf! jnc badfunc ;func >= nxdf
cpi 111! jz func111
cpi 112! jz func112
jmp disk$function
OKdf:
cpi 17! jz search
cpi 18! jz searchn
cpi setdmafx! jnz disk$function
; Set dma addr
xchg! shld dmaad! shld curdma! ret
search:
xchg! shld searcha
searchn:
lhld searcha! xchg
disk$function:
;
; Perform the required buffer tranfers from
; the user bank to common memory
;
lxi h,dfctbl-12
mov a,c! cpi 98! jc normalCPM
lxi h,xdfctbl-98
normalCPM:
mvi b,0! dad b! mov a,m
; **** SAVE DFTBL ITEM, INFO, & FUNCTION *****
mov b,a! push b! push d
rar! jc cpycdmain ;cdmain test
rar! jc cpyfcbin ;fcbin test
jmp nocpyin
cpycdmain:
lhld dmaad! xchg
lxi h,common$dma! lxi b,16
call movef
pop d! push d
cpyfcbin:
xra a! sta copy$cr$only
lxi h,commonfcb! lxi b,36
call movef
lxi d,commonfcb
pop h! pop b! push b! push h
shld user$info
nocpyin:
call bank$bdos
pop d ;restore FCB address
pop b! mov a,b ;restore fcbtbl byte & function #
ani 0f8h! rz
lxi h,commonfcb! xchg! lxi b,33
ral! jc copy$fcb$back ;fcbout test
mvi c,36! ral! jc copy$fcb$back ;pfcbout test
ral! jc cdmacpyout128 ;cdmaout128 test
mvi c,4! ral! jc movef ;timeout test
ral! jc cdmacpyout003 ;cdmaout003 test
mvi c,6! jmp movef ;seriout
copy$fcb$back:
lda copy$cr$only! ora a! jz movef
lxi b,14! dad b! xchg! dad b
mov a,m! stax d
inx h! inx d
mov a,m! stax d
inx b! inx b! inx b! dad b! xchg! dad b
ldax d! mov m,a! ret
cdmacpyout003:
lhld dmaad! lxi b,3! lxi d,common$dma
jmp movef
cdmacpyout128:
lhld dmaad! lxi b,128! lxi d,common$dma
jmp movef
parse:
xchg! mov e,m! inx h! mov d,m
inx h! mov c,m! inx h! mov b,m
lxi h,buffer+133! push h! push b! push d
shld buffer+2! lxi h,buffer+4! shld buffer
lxi b,128! call movef! mvi m,0
mvi c,152! lxi d,buffer! call bank$bdos
pop b! mov a,l! ora h! jz parse1
mov a,l! ana h! inr a! jz parse1
lxi d,buffer+4
mov a,l! sub e! mov l,a
mov a,h! sbb d! mov h,a
dad b! shld aret
parse1:
pop h! pop d! lxi b,36! jmp movef
bad$func:
cpi 152! jz parse
; A = 0 if fx >= 128, 0ffh otherwise
ral! mvi a,0! jc sta$ret
dcr a
sta$ret:
sta aret
goback:
lhld entsp! sphl ;user stack restored
lhld aret! mov a,l! mov b,h ;BA = HL = aret
ret
BANK$BDOS:
xra a! call selmemf
call bnkbdos
shld aret
mvi a,1! jmp selmemf ;ret
move$out:
ora a! jz move$f
call selmemf
move$ret:
call movef
xra a! jmp selmemf
move$tpa:
mvi a,1! call selmemf
jmp move$ret
search$hash: ; A = bank # , HL = hash table addr
; Hash format
; xxsuuuuu xxxxxxxx xxxxxxxx ssssssss
; x = hash code of fcb name field
; u = low 5 bits of fcb user field
; 1st bit is on for XFCB's
; s = shiftr(mod || ext,extshf)
shld hash$tbla! call selmemf
; Push return address
lxi h,search$h7! push h
; Reset read directory record flag
xra a! sta rd$dir
lhld hash$tbla! mov b,h! mov c,l
lhld hashmx! xchg
; Return with Z flag set if dcnt = hash$mx
lhld dcnt! push h! call subdh! pop d! ora l! rz
; Push hash$mx-dcnt (# of hash$tbl entries to search)
; Push dcnt+1
push h! inx d! xchg! push h
; Compute .hash$tbl(dcnt-1)
dcx h! dad h! dad h! dad b
search$h1:
; Advance hl to address of next hash$tbl entry
lxi d,4! dad d! lxi d,hash
; Do hash u fields match?
ldax d! xra m! ani 1fh! jnz search$h3 ; no
; Do hash's match?
call search$h6! jz search$h4 ; yes
search$h2:
xchg! pop h
search$h25:
; de = .hash$tbl(dcnt), hl = dcnt
; dcnt = dcnt + 1
inx h! xthl
; hl = # of hash$tbl entries to search
; decrement & test for zero
; Restore stack & hl to .hash$tbl(dcnt)
dcx h! mov a,l! ora h! xthl! push h
; Are we done?
xchg! jnz search$h1 ; no - keep searching
; Search unsuccessful - return with Z flag reset
inr a! pop h! pop h! ret
search$h3:
; Does xdcnt+1 = 0ffh?
lda xdcnt+1! inr a! jz search$h5 ; yes
; Does xdcnt+1 = 0feh?
inr a! jnz search$h2 ; no - continue searching
; Do hash's match?
push d! call search$h6! pop d! jnz search$h2 ; no
; Does find$xfcb = 0ffh?
lda find$xfcb! inr a! jz search$h45 ; yes
; Does find$xfcb = 0feh?
inr a! jz search$h35 ; yes
; xdcnt+1 = 0feh & find$xfcb < 0feh
; Open user 0 search
; Does hash u field = 0?
mov a,m! ani 1fh! jnz search$h2 ; no
; Search successful
jmp search$h4
search$h35:
; xdcnt+1 = 0feh & find$xfcb = 0feh
; Delete search to return matching fcb's & xfcbs
; Do hash user fields match?
ldax d! xra m! ani 0fh! jnz search$h2 ; no
; Exclude empty fcbs, sfcbs, and dir lbls
mov a,m! ani 30h! cpi 30h! jz search$h2
search$h4:
; successful search
; Set dcnt to search$hash dcnt-1
; dcnt gets incremented by read$dir
; Also discard search$hash loop count
lhld dcnt! xchg
pop h! dcx h! shld dcnt! pop b
; Does dcnt&3 = 3?
mov a,l! ani 03h! cpi 03h! rz ; yes
; Does old dcnt & new dcnt reside in same sector?
mov a,e! ani 0fch! mov e,a
mov a,l! ani 0fch! mov l,a
call subdh! ora l! rz ; yes
; Set directory read flag
mvi a,0ffh! sta rd$dir
xra a! ret
search$h45:
; xdcnt+1 = 0feh, find$xfcb = 0ffh
; Rename search to save dcnt of xfcb in xdcnt
; Is hash entry an xfcb?
mov a,m! ani 10h! jz search$h2 ; no
; Do hash user fields agree?
ldax d! xra m! ani 0fh! jnz search$h2 ; no
; set xdcnt
jmp search$h55
search$h5:
; xdcnt+1 = 0ffh
; Make search to save dcnt of empty fcb
; is hash$tbl entry empty?
mov a,m! cpi 0f5h! jnz search$h2 ; no
search$h55:
; xdcnt = dcnt
xchg! pop h! shld xdcnt! jmp search$h25
search$h6:
; hash compare routine
; Is hashl = 0?
lda hashl! ora a! rz ; yes - hash compare successful
; hash$mask = 0e0h if hashl = 3
; = 0c0h if hashl = 2
mov c,a! rrc! rrc! rar! mov b,a
; hash s field does not pertain if hashl ~= 3
; Does hash(0) fields match?
ldax d! xra m! ana b! rnz ; no
; Compare remainder of hash fields for hashl bytes
push h! inx h! inx d! call compare
pop h! ret
search$h7:
; Return to bnkbdos
push a! xra a! call selmemf! pop a! ret
subdh:
;compute HL = DE - HL
mov a,e! sub l! mov l,a
mov a,d! sbb h! mov h,a
ret
compare:
ldax d! cmp m! rnz
inx h! inx d! dcr c! rz
jmp compare
; Disk Function Copy Table
cdmain equ 00000001B ;copy 1ST 16 bytes of DMA to
;common$dma on entry
fcbin equ 00000010b ;fcb copy on entry
fcbout equ 10000000b ;fcb copy on exit
pfcbout equ 01000000b ;random fcb copy on exit
cdma128 equ 00100000b ;copy 1st 128 bytes of common$dma
;to DMA on exit
timeout equ 00010000b ;copy date & time on exit
cdma003 equ 00001000B ;copy 1ST 3 bytes of common$dma
;to DMA on exit
serout equ 00000100b ;copy serial # on exit
dfctbl:
db 0 ; 12=return version #
db 0 ; 13=reset disk system
db 0 ; 14=select disk
db fcbin+fcbout+cdmain ; 15=open file
db fcbin+fcbout ; 16=close file
db fcbin+cdma128 ; 17=search first
db fcbin+cdma128 ; 18=search next
db fcbin+cdmain ; 19=delete file
db fcbin+fcbout ; 20=read sequential
db fcbin+fcbout ; 21=write sequential
db fcbin+fcbout+cdmain ; 22=make file
db fcbin+cdmain ; 23=rename file
db 0 ; 24=return login vector
db 0 ; 25=return current disk
db 0 ; 26=set DMA address
db 0 ; 27=get alloc address
db 0 ; 28=write protect disk
db 0 ; 29=get R/O vector
db fcbin+fcbout+cdmain ; 30=set file attributes
db 0 ; 31=get disk param addr
db 0 ; 32=get/set user code
db fcbin+fcbout ; 33=read random
db fcbin+fcbout ; 34=write random
db fcbin+pfcbout ; 35=compute file size
db fcbin+pfcbout ; 36=set random record
db 0 ; 37=drive reset
db 0 ; 38=access drive
db 0 ; 39=free drive
db fcbin+fcbout ; 40=write random w/ zero fill
db fcbin+fcbout ; 41=test & write record
db 0 ; 42=record lock
db 0 ; 43=record unlock
db 0 ; 44=set multi-sector count
db 0 ; 45=set BDOS error mode
db cdma003 ; 46=get disk free space
db 0 ; 47=chain to program
db 0 ; 48=flush buffers
db fcbin ; 49=Get/Set system control block
db fcbin ; 50=direct BIOS call (CP/M)
ndf equ ($-dfctbl)+12
xdfctbl:
db 0 ; 98=reset allocation vectors
db fcbin+cdmain ; 99=truncate file
db fcbin+cdmain ; 100=set directory label
db 0 ; 101=return directory label data
db fcbin+fcbout+cdmain ; 102=read file xfcb
db fcbin+cdmain ; 103=write or update file xfcb
db fcbin ; 104=set current date and time
db fcbin+timeout ; 105=get current date and time
db fcbin ; 106=set default password
db fcbin+serout ; 107=return serial number
db 0 ; 108=get/set program return code
db 0 ; 109=get/set console mode
db 0 ; 110=get/set output delimiter
db 0 ; 111=print block
db 0 ; 112=list block
nxdf equ ($-xdfctbl)+98
res$fx: ds 1
hash$tbla:
ds 2
bank: ds 1
aret: ds 2 ;address value to return
buffer: ;function 10 256 byte buffer
commonfcb:
ds 36 ;fcb copy in common memory
common$dma:
ds 220 ;function 10 buffer cont.
ds ssize*2
lstack:
entsp: ds 2
; BIOS intercept vector
wbootfx: jmp wbootf
jmp switch1
constfx: jmp constf
jmp switch1
coninfx: jmp coninf
jmp switch1
conoutfx: jmp conoutf
jmp switch1
listfx: jmp listf
jmp switch1
dw 0,0,0
dw 0,0
olog: dw 0
rlog: dw 0
patch$flgs: dw 0,0
; Base of RESBDOS
dw base+6
; Reserved for use by non-banked BDOS
ds 2
; System Control Block
SCB:
; Expansion Area - 6 bytes
hashl: db 0 ;hash length (0,2,3)
hash: dw 0,0 ;hash entry
version: db 31h ;version 3.1
; Utilities Section - 8 bytes
util$flgs: dw 0,0
dspl$flgs: dw 0
dw 0
; CLP Section - 4 bytes
clp$flgs: dw 0
clp$errcde: dw 0
; CCP Section - 8 bytes
ccp$comlen: db 0
ccp$curdrv: db 0
ccp$curusr: db 0
ccp$conbuff: dw 0
ccp$flgs: dw 0
db 0
; Device I/O Section - 32 bytes
conwidth: db 0
column: db 0
conpage: db 0
conline: db 0
conbuffadd: dw 0
conbufflen: dw 0
conin$rflg: dw 0
conout$rflg: dw 0
auxin$rflg: dw 0
auxout$rflg: dw 0
lstout$rflg: dw 0
page$mode: db 0
pm$default: db 0
ctlh$act: db 0
rubout$act: db 0
type$ahead: db 0
contran: dw 0
conmode: dw 0
dw buffer+64
outdelim: db '$'
listcp: db 0
qflag: db 0
; BDOS Section - 42 bytes
scbadd: dw scb
dmaad: dw 0080h
seldsk: db 0
info: dw 0
resel: db 0
relog: db 0
fx: db 0
usrcode: db 0
dcnt: dw 0
searcha: dw 0
searchl: db 0
multcnt: db 1
errormode: db 0
searchchain: db 0,0ffh,0ffh,0ffh
temp$drive: db 0
errdrv: db 0
dw 0
media$flag: db 0
dw 0
bdos$flags: db 80h
stamp: db 0ffh,0ffh,0ffh,0ffh,0ffh
commonbase: dw 0
error: jmp error$jmp
bdosadd: dw base+6
end


805
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/SAVE.ASM Normal file
View File

@@ -0,0 +1,805 @@
title 'SAVE.RSX - CP/M 3.0 save routine. July 1982'
; *************************************************
; *
; * Title: SAVE.RSX Resident System eXtension
; * Date: 7/28/82
; * Author: Thomas J. Mason
; *
; * Modified:
; * 11/30/82 - Thomas J. Mason
; * Added trap for function 60 to fix PUT and SAVE
; * bios vector mods.
; *
; *********************************************************
;
; Copyright (c) 1982
; Digital Research
; PO Box 579
; Pacific Grove, Ca. 93950
;
TRUE equ 0FFFFh
FALSE equ not TRUE
;
; BIOS and BDOS Jump vectors
;
WBOOT equ 0
WBTADR equ 1 ;address of boot in BIOS
BDOS equ 5 ;BDOS jump vector
BDOSAD equ 6 ;location of instructions
DFCB equ 05Ch ;default FCB
;
; BDOS Function calls
;
BDOSAD equ 6 ;BDOS jump address
PSTRING equ 9 ;print string
BUFIN equ 10 ;console buffer input
CFILE equ 16 ;file close
DFILE equ 19 ;file delete
WFILE equ 21 ;file write
MFILE equ 22 ;make file
SETDMA equ 26 ;set DMA function
BDOSER equ 45 ;Set BDOS error mode
GETSCB equ 49 ;get/set scb func #
LDRSX equ 59 ;function for RSX load
CALRSX equ 60 ;call rsx func #
CONMOD equ 109 ;GET/SET Console Mode
;
; Non Printable ASCII characters
;
CTL$C equ 03 ;CONTROL-C
CR equ 13 ;ASCII Carrige Return
LF equ 10 ;ASCII Line Feed
;
VERSION equ 30
;
; Buffer size
;
CONMAX equ 13 ;console buffer maximum
STKSZE equ 010h ;size fo stack
SCBOST equ 068h ;page boundary + to jmp instr
RETDSP equ 0FEh ;RETurn and DiSPlay mode
JUMP equ 0C3h ;opcode for jump
LXIH equ 21h ;lxi instr to poke
BSNLY equ 07Fh ;restore bios jump table only
CMMON equ 0F9h ;offset of common memory base from pg. bound
;
; *********************************
; * *
; * The Save Program *
; * *
; *********************************
;
db 0,0,0,0,0,0
jmp PREFIX
NEXTJ:
db JUMP ;jump
NEXT:
db 0,0 ;next module in line
PREV:
dw 5 ;previous, initialized to 5
STKYBT: db 00h ;for warm start
db 0
db 'SAVE '
ds 3
;
;
; This is the check performed every time the BDOS is
; called to see if the RSX is to be invoked
;
PREFIX:
mov a,c ;set up for compare
cpi CALRSX
jnz GETGOING
push b
push d
push h
lxi h,0000h ;zero out HL
dad d ; <HL> -> RSXPB
mov a,m ;get the byte
cpi 160 ; sub function defined
pop h
pop d
pop b
jz GOODBYE ;remove this RSX
GETGOING:
;
cpi LDRSX ;do the compare
jz START
lhld NEXT ;get address for continue
pchl ;get going.....
;
;
;
START:
;
; They are equal so get the BIOS address to point here
; in case of a Func 0 call
;
push b ;save state
push d ; of registers
;
; check for jump byte before the SCB
call GETSET$SCB
shld SCBADR ;save address for later
;
mvi l,CMMON+1 ;offset into scb to check BIOS
mov a,m ;get byte
ora a ;check for zero
mvi a,FALSE ;store for insurance
sta CHGJMP ;non-banked = FALSE
jz NBNKED ;high byte zero if non-banked
;
lhld SCBADR ;restor SCB
mvi l,SCBOST ;offset from page for instr
mov a,m ;get byte
cpi JUMP ;is it a jump?
jnz MORRSX ;we are not alone
mvi a,TRUE
sta CHGJMP ;set flag
mvi m,LXIH ;put in lxi h,xxxx mnemonic
;
MORRSX:
; continue with processing
NBNKED:
;
;
lhld WBTADR ;get address at 01h
inx h ;now points to address of jmp xxxx
mov a,m ;get low order byte
sta BIOSAD
inx h ;next byte
mov a,m
sta BIOSAD+1 ;high order byte
;
; Now poke the BIOS address to point to
; the save routine.
;
lxi d,BEGIN ;begining of routine
mov m,d
dcx h ;point back to first byte
mov m,e ;low order
;
mvi c,BDOSER ;now set BDOS errormode
mvi e,RETDSP ;to trap any hard
call BDOS ;errors
;
;
pop d
pop b
lhld NEXT
pchl ;continue on
;
BEGIN:
; Start of the save routine
; Notify the user which program is running
;
lxi sp,STACK ;initialize stack
lxi d,SIGNON ;prompt
call PSTR
;
; Get the file from the user
;
FLEGET:
lxi d,FLEPRMPT ;ask for file name
call PSTR
call GETBUF
; zero at end of string for parser
lxi h,CONBUF-1 ;address of #
mov a,m ;get it
cpi 0
jz REPLCE
inx h ;HL->CONBUF
mvi d,0 ;zero out high order
mov e,a ;fill low
dad d ;add to h
mvi m,00 ;zero out byte for parse
push h
;
;
call PARSE
mov a,h
cpi 0FFh
jz FLEGET
;
pop h ;get end of string address back
inx h
mvi m,'?' ;put in question mark
inx h ;bump
mvi m,' ' ;blank in string
inx h ;bump
mvi m,'$' ;end of string
;
mvi c,17 ;Search for first
lxi d,DFCB
call BDOS ;find it
inr a ;bump Acc
jz FLECLR ;file no present skip prompt
;
lxi d,DELFLE
call PSTR ;print out delete prompt
lxi d,CONBUF ;buffer address
call PSTR ;print out filename
call GETBUF ;get answer
call GNC ;get the next char
cpi 'Y' ;is it yes
jnz FLEGET ;another name if not
;
; Delete any existing file, then make a new one
FLECLR:
mvi c,DFILE ;file delete func
lxi d,DFCB ;default FCB
call BDOS ;real BDOS call
;
mvi a,0
lxi h,07ch ;M -> record count in FCB
mov m,a ;zero out record count
;
mvi c,MFILE ;make file function
lxi d,DFCB ;default FCB
call BDOS
; Get the address of start of write
;
STRADD:
lxi d,SPRMPT ;first address
call PSTR
call GETBUF
;
lda BUFFER+1 ;get # of chars read
cpi 0
jz STRADD
;
call SCANAD ;get address
jc STRADD
;
shld SADDR ;store in SADDR
;
; Get the finish address
ENDADD:
lxi d,FPRMPT ;load prompt
call PSTR ;print
call GETBUF ;read in
;
lda BUFFER+1
cpi 0
jz ENDADD
;
call SCANAD ;get finish address
jc ENDADD
;
shld FADDR ;store it
xchg
lhld SADDR
xchg
;
call CHECK
jc STRADD
;
;
lhld SADDR ;beginning DMA address
xchg ;DE=DMA address
;
; Write the first record then check the beginning address
; if DMA address ends up larger exit
;
WLOOP:
call WFLAG
push d ;save DMA address
mvi c,SETDMA
call BDOS ;set DMA address
;
mvi c,WFILE
lxi d,DFCB
call BDOS ;write
;
; Check for directory space on disk for extents
lxi d,NODIR
cpi 01h ;no more directory
jz FINIS
;
; CHECK data block error
lxi d,NOBLK
cpi 02h
jz FINIS ;out of disk space!
; final check
ora a ;if bad write occured...
jnz REPLCE ;restore BIOS address
;
; Write OK now check write address
pop d ;get DMA address
lxi h,080h
dad d
xchg
lhld FADDR ;HL=end of write
;
call CHECK
;
lda ONEFLG
cpi TRUE
jnz WLOOP ;WLOOP if not done
;
; Else, Close file and print out ending prompt
CLOSE:
mvi c,CFILE ;close function
lxi d,DFCB ;get filename
call BDOS
;
inr a ;check for close error
lxi d,CERROR
jz FINIS ;maybe write protected
;
;good copy
lxi d,ENDMSG
FINIS:
call PSTR
;
; Replace the BIOS Address to correct one
REPLCE:
lhld BIOSAD ;HL=BIOS warm jump
xchg ;DE=" " "
lhld WBTADR
inx h
mov m,e
inx h
mov m,d
;
GOODBYE:
mvi a,0FFh
sta STKYBT ;change sticky byte for
; ; removal of RSX
;
; check to see if JMP changed for BANKED system
lda CHGJMP
cpi TRUE ;has it been done?
jnz CHGBIOS
lhld SCBADR ;retreive SCB address
mvi l,SCBOST ;points to page + offset
mvi m,JUMP ;restore original code
;
CHGBIOS:
mvi c,13 ;reset the disk system
call BDOS
;
mvi c,0 ;set up for wboot
call BDOS
;****************************************
;* *
;* Logical end of the program *
;* *
;****************************************
;
GETSET$SCB:
mvi c,GETSCB
lxi d,SCBPB
call BDOS
ret
;
WFLAG:
mvi a,FALSE
sta ONEFLG
lda RSLT+1
cpi 00h
rnz
lda RSLT
cpi 080h
jc WFLAG1
jz WFLAG1
ret
;
WFLAG1:
mvi a,TRUE
sta ONEFLG
ret
;
;
;
CHECK:
; Subtract the two to find out if finished
mov a,l ;low order
sub e ;subtraction
sta RSLT
mov a,h ;now ...
sbb d ;high order subtraction
sta RSLT+1 ;saved
ret
;
GETBUF:
;buffer input routine
;
lxi h,CONBUF ;address of buffer
shld NEXTCOM ;store it
mvi c,BUFIN
lxi d,BUFFER
call BDOS
ret
;
PSTR:
; String output routine for messages
;
mvi c,PSTRING
call BDOS
ret
;
PARSE:
; General purpose parser
;
; Filename = [d:]file[.type][;password]
;
; FCB assignments
;
; 0 => drive, 0=default, 1=A, 2=B
; 1-8 => file, converted to upper case,
; padded with blanks
; 9-11 => type, converted to upper case,
; padded with blanks
; 12-15 => set to zero
; 16-23 => passwords, converted to upper case,
; padded with blanks
; 24-25 => address of password field in "filename",
; set to zero if password length=0.
; 26 => length of password (0-8)
;
; Upon return, HL is set to FFFFh if BC locates
; an invalid file name;
; otherwise, HL is set to 0000h if the delimiter
; following the file name is a 00h (null)
; or a 0Dh (CR);
; otherwise, HL is set to the address of the delimiter
; following the file name.
;
;
lxi h,0
push h
push h
lxi d,CONBUF ;set up source address
lxi h,DFCB ;set up dest address
call DEBLNK ;scan the blanks
call DELIM ;check for delimeter
jnz PARSE1
mov a,c
ora a
jnz PARSE9
mov m,a
jmp PARSE3
;
PARSE1:
mov b,a
inx d
ldax d
cpi ':'
jnz PARSE2
;
mov a,b
sui 'A'
jc PARSE9
cpi 16
jnc PARSE9
inr a
mov m,a
inx d
call DELIM
jnz PARSE3
cpi '.'
jz PARSE9
cpi ':'
jz PARSE9
cpi ';'
jz PARSE9
jmp PARSE3
;
PARSE2:
dcx d
mvi m,0
PARSE3:
mvi b,8
call SETFLD
mvi b,3
cpi '.'
jz PARSE4
call PADFLD
jmp PARSE5
;
PARSE4:
inx d
call SETFLD
PARSE5:
mvi b,4
PARSE6:
inx h
mvi m,0
dcr b
jnz PARSE6
mvi b,8
cpi ';'
jz PARSE7
call PADFLD
jmp PARSE8
PARSE7:
inx d
call PWFLD
PARSE8:
push d
call DEBLNK
call DELIM
jnz PARSE81
inx sp
inx sp
jmp PARSE82
PARSE81:
pop d
PARSE82:
mov a,c
ora a
pop b
mov a,c
pop b
inx h
mov m,c
inx h
mov m,b
inx h
mov m,a
xchg
rnz
lxi h,0
ret
PARSE9:
pop h
pop h
lxi h,0FFFFh
ret
;
SETFLD:
call DELIM
jz PADFLD
inx h
cpi '*'
jnz SETFD1
mvi m,'?'
dcr b
jnz SETFLD
jmp SETFD2
SETFD1:
mov m,a
dcr b
SETFD2:
inx d
jnz SETFLD
SETFD3:
call DELIM
rz
pop h
jmp PARSE9
;
PWFLD:
call DELIM
jz PADFLD
inx sp
inx sp
inx sp
inx sp
inx sp
inx sp
push d
push h
mvi l,0
xthl
dcx sp
dcx sp
PWFLD1:
inx sp
inx sp
xthl
inr l
xthl
dcx sp
dcx sp
inx h
mov m,a
inx d
dcr b
jz SETFD3
call DELIM
jnz PWFLD1
;
PADFLD:
inx h
mvi m,' '
dcr b
jnz PADFLD
ret
;
DELIM:
ldax d
mov c,a
ora a
rz
mvi c,0
cpi 0Dh
rz
mov c,a
cpi 09h
rz
cpi ' '
jc DELIM2
rz
cpi '.'
rz
cpi ':'
rz
cpi ';'
rz
cpi '='
rz
cpi ','
rz
cpi '/'
rz
cpi '['
rz
cpi ']'
rz
cpi '<'
rz
cpi '>'
rz
cpi 'a'
rc
cpi 'z'+1
jnc DELIM1
ani 05Fh
DELIM1:
ani 07Fh
ret
DELIM2:
pop h
jmp PARSE9
;
DEBLNK:
ldax d
cpi ' '
jz DBLNK1
cpi 09h
jz DBLNK1
ret
DBLNK1:
inx d
jmp DEBLNK
; End of the Parser
;
; GET a character from the console buffer
GNC:
push h
lxi h,CONBUF-1 ;get length
mov a,m
ora a ;zero?
mvi a,CR ;return with CR if so
jz GNCRET
dcr m ;lenght = length-1
lhld NEXTCOM ;next char address
mov a,m
inx h ;bump to next
shld NEXTCOM ;update
GNCRET:
pop h
TRANS:
cpi 7Fh ;Rubout?
rz
cpi ('A' or 0100000b)
rc
ani 1011111b ; clear upper case bit
ret
;
;
; Scan the buffer for the address read in ASCII from the terminal
;
SCANAD:
lxi d,00h ;zero out address
push d ;and save
;
lda CONBUF-1 ;get character count
cpi 05 ;5 is too many
jc SCAN0
stc ;set carry for routine
jmp SCNRET
SCAN0:
call GNC ;get a char
cpi CR ;end?
jz SCNRET ;to scnret if so
cpi '0' ;is it >0?
jnc SCAN01 ;bad character
jmp SCNRET
SCAN01:
cpi '@'
jnz SCAN02 ;bad character
stc
jmp SCNRET ;return on bad file
SCAN02:
jnc SCAN1 ;must be A-F
sui 030h ;normalize 0-9
jmp SCAN2
SCAN1:
cpi 'G' ;is it out of range?
jc SCAN11
stc
jmp SCNRET
SCAN11:
sui 037h ;normalize
SCAN2:
mov l,a ;character in low of DE
lda CONBUF-1 ;get # left
adi 1 ;readjust
mov c,a
mvi h,00 ;zero out high order
SCAN3:
dcr c ;dec to set flag
jz SCAN4 ;were done
dad h ;shift 1bit left
dad h ;same
dad h ;same
dad h ;finally
jmp SCAN3 ;back for more
;
SCAN4:
pop d ;ready for or
mov a,d ;high order
ora h ;
mov d,a
mov a,e ;low order
ora l ;ORed
mov e,a ;back
push d ;save
jmp SCAN0 ;get more characters
SCNRET:
pop d ;hl = address
xchg ;DE->HL
ret
;
;
; *********************************
; * *
; * Data Structures *
; * *
; *********************************
;
SCBPB:
db 03Ah ;SCB address
db 0
;
SADDR: dw 0 ;write start address
FADDR: dw 0 ;write finish address
BIOSAD: dw 0 ;WarmBOOT bios address
NEXTCOM: dw 0 ;address of next character to read
ONEFLG: db 0
RSLT: dw 0
CHGJMP db FALSE
;
SCBADR: dw 0 ;Scb address
;
BIOSMD: db 0 ;if non-zero change LXI @jmpadr to
;JUMP when removed.
;
BUFFER: db CONMAX
db 0 ;# of console characters read
CONBUF: ds CONMAX
;
SIGNON: db CR,LF,'CP/M 3 SAVE - Version ',VERSION/10+'0','.',VERSION mod 10+'0','$'
FLEPRMPT: db CR,LF,'Enter file '
db '(type RETURN to exit): $'
DELFLE: db CR,LF,'Delete $'
SPRMPT: db CR,LF,'Beginning hex address $'
FPRMPT: db CR,LF,'Ending hex address $'
ENDMSG: db CR,LF,'$'
;
; Error messages......
CERROR: db CR,LF,'ERROR: Bad close.$'
NODIR: db CR,LF,'ERROR: No directory space.$'
NOBLK: db CR,LF,'ERROR: No disk space.$'
;
; Stack for program
ds STKSZE
STACK:
end ;Physical end of program


23
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/SCAN.LIT Normal file
View File

@@ -0,0 +1,23 @@
declare
pcb$structure literally 'structure (
state address,
scan$adr address,
token$adr address,
tok$typ byte,
token$len byte,
p$level byte,
nxt$token byte)';
declare
t$null lit '0',
t$param lit '1',
t$op lit '2',
t$mod lit '4',
t$identifier lit '8',
t$string lit '16',
t$numeric lit '32',
t$filespec lit '64',
t$error lit '128';


732
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/SCAN.PLM Normal file
View File

@@ -0,0 +1,732 @@
$title ('Utility Command Line Scanner')
scanner:
do;
$include(comlit.lit)
$include(mon.plm)
dcl debug boolean initial (false);
dcl eob lit '0'; /* end of buffer */
$include(fcb.lit)
/* -------- Some routines used for diagnostics if debug mode is on -------- */
printchar: procedure(char) external;
declare char byte;
end printchar;
printb: procedure external;
end printb;
crlf: procedure external;
end crlf;
pdecimal: procedure(v,prec,zerosup) external;
/* print value v, field size = (log10 prec) + 1 */
/* with leading zero suppression if zerosup = true */
declare v address, /* value to print */
prec address, /* precision */
zerosup boolean, /* zero suppression flag */
d byte; /* current decimal digit */
end pdecimal;
/*
show$buf: procedure;
dcl i byte;
i = 1;
call crlf;
call mon1(9,.('buff = $'));
do while buff(i) <> 0;
i = i + 1;
end;
buff(i) = '$';
call mon1(9,.buff(1));
buff(i) = 0;
end show$buf; */
/* -------- -------- */
white$space: procedure (str$adr) byte;
dcl str$adr address,
str based str$adr (1) byte,
i byte;
i = 0;
do while (str(i) = ' ') or (str(i) = tab);
i = i + 1;
end;
return(i);
end white$space;
delimiter: procedure(char) boolean;
dcl char byte;
if char = '[' or char = ']' or char = '(' or char = ')' or
char = '=' or char = ',' or char = 0 then
return (true);
return(false);
end delimiter;
dcl string$marker lit '05ch';
deblank: procedure(buf$adr);
dcl (buf$adr,dest) address,
buf based buf$adr (128) byte,
(i,numspaces) byte,
string boolean;
string = false;
if (numspaces := white$space(.buf(1))) > 0 then
call move(buf(0) - numspaces + 1,.buf(numspaces+1),.buf(1));
i = 1;
do while buf(i) <> 0;
/* call show$buf;*/
do while ((numspaces := white$space(.buf(i))) = 0 and (buf(i) <> 0))
and not string;
/* call mon1(9,.(cr,lf,'2numspaces = $'));
call pdecimal(numspaces,100,false);*/
/* call show$buf;*/
if buf(i) = '"' then
do;
string = true;
buf(i) = string$marker;
end;
i = i + 1;
end;
do while string and buf(i) <> 0;
if buf(i) = '"' then
if buf(i+1) = '"' then
call move(buf(0) - i + 1,.buf(i+1), .buf(i));
else
do;
buf(i) = string$marker;
string = false;
end;
i = i + 1;
end;
if (numspaces := white$space(.buf(i))) > 0 then
do;
/* call mon1(9,.(cr,lf,'1numspaces = $'));
call pdecimal(numspaces,100,false);*/
buf(i) = ' ';
dest = .buf(i+1); /* save space for ',' */
if i > 1 then
if delimiter(buf(i-1)) or delimiter(buf(i+numspaces)) then
/* write over ' ' with */
dest = dest - 1; /* a = [ ] ( ) */
call move(((buf(0)+1)-(i+numspaces-1)),
.buf(i+numspaces),dest);
if buf(i) = '"' then
string = true;
i = i + 1;
end;
end;
if buf(i - 1) = ' ' then /* no trailing blanks */
buf(i - 1) = 0;
/* if debug then
call show$buf; */
end deblank;
upper$case: procedure (buf$adr);
dcl buf$adr address,
buf based buf$adr (1) byte,
i byte;
i = 0;
do while buf(i) <> eob;
if buf(i) >= 'a' and buf(i) <= 'z' then
buf(i) = buf(i) - ('a' - 'A');
i = i + 1;
end;
end upper$case;
dcl option$max lit '11';
dcl done$scan lit '0ffffh';
dcl ident$max lit '11';
dcl token$max lit '11';
dcl t$null lit '0',
t$param lit '1',
t$option lit '2',
t$modifier lit '4',
t$identifier lit '8',
t$string lit '16',
t$numeric lit '32',
t$filespec lit '64',
t$error lit '128';
dcl pcb$base address;
dcl pcb based pcb$base structure (
state address,
scan$adr address,
token$adr address,
token$type byte,
token$len byte,
p$level byte,
nxt$token byte);
dcl scan$adr address,
inbuf based scan$adr (1) byte,
in$ptr byte,
token$adr address,
token based token$adr (1) byte,
t$ptr byte,
(char, nxtchar, tcount) byte;
digit: procedure (char) boolean;
dcl char byte;
return (char >= '0' and char <= '9');
end digit;
letter: procedure (char) boolean;
dcl char byte;
return (char >= 'A' and char <= 'Z');
end letter;
eat$char: procedure;
char = inbuf(in$ptr := inptr + 1);
nxtchar = inbuf(in$ptr + 1);
end eat$char;
put$char: procedure(charx);
dcl charx byte;
if pcb.token$adr <> 0ffffh then
token(t$ptr := t$ptr + 1) = charx;
end put$char;
get$identifier: procedure (max) byte;
dcl max byte;
tcount = 0;
/* call mon1(9,.(cr,lf,'getindentifier$'));*/
if not letter(char) and char <> '$' then
return(tcount);
do while (letter(char) or digit(char) or char = '_' or
char = '$' ) and tcount <= max;
call put$char(char);
call eat$char;
tcount = tcount + 1;
end;
do while letter(char) or digit(char) or char = '_'
or char = '$' ;
call eat$char;
tcount = tcount + 1;
end;
pcb.token$type = t$identifier;
/* call mon1(9,.(cr,lf,'end of getident$')); */
pcb.token$len = tcount;
return(tcount);
end get$identifier;
file$char: procedure (x) boolean;
dcl x byte;
return(letter(x) or digit(x) or x = '*' or x = '?'
or x = '_' or x = '$');
end file$char;
expand$wild$cards: procedure(field$size) boolean;
dcl (i,leftover,field$size) byte,
save$inptr address;
field$size = field$size + t$ptr;
do while filechar(char) and t$ptr < field$size;
if char = '*' then
do; leftover = t$ptr;
save$inptr = inptr;
call eatchar;
do while filechar(char);
leftover = leftover + 1;
call eatchar;
end;
if leftover >= field$size then /* too many chars */
do; inptr = save$inptr;
return(false);
end;
do i = 1 to field$size - leftover;
call putchar('?');
end;
inptr = save$inptr;
end;
else
call putchar(char);
call eatchar;
end;
return(true);
end expand$wild$cards;
get$file$spec: procedure boolean;
dcl i byte;
do i = 1 to f$name$len + f$type$len;
token(i) = ' ';
end;
if nxtchar = ':' then
if char >= 'A' and char <= 'P' then
do;
call putchar(char - 'A' + 1);
call eat$char; /* skip ':' */
call eat$char; /* 1st char of file name */
end;
else
return(false);
else
call putchar(0); /* use default drive */
if not (letter(char) or char = '$' or char = '_'
or char = '*' or char = '?' ) then /* no leading numerics */
if token(0) = 0 then /* ambiguous with numeric token */
return(false);
if not expand$wild$cards(f$namelen) then
return(false); /* blank name is illegal */
if char = '.' then
do; call eat$char;
if filechar(char) then
do; t$ptr = f$namelen;
if not expand$wild$cards(f$typelen) then
return(false);
end;
end;
pcb.token$len = f$name$len + f$type$len + 1;
pcb.token$type = t$file$spec;
return(true);
end get$file$spec;
get$numeric: procedure(max) boolean;
dcl max byte;
if not digit(char) then
return(false);
do while digit(char) and pcb.token$len <= max and
char <> eob;
call putchar(char);
call eat$char;
pcb.token$len = pcb.token$len + 1;
end;
if char = 'H' or char = 'D' or char = 'B' then
if pcb.token$len < max then
do;
call putchar(char);
call eat$char;
pcb.token$len = pcb.token$len + 1;
end;
else
return(false);
pcb.token$type = t$numeric;
return(true);
end get$numeric;
get$string: procedure(max) boolean;
dcl max byte;
if char <> string$marker then
return(false);
call eatchar;
do while char <> string$marker and char <> eob
and pcb.token$len < token$max;
call putchar(char);
call eatchar;
pcb.token$len = pcb.token$len + 1;
end;
do while char <> string$marker and char <> eob;
call eat$char;
end;
if char <> string$marker then
return(false);
pcb.token$type = t$string;
call eat$char;
return(true);
end get$string;
get$token$all: procedure boolean;
dcl save$inptr byte;
/* call mon1(9,.(cr,lf,'gettokenall$'));*/
save$inptr = in$ptr;
if get$file$spec then
return(true);
/* call mon1(9,.(cr,lf,'gettokenall - no file$')); */
in$ptr = save$inptr - 1; /* need to re-scan, reset buffer pointers */
call eat$char;
t$ptr = 255;
call putchar(0); /* zero drive byte */
if get$identifier(token$max) = 0 then
if not get$string(token$max) then
if not get$numeric(token$max) then
return(false);
/* call mon1(9,.(cr,lf,'end gettokenall$'));*/
return(true);
end get$token$all;
get$modifier: procedure boolean;
if char = ',' or char = ')' or char = 0 then
do;
pcb.token$type = t$modifier or t$null;
return(true);
end;
if get$token$all then
do;
pcb.token$type = pcb.token$type or t$modifier;
return(true);
end;
return(false);
end get$modifier;
get$option: procedure boolean;
call putchar(0);
if get$identifier(token$max) > 0 then
do;
pcb.token$type = pcb.token$type or t$option;
if pcb.token$len > token$max then
pcb.token$len = token$max;
return(true);
end;
return(false);
end get$option;
get$param: procedure boolean;
if char = ',' or char = ')' or char = 0 then
do;
pcb.token$type = t$param or t$null;
return(true);
end;
if get$token$all then
do;
pcb.token$type = pcb.token$type or t$param;
return(true);
end;
return(false);
end get$param;
dcl gotatoken boolean;
dcl parens byte initial (0);
end$state: procedure boolean;
if gotatoken then
do;
pcb.state = .end$state;
return(true);
end;
pcb.token$type = t$null;
pcb.scan$adr = 0ffffh;
return(true);
end end$state;
state8: procedure boolean reentrant;
if debug then do;
call mon1(9,.(cr,lf,'state8, char = $'));
call printchar(char); end;
if char = 0 then
return(end$state);
if char = ']' then
do;
call eatchar;
if char = ',' or nxtchar = '(' or nxtchar = ')' then
return(state2);
else if char = 0 then
return(end$state);
else
return(state1);
end;
else if char = ' ' or char = ',' then
do;
call eatchar;
return(state3);
end;
return(state3);
end state8;
state7:procedure boolean reentrant;
if debug then do;
call mon1(9,.(cr,lf,'state7, char = $'));
call printchar(char); end;
if char = 0 then
return(end$state);
if char = ' ' or char = ',' then
do;
call eat$char;
return(state6);
end;
else
if char = ')' then
do;
call eat$char;
return(state8);
end;
return(false);
end state7;
state6: procedure boolean reentrant;
if debug then do;
call mon1(9,.(cr,lf,'state6, char = $'));
call printchar(char); end;
if gotatoken then
do;
pcb.state = .state6;
pcb.nxt$token = t$modifier;
return(true);
end;
if (gotatoken := get$modifier) then
return(state7);
return(false);
end state6;
state5:procedure boolean reentrant;
if debug then do;
call mon1(9,.(cr,lf,'state5, nxtchar = $'));
call printchar(nxtchar); end;
if char = '(' then
do;
call eat$char;
return(state6);
end;
if gotatoken then
do;
pcb.state = .state5;
pcb.nxt$token = t$modifier;
return(true);
end;
if (gotatoken := get$modifier) then
return(state8);
return(false);
end state5;
state4: procedure boolean reentrant;
dcl temp byte;
if debug then do;
call mon1(9,.(cr,lf,'state4, char = $'));
call printchar(char); end;
if char = 0 then
return(end$state);
temp = char;
call eatchar;
if temp = ',' or temp = ' ' then
return(state3);
if temp = ']' then
if char = '(' or char = ',' or char = ')' then
return(state2);
else if char = 0 then
return(end$state);
else
return(state1);
if temp = '=' then
return(state5);
return(false);
end state4;
state3: procedure boolean reentrant;
if debug then do;
call mon1(9,.(cr,lf,'state3, char = $'));
call printchar(char); end;
if gotatoken then
do;
pcb.state = .state3;
pcb.nxt$token = t$option;
return(true);
end;
if (pcb.plevel := parens ) > 128 then
return(false);
if (gotatoken := get$option) then
return(state4);
return(false);
end state3;
state2: procedure boolean reentrant;
if debug then do;
call mon1(9,.(cr,lf,'state2, char = $'));
call printchar(char); end;
do while char = ')' or char = 0;
if char = 0 then
return(end$state);
call eat$char;
parens = parens - 1;
end;
if char = '[' then
do;
call eat$char;
return(state3);
end;
if char = ' ' or char = ',' or char = '(' then
do;
if char = '(' then
parens = parens + 1;
call eat$char;
return(state1);
end;
return(state1);
end state$2;
state1: procedure boolean reentrant;
if debug then do;
call mon1(9,.(cr,lf,'state1, char = $'));
call printchar(char); end;
if gotatoken then
do;
pcb.nxt$token = t$param;
pcb.state = .state1;
return(true);
end;
do while char = '(' ;
parens = parens + 1;
call eat$char;
end;
if (pcb.plevel := parens) > 128 then
return(false);
if (gotatoken := get$param) then
return(state2);
return(false);
end state1;
start$state: procedure boolean;
if char = '@' then do;
debug = true;
call eat$char;
call mon1(9,.(cr,lf,'startstate, char = $'));
call printchar(char); end;
if char = 0 then
return(end$state);
if char = ')' then
return(false);
if char = '(' then
do;
parens = parens + 1;
call eat$char;
return(state1);
end;
if char = '[' then
do;
call eat$char;
return(state3);
end;
if (gotatoken := get$param) then
return(state2);
return(false);
end start$state;
/* display$all: procedure; /* called if debug set */
/* call mon1(9,.(cr,lf,'scanadr=$'));
call pdecimal(pcb.scanadr,10000,false);
call mon1(9,.(', tadr=$'));
call pdecimal(pcb.token$adr,10000, false);
call mon1(9,.(', tlen=$'));
call pdecimal(double(pcb.token$len),100, false);
call mon1(9,.(', ttype=$'));
call pdecimal(double(pcb.token$type),100,false);
call mon1(9,.(', plevel=$'));
call pdecimal(double(pcb.plevel),100,false);
call mon1(9,.(', ntok=$'));
call pdecimal(double(pcb.nxt$token),100,false);
if (pcb.token$type and t$option) <> 0 then
call mon1(9,.(cr,lf,'option =$'));
if (pcb.token$type and t$param) <> 0 then
call mon1(9,.(cr,lf,'parm =$'));
if (pcb.token$type and t$modifier) <> 0 then
call mon1(9,.(cr,lf,'modifier=$'));
if (pcb.token$type and t$filespec) <> 0 then
do;
if fcb(0) = 0 then
call print$char('0');
else call print$char(fcb(0) + 'A' - 1);
call print$char(':');
fcb(12) = '$';
call mon1(9,.fcb(1));
call mon1(9,.(' (filespec)$'));
end;
if ((pcb.token$type and t$string) or (pcb.token$type and
t$identifier) or (pcb.token$type and t$numeric)) <> 0 then
do;
fcb(pcb.token$len + 1) = '$';
call mon1(9,.fcb(1));
end;
if pcb.token$type = t$error then
do;
call mon1(9,.(cr,lf,'scanner error$'));
return;
end;
if (pcb.token$type and t$identifier) <> 0 then
call mon1(9,.(' (identifier)$'));
if (pcb.token$type and t$string) <> 0 then
call mon1(9,.(' (string)$'));
if (pcb.token$type and t$numeric) <> 0 then
call mon1(9,.(' (numeric)$'));
if (pcb.nxt$token and t$option) <> 0 then
call mon1(9,.(cr,lf,'nxt tok = option $'));
if (pcb.nxt$token and t$param) <> 0 then
call mon1(9,.(cr,lf,'nxt tok = parm $'));
if (pcb.nxt$token and t$modifier) <> 0 then
call mon1(9,.(cr,lf,'nxt tok = modifier$'));
call crlf;
end display$all; */
scan: procedure (pcb$adr) public;
dcl status boolean,
pcb$adr address;
pcb$base = pcb$adr;
scan$adr = pcb.scan$adr;
token$adr = pcb.token$adr;
in$ptr, t$ptr = 255;
call eatchar;
gotatoken = false;
pcb.nxt$token = t$null;
pcb.token$len = 0;
if pcb.token$type = t$error then /* after one error, return */
return; /* on any following calls */
else if pcb.state = .start$state then
status = start$state;
else if pcb.state = .state$1 then
status = state$1;
else if pcb.state = .state$3 then
status = state$3;
else if pcb.state = .state$5 then
status = state$5;
else if pcb.state = .state$6 then
status = state$6;
else if pcb.state = .end$state then /* repeated calls go here */
status = end$state; /* after first end$state */
else
status = false;
if not status then
pcb.token$type = t$error;
if pcb.scan$adr <> 0ffffh then
pcb.scan$adr = pcb.scan$adr + inptr;
/* if debug then
call display$all; */
end scan;
scan$init: procedure(pcb$adr) public;
dcl pcb$adr address;
pcb$base = pcb$adr;
call deblank(pcb.scan$adr);
call upper$case(pcb.scan$adr := pcb.scan$adr + 1);
pcb.state = .start$state;
end scan$init;
end scanner;


23
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/SEARCH.LIT Normal file
View File

@@ -0,0 +1,23 @@
declare /* what kind of file user wants to find */
find$structure lit 'structure (
dir byte,
sys byte,
ro byte,
rw byte,
pass byte,
xfcb byte,
nonxfcb byte,
exclude byte)';
declare
max$search$files literally '10';
declare
search$structure lit 'structure(
drv byte,
name(8) byte,
type(3) byte,
anyfile boolean)'; /* match on any drive if true */


437
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/SEARCH.PLM Normal file
View File

@@ -0,0 +1,437 @@
$title ('SDIR - Search For Files')
search:
do;
/* search module for extended dir */
$include (comlit.lit)
$include (mon.plm)
dcl debug boolean external;
dcl first$pass boolean external;
dcl get$all$dir$entries boolean external;
dcl usr$vector address external;
dcl active$usr$vector address external;
dcl used$de address public; /* used directory entries */
dcl filesfound address public; /* num files collected in memory */
$include(fcb.lit)
$include(xfcb.lit)
declare
sfcb$type lit '21H',
deleted$type lit '0E5H';
$include (search.lit)
dcl find find$structure external; /* what kind of files to look for */
dcl num$search$files byte external;
dcl search (max$search$files) search$structure external;
/* file specs to match on */
/* other globals */
dcl cur$usr byte external,
cur$drv byte external, /* current drive " " */
dir$label byte public; /* directory label for BDOS 3.0 */
/* -------- BDOS calls -------- */
read$char: procedure byte;
return mon2 (1,0);
end read$char;
/* -------- in sort.plm -------- */
mult23: procedure(f$info$index) address external;
dcl f$info$index address;
end mult23;
/* -------- in util.plm -------- */
print: procedure(string$adr) external;
dcl string$adr address;
end print;
print$char: procedure(char) external;
dcl char byte;
end print$char;
pdecimal:procedure(val,prec,zsup) external;
dcl (val, prec) address;
dcl zsup boolean;
end pdecimal;
printfn: procedure(fnameadr) external;
dcl fnameadr address;
end printfn;
crlf: procedure external; /* print carriage return, linefeed */
end crlf;
add3byte: procedure(byte3adr,num) external;
dcl (byte3adr,num) address;
end add3byte;
/* add three byte number to 3 byte accumulater */
add3byte3: procedure(totalb,numb) external;
dcl (totalb,numb) address;
end add3byte3;
/* divide 3 byte value by 8 */
shr3byte: procedure(byte3adr) external;
dcl byte3adr address;
end shr3byte;
/* -------- In dpb86.plm -------- */
$include(dpb.lit)
dcl k$per$block byte external; /* set in dpb module */
base$dpb: procedure external;
end base$dpb;
dpb$byte: procedure(param) byte external;
dcl param byte;
end dpb$byte;
dpb$word: procedure(param) address external;
dcl param byte;
end dpb$word;
/* -------- Some Utility Routines -------- */
check$console$status: procedure byte;
return mon2 (11,0);
end check$console$status;
search$first: procedure (fcb$address) byte public;
declare fcb$address address; /* shared with disp.plm */
return mon2 (17,fcb$address); /* for short display */
end search$first;
search$next: procedure byte public; /* shared with disp.plm */
return mon2 (18,0);
end search$next;
terminate: procedure external; /* in main.plm */
end terminate;
set$vec: procedure(vector,value) external; /* in main.plm */
dcl vector address,
value byte;
end set$vec;
break: procedure public; /* shared with disp.plm */
dcl x byte;
if check$console$status then
do;
x = read$char;
call terminate;
end;
end break;
/* -------- file information record declaration -------- */
$include(finfo.lit)
declare
buf$fcb$adr address public, /* index into directory buffer */
buf$fcb based buf$fcb$adr (32) byte,
/* fcb template for dir */
(first$f$i$adr, f$i$adr, last$f$i$adr) address public,
/* indices into file$info array */
file$info based f$i$adr f$info$structure,
sfcb$adr address,
dir$type based sfcb$adr byte,
sfcbs$present byte public,
x$i$adr address public,
xfcb$info based x$i$adr x$info$structure;
compare: procedure(length, str1$adr, str2$adr) boolean;
dcl (length,i) byte,
(str1$adr, str2$adr) address,
str1 based str1$adr (1) byte,
str2 based str2$adr (1) byte;
/* str2 is the possibly wildcarded filename we are looking for */
do i = 0 to length - 1;
if ((str1(i) and 7fh) <> (str2(i) and 7fh)) and str2(i) <> '?' then
return(false);
end;
return(true);
end compare;
match: procedure boolean public;
dcl i byte,
temp address;
if (i := (buf$fcb(f$drvusr) and 0fh)) <> cur$usr then
if not get$all$dir$entries then /* Not looking for this user */
return(false); /* and not buffering all other*/
else /* specified user files on */
do; temp = 0; /* this drive. */
call set$vec(.temp,i);
if (temp and usr$vector) = 0 then /* Getting all dir entries, */
return(false); /* with user number corresp'g */
end; /* to a bit on in usr$vector */
if usr$vector <> 0 and i <> 0 and first$pass <> 0 then
call set$vec(.active$usr$vector,i); /* skip cur$usr files */
/* build active usr vector for this drive */
do i = 0 to num$search$files - 1;
if search(i).drv = 0ffh or search(i).drv = cur$drv then
/* match on any drive if 0ffh */
if search(i).anyfile = true then
return(not find.exclude); /* file found */
else if compare(11,.buf$fcb(f$name),.search(i).name(0)) then
return(not find.exclude); /* file found */
end;
return(find.exclude); /* file not found */
end match; /* find.exclude = the exclude option value */
dcl hash$table$size lit '128', /* must be power of 2 */
hash$table (hash$table$size) address at (.memory),
/* must be initialized on each*/
hash$entry$adr address, /* disk scan */
hash$entry based hash$entry$adr address; /* where to put a new entry's */
/* address */
hash$look$up: procedure boolean;
dcl (i,found,hash$index) byte;
hash$index = 0;
do i = f$name to f$namelen + f$typelen;
hash$index = hash$index + (buf$fcb(i) and 7fh); /* attributes may */
end; /* only be set w/ 1st extent */
hash$index = hash$index + cur$usr;
hash$index = hash$index and (hash$table$size - 1);
hash$entry$adr = .hash$table(hash$index); /* put new entry in table if */
f$i$adr = hash$table(hash$index); /* unused ( = 0) */
found = false;
do while f$i$adr <> 0 and not found;
if file$info.usr = (buf$fcb(f$drvusr) and 0fh) and
compare(f$namelen + f$typelen,.file$info.name(0),.buf$fcb(f$name))
then
found = true;
else /* table entry used - collison */
do; hash$entry$adr = .file$info.hash$link; /* resolve by linked */
f$i$adr = file$info.hash$link; /* list */
end;
end;
if f$i$adr = 0 then
return(false); /* didn't find it, used hash$entry to keep new info */
else return(true); /* found it, file$info at matched entry */
end hash$look$up;
$eject
store$file$info: procedure boolean;
/* Look for file name of last found fcb or xfcb in fileinfo */
/* array, if not found put name in fileinfo array. Copy other */
/* info to fileinfo or xfcbinfo. The lookup is hash coded with */
/* collisions handled by linking up file$info records through */
/* the hash$link field of the previous file$info record. */
/* The file$info array grows upward in memory and the xfcbinfo */
/* grows downward. */
/*
-------------------------<---.memory
__ | HASH TABLE |
hash = \ of filename -->| root of file$info list|------------>-----------|
func /__ letters | . | |
| . | |
lower memory ------------------------- <-- first$f$i$adr |
| file$info entry | |
(hash) -----<--| . | <----------------------|
(collision) | | . |
------->| . |
| . |-------------------->|
| last file$info entry | <- last$f$i$adr |
|-----------------------| |
| | |
| | |
| unused by dsearch, | |
| used by dsort | |
| for indices | |
| | |
| | |
|-----------------------| |
| last$xfcb entry | <- x$i$adr |
| . | |
| . | |
| . | <-------------------|
| first xfcb entry |
|-----------------------|
| un-usuable memory | <- maxb
higher memory ------------------------- */
dcl (i, j, d$map$cnt) byte,
temp address;
store$file: procedure;
call move(f$namelen + f$typelen, .buf$fcb(f$name),.file$info.name);
/* attributes are not in XFCBs to copy again in case */
/* XFCB came first in directory */
file$info.name(f$arc-1) = file$info.name(f$arc-1) and buf$fcb(f$arc);
/* 0 archive bit if it is 0 in any dir entry */
d$map$cnt = 0; /* count kilobytes for current dir entry */
i = 1; /* 1 or 2 byte block numbers ? */
if dpb$word(blk$max$w) > 255 then
i = 2;
do j = f$diskmap to f$diskmap + diskmaplen - 1 by i;
temp = buf$fcb(j);
if i = 2 then /* word block numbers */
temp = temp or buf$fcb(j+1);
if temp <> 0 then /* allocated */
d$map$cnt = d$map$cnt + 1;
end;
if d$map$cnt > 0 then
do;
call add3byte
(.file$info.recs$lword,
d$map$cnt * (dpb$byte(blkmsk$b) + 1) -
( (128 - buf$fcb(f$rc)) and dpb$byte(blkmsk$b) )
);
file$info.onekblocks = file$info.onekblocks +
d$map$cnt * k$per$block -
shr( (128 - buf$fcb(f$rc)) and dpb$byte(blkmsk$b), 3 );
/* treat each directory entry separately for sparse files */
/* if copied to single density diskette, the number of 1kblocks */
file$info.kbytes = file$info.kbytes + d$map$cnt * k$per$block;
end;
end;
if buf$fcb(f$drvusr) <> sfcb$type then do; /* don't put SFCB's in table */
if not hash$look$up then /* not in table already */
/* hash$entry is where to put adr of new entry */
do; /* copy to new position in file info array */
if (temp := mult23(files$found + 1)) > x$i$adr then
return(false); /* out of memory */
if (temp < first$f$i$adr) then
return(false); /* wrap around - out of memory */
f$i$adr = (last$f$i$adr := last$f$i$adr + size(file$info));
filesfound = filesfound + 1;
call move(f$namelen + f$typelen, .buf$fcb(f$name),.file$info.name);
file$info.usr = buf$fcb(f$drvusr) and 0fh;
file$info.onekblocks,file$info.kbytes,file$info.recs$lword,
file$info.recs$hbyte, file$info.x$i$adr,file$info.hash$link = 0;
hash$entry = f$i$adr; /* save the address of file$info */
end; /* zero totals for the new file */
end;
/* else hash$lookup has set f$i$adr to the file entry already in the */
/* hash table */
/* save sfcb,xfcb or fcb type info */
if sfcbs$present then do;
if (buf$fcb(f$drvusr) and xfcb$type) = 0 then do;
if buf$fcb(f$drvusr) <> sfcb$type then do;
/* store sfcb info into xfcb table */
if buf$fcb(f$ex) <= dpb$byte(extmsk$b) then do;
if last$f$i$adr + size(file$info) > x$i$adr - size(xfcb$info) then
return(false); /* out of memory */
x$i$adr = x$i$adr - size(xfcb$info);
call move(9,sfcb$adr,.xfcb$info.create);
file$info.x$i$adr = x$i$adr;
end; /* extent check */
call store$file;
end;
end;
end;
else do; /* no SFCB's present */
if (buf$fcb(f$drvusr) and xfcb$type) <> 0 then
do; /* XFCB */
/*
if last$f$i$adr + size(file$info) > x$i$adr - size(xfcb$info) then
return(false);
x$i$adr = x$i$adr - size(xfcb$info);
call move(8,.buf$fcb(xf$create),.xfcb$info.create);
xfcb$info.passmode = buf$fcb(xf$passmode);
file$info.x$i$adr = x$i$adr;
*/
end;
else do;
call store$file; /* must be a regular fcb then */
end;
end;
return(true); /* success */
end store$file$info;
/* Module Entry Point */
get$files: procedure public; /* with one scan through directory get */
dcl dcnt byte; /* files from currently selected drive */
call print(.(cr,lf,'Scanning Directory...',cr,lf,'$'));
last$f$i$adr = first$f$i$adr - size(file$info);
/* after hash table */
/* last$f$i$adr is the address of the highest file info record */
/* in memory */
do dcnt = 0 to hash$table$size - 1; /* init hash table */
hash$table(dcnt) = 0;
end;
x$i$adr = maxb; /* top of mem, put xfcb info here */
call base$dpb;
dir$label,filesfound, used$de = 0;
fcb(f$drvusr) = '?'; /* match all dir entries */
dcnt = search$first(.fcb);
sfcb$adr = 96 + .buff; /* determine if SFCB's are present */
if dir$type = sfcb$type then
sfcbs$present = true;
else
sfcbs$present = false;
do while dcnt <> 255;
buf$fcb$adr = shl(dcnt and 11b,5)+.buff; /* dcnt mod 4 * 32 */
if sfcbs$present then
sfcb$adr = 97 + (dcnt * 10) + .buff; /* SFCB time & date stamp adr */
if buf$fcb(f$drvusr) <> deleted$type then
do;
used$de = used$de + 1;
if buf$fcb(f$drvusr) = dirlabel$type then /* dir label ? */
dir$label = buf$fcb(f$ex); /* save label info */
else
if (match) then
do;
if not store$file$info then /* store fcb or xfcb info */
do; /* out of space */
call print (.('Out of Memory',cr,lf,'$'));
return;
end; /* not store$file$info */
end; /* else if match */
end; /* buf$fcb(f$drvusr) <> deleted$type */
call break;
dcnt = search$next; /* to next entry in directory */
end; /* of do while dcnt <> 255 */
end get$files;
search$init: procedure public; /* called once from main.plm */
if (first$f$i$adr := (.hash$table + size(hash$table))) + size(file$info)
> maxb then
do;
call print(.('Not Enough Memory',cr,lf,'$'));
call terminate;
end;
end search$init;
end search;


1854
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/SET.PLM Normal file
View File

File diff suppressed because it is too large Load Diff

1078
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/SETBUF.PLM Normal file
View File

File diff suppressed because it is too large Load Diff

861
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/3.0 SOURCE/SETDEF.PLM Normal file
View File

@@ -0,0 +1,861 @@
$ TITLE('CP/M 3.0 --- SETDEF')
setdef:
do;
/*
Copyright (C) 1982
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
*/
/*
Written: 27 July 82 by John Knight
Modified: 30 Sept 82 by Doug Huskey
Modified: 03 Dec 82 by Bruce Skidmore
*/
/********************************************
* *
* LITERALS AND GLOBAL VARIABLES *
* *
********************************************/
declare
true literally '1',
false literally '0',
forever literally 'while true',
lit literally 'literally',
proc literally 'procedure',
dcl literally 'declare',
addr literally 'address',
cr literally '13',
tab literally '9',
lf literally '10',
ctrlc literally '3',
ctrlx literally '18h',
bksp literally '8',
con$width$offset literally '1ah',
drive0$offset literally '4ch',
drive1$offset literally '4dh',
drive2$offset literally '4eh',
drive3$offset literally '4fh',
temp$drive$offset literally '50h',
ccp$flag1$offset literally '17h',
ccp$flag2$offset literally '18h',
pg$mode$offset literally '2ch',
pg$def$offset literally '2dh',
cpmversion literally '30h';
declare drive$table (4) byte;
declare order$table (2) byte initial(0);
declare drive (4) byte;
declare temp$drive byte;
declare ccp$flag1 byte;
declare ccp$flag2 byte;
declare con$width byte;
declare i byte;
declare begin$buffer address;
declare buf$length byte;
/* display control variables */
declare show$drive byte initial(true);
declare show$order byte initial(true);
declare show$temp byte initial(true);
declare show$page byte initial(true);
declare show$display byte initial(true);
declare scbpd structure
(offset byte,
set byte,
value address);
/* scanner variables and data */
declare
options(*) byte data
('TEMPORARY~ORDER~PAGE~DISPLAY~NO~COM~SUB~NOPAGE~NODISPLAY',
'~ON~OFF',0ffh),
options$offset(*) byte data
(0,10,16,21,29,32,36,40,47,57,60,63),
drives(*) byte data
('*~A:~B:~C:~D:~E:~F:~G:~H:~I:~J:~K:~',
'L:~M:~N:~O:~P:',0ffh),
drives$offset(*) byte data
(0,2,5,8,11,14,17,20,23,26,29,32,
35,38,41,44,47,49),
end$list byte data (0ffh),
delimiters(*) byte data (0,'[]=, ./;()',0,0ffh),
SPACE byte data(5),
j byte initial(0),
buf$ptr address,
index byte,
endbuf byte,
delimiter byte;
declare end$of$string byte initial ('~');
declare plm label public;
/**************************************
* *
* B D O S INTERFACE *
* *
**************************************/
mon1:
procedure (func,info) external;
declare func byte;
declare info address;
end mon1;
mon2:
procedure (func,info) byte external;
declare func byte;
declare info address;
end mon2;
mon3:
procedure (func,info) address external;
declare func byte;
declare info address;
end mon3;
declare cmdrv byte external; /* command drive */
declare fcb (1) byte external; /* 1st default fcb */
declare fcb16 (1) byte external; /* 2nd default fcb */
declare pass0 address external; /* 1st password ptr */
declare len0 byte external; /* 1st passwd length */
declare pass1 address external; /* 2nd password ptr */
declare len1 byte external; /* 2nd passwd length */
declare tbuff (1) byte external; /* default dma buffer */
/**************************************
* *
* B D O S Externals *
* *
**************************************/
printchar:
procedure(char);
declare char byte;
call mon1(2,char);
end printchar;
print$buf:
procedure (buffer$address);
declare buffer$address address;
call mon1 (9,buffer$address);
end print$buf;
version: procedure address;
/* returns current cp/m version # */
return mon3(12,0);
end version;
getscbbyte: procedure (offset) byte;
declare offset byte;
scbpd.offset = offset;
scbpd.set = 0;
return mon2(49,.scbpd);
end getscbbyte;
setscbbyte:
procedure (offset,value);
declare offset byte;
declare value byte;
scbpd.offset = offset;
scbpd.set = 0ffh;
scbpd.value = double(value);
call mon1(49,.scbpd);
end setscbbyte;
/**************************************
* *
* S U B R O U T I N E S *
* *
**************************************/
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * Option scanner * * *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
separator: procedure(character) byte;
/* determines if character is a
delimiter and which one */
declare k byte,
character byte;
k = 1;
loop: if delimiters(k) = end$list then return(0);
if delimiters(k) = character then return(k); /* null = 25 */
k = k + 1;
go to loop;
end separator;
opt$scanner: procedure(list$ptr,off$ptr,idx$ptr);
/* scans the list pointed at by idxptr
for any strings that are in the
list pointed at by list$ptr.
Offptr points at an array that
contains the indices for the known
list. Idxptr points at the index
into the list. If the input string
is unrecognizable then the index is
0, otherwise > 0.
First, find the string in the known
list that starts with the same first
character. Compare up until the next
delimiter on the input. if every input
character matches then check for
uniqueness. Otherwise try to find
another known string that has its first
character match, and repeat. If none
can be found then return invalid.
To test for uniqueness, start at the
next string in the knwon list and try
to get another match with the input.
If there is a match then return invalid.
else move pointer past delimiter and
return.
P.Balma */
declare
buff based buf$ptr (1) byte,
idx$ptr address,
off$ptr address,
list$ptr address;
declare
i byte,
j byte,
list based list$ptr (1) byte,
offsets based off$ptr (1) byte,
wrd$pos byte,
character byte,
letter$in$word byte,
found$first byte,
start byte,
index based idx$ptr byte,
save$index byte,
(len$new,len$found) byte,
valid byte;
/*****************************************************************************/
/* internal subroutines */
/*****************************************************************************/
check$in$list: procedure;
/* find known string that has a match with
input on the first character. Set index
= invalid if none found. */
declare i byte;
i = start;
wrd$pos = offsets(i);
do while list(wrd$pos) <> end$list;
i = i + 1;
index = i;
if list(wrd$pos) = character then return;
wrd$pos = offsets(i);
end;
/* could not find character */
index = 0;
return;
end check$in$list;
setup: procedure;
character = buff(0);
call check$in$list;
letter$in$word = wrd$pos;
/* even though no match may have occurred, position
to next input character. */
i = 1;
character = buff(1);
end setup;
test$letter: procedure;
/* test each letter in input and known string */
letter$in$word = letter$in$word + 1;
/* too many chars input? 0 means
past end of known string */
if list(letter$in$word) = end$of$string then valid = false;
else
if list(letter$in$word) <> character then valid = false;
i = i + 1;
character = buff(i);
end test$letter;
skip: procedure;
/* scan past the offending string;
position buf$ptr to next string...
skip entire offending string;
ie., falseopt=mod, [note: comma or
space is considered to be group
delimiter] */
character = buff(i);
delimiter = separator(character);
/* No skip for SETPATH */
do while ((delimiter < 1) or (delimiter > 11));
i = i + 1;
character = buff(i);
delimiter = separator(character);
end;
endbuf = i;
buf$ptr = buf$ptr + endbuf + 1;
return;
end skip;
eat$blanks: procedure;
declare charac based buf$ptr byte;
do while ((delimiter := separator(charac)) = SPACE);
buf$ptr = buf$ptr + 1;
end;
end eat$blanks;
/*****************************************************************************/
/* end of internals */
/*****************************************************************************/
/* start of procedure */
call eat$blanks;
start = 0;
call setup;
/* match each character with the option
for as many chars as input
Please note that due to the array
indices being relative to 0 and the
use of index both as a validity flag
and as a index into the option/mods
list, index is forced to be +1 as an
index into array and 0 as a flag*/
do while index <> 0;
start = index;
delimiter = separator(character);
/* check up to input delimiter */
valid = true; /* test$letter resets this */
do while delimiter = 0;
call test$letter;
if not valid then go to exit1;
delimiter = separator(character);
end;
go to good;
/* input ~= this known string;
get next known string that
matches */
exit1: call setup;
end;
/* fell through from above, did
not find a good match*/
endbuf = i; /* skip over string & return*/
call skip;
return;
/* is it a unique match in options
list? */
good: endbuf = i;
len$found = endbuf;
save$index = index;
valid = false;
next$opt:
start = index;
call setup;
if index = 0 then go to finished;
/* look at other options and check
uniqueness */
len$new = offsets(index + 1) - offsets(index) - 1;
if len$new = len$found then do;
valid = true;
do j = 1 to len$found;
call test$letter;
if not valid then go to next$opt;
end;
end;
else go to nextopt;
/* fell through...found another valid
match --> ambiguous reference */
index = 0;
call skip; /* skip input field to next delimiter*/
return;
finished: /* unambiguous reference */
index = save$index;
buf$ptr = buf$ptr + endbuf;
call eat$blanks;
if delimiter <> 0 then
buf$ptr = buf$ptr + 1;
else
delimiter = 5;
return;
end opt$scanner;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
crlf: proc;
call printchar(cr);
call printchar(lf);
end crlf;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* The error processor. This routine prints the command line
with a carot '^' under the offending delimiter, or sub-string.
The code passed to the routine determines the error message
to be printed beneath the command string. */
error: procedure (code);
declare (code,i,j,nlines,rem) byte;
declare (string$ptr,tstring$ptr) address;
declare chr1 based string$ptr byte;
declare chr2 based tstring$ptr byte;
declare carot$flag byte;
print$command: procedure (size);
declare size byte;
do j=1 to size; /* print command string */
call printchar(chr1);
string$ptr = string$ptr + 1;
end;
call crlf;
do j=1 to size; /* print carot if applicable */
if .chr2 = buf$ptr then do;
carot$flag = true;
call printchar('^');
end;
else
call printchar(' ');
tstring$ptr = tstring$ptr + 1;
end;
call crlf;
end print$command;
carot$flag = false;
string$ptr,tstring$ptr = begin$buffer;
con$width = getscbbyte(con$width$offset);
if con$width < 40 then con$width = 40;
nlines = buf$length / con$width; /* num lines to print */
rem = buf$length mod con$width; /* num extra chars to print */
if ((code = 1) or (code = 5)) then /* adjust carot pointer */
buf$ptr = buf$ptr - 1; /* for delimiter errors */
else
buf$ptr = buf$ptr - endbuf - 1; /* all other errors */
call crlf;
do i=1 to nlines;
tstring$ptr = string$ptr;
call print$command(con$width);
end;
call print$command(rem);
if carot$flag then
call print$buf(.('Error at the ''^''; $'));
else
call print$buf(.('Error at end of line; $'));
if con$width < 65 then
call crlf;
do case code;
call print$buf(.('More than four drives specified$'));
call print$buf(.('Invalid delimiter$'));
call print$buf(.('Invalid drive$'));
call print$buf(.('Invalid type for ORDER option$'));
call print$buf(.('Invalid option$'));
call print$buf(.('End of line expected$'));
call print$buf(.('Drive defined twice in search path$'));
call print$buf(.('Invalid ORDER specification$'));
call print$buf(.('Must be ON or OFF$'));
end;
call crlf;
call mon1(0,0);
end error;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* This is the main screen display for SETPATH. After every
successful operation, this procedure will be called to
show the results. This routine is also called whenever the
user just types SETPATH with no options. */
display$path: procedure;
declare i byte;
declare (display$flag,pg$mode,order) byte;
/* GET SETTINGS FROM SYSTEM CONTROL BLOCK */
drive(0) = getscbbyte(drive0$offset);
drive(1) = getscbbyte(drive1$offset);
drive(2) = getscbbyte(drive2$offset);
drive(3) = getscbbyte(drive3$offset);
temp$drive = getscbbyte(temp$drive$offset);
pg$mode = getscbbyte(pg$mode$offset);
ccp$flag2 = getscbbyte(ccp$flag2$offset);
display$flag = ccp$flag2 and 00$000$011b;
order = shr((ccp$flag2 and 00$011$000b),3);
/* 0 = COM, 1 = COM,SUB, 2 = SUB,COM */
/* DRIVE SEARCH PATH */
if show$drive then do;
call crlf;
call print$buf(.('Drive Search Path:',cr,lf,'$'));
i = 0;
do while ((drive(i) <> 0ffh) and (i < 4));
call printchar(i + '1');
do case i;
call print$buf(.('st$'));
call print$buf(.('nd$'));
call print$buf(.('rd$'));
call print$buf(.('th$'));
end;
call print$buf(.(' Drive - $'));
if drive(i) = 0 then
call print$buf(.('Default$'));
else do;
call printchar(drive(i) + 40h);
call printchar(':');
end;
call crlf;
i = i + 1;
end;
end;
/* PROGRAM vs. SUBMIT SEARCH ORDER */
if show$order then do;
call crlf;
call print$buf(.('Search Order - $'));
do case order;
call print$buf(.('COM$'));
call print$buf(.('COM, SUB$'));
call print$buf(.('SUB, COM$'));
end;
end;
/* TEMPORARY FILE DRIVE */
if show$temp then do;
call crlf;
call print$buf(.('Temporary Drive - $'));
if temp$drive > 16
then temp$drive = 0;
if temp$drive = 0 then
call print$buf(.('Default$'));
else do;
call printchar(temp$drive + 40h);
call printchar(':');
end;
end;
/* CONSOLE PAGE MODE */
if show$page then do;
call crlf;
call print$buf(.('Console Page Mode - $'));
if pg$mode = 0 then
call print$buf(.('On$'));
else
call print$buf(.('Off$'));
end;
/* PROGRAM NAME & DRIVE DISPLAY */
if show$display then do;
call crlf;
call print$buf(.('Program Name Display - $'));
if display$flag = 0 then
call print$buf(.('Off$'));
else
call print$buf(.('On$'));
end;
call crlf;
end display$path;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* This routine processes the search drives string. When called
this routine scans the command line expecting a drive name, a:-p:.
It puts the drive code in a drive table and continues the scan
collecting drives until more than 4 drives are specified (an error)
or an eoln or the delimiter '[' is encountered. Next it modifies
the SCB searchchain bytes so that it reflects the drive order as
inputed. No check is made to insure that the drive specified is
a known drive to the particular system being used. */
process$drives: procedure;
declare (i,ct) byte;
show$drive = true;
index = 0;
delimiter = 0;
do i=0 to 3; /* clear drive table */
drive$table(i) = 0ffh;
end;
ct = 0;
do while ((delimiter <> 1) and (delimiter <> 11)); /* not eoln */
call opt$scanner(.drives(0),.drives$offset(0),.index);
if ct > 3 then /* too many drives */
call error(0);
if index = 0 then /* invalid drive */
call error(2);
do i=0 to 3;
if drive$table(i) = (index-1) then
call error(6); /* Drive already defined */
end;
drive$table(ct) = index-1;
ct = ct + 1;
end;
do i=0 to 3; /* update scb drive table */
call setscbbyte(drive0$offset+i,drive$table(i));
end;
end process$drives;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* This routine does all the processing for the options. Ie. any
string beginning with a '['. The routine will handle basically
five options: Temporary, Order, Display, Page, No Display and
No Page. Each routine is fairly short and can be found as a
branch in the case statement.
*/
process$options: procedure;
declare next$delim based buf$ptr byte;
declare (first$sub,paren,val) byte;
do while (delimiter <> 2) and (delimiter <> 11);
index = 0;
delimiter = 1;
call opt$scanner(.options(0),.options$offset(0),.index);
do case index;
call error(4); /* not in options list (INVALID) */
do; /* temporary drive option */
show$temp = true;
if delimiter <> 3 then /* = */
call error(1);
call opt$scanner(.drives(0),.drives$offset(0),.index);
if index = 0 then
call error(2);
call setscbbyte(temp$drive$offset,index-1);
end;
do; /* order option */
show$order = true;
first$sub,paren = false;
if delimiter <> 3 then /* = */
call error(1);
do while ((next$delim = ' ') or (next$delim = tab)); /* skip spaces */
buf$ptr = buf$ptr + 1;
end;
if next$delim = '(' then do;
paren = true;
buf$ptr = buf$ptr + 1;
end;
call opt$scanner(.options(0),.options$offset(0),.index);
if ((index <> 6) and (index <> 7)) then
call error(3);
if index = 7 then /* note that the first entry was SUB */
first$sub = true;
order$table(0) = index - 6;
if (first$sub and ((delimiter = 10) or not paren)) then
call error(7); /* (SUB) not allowed */
if (delimiter <> 10) and paren then do;
call opt$scanner(.options(0),.options$offset(0),.index);
if ((index <> 6) and (index <> 7)) then
call error(3);
order$table(1) = index - 6;
if (first$sub and (index = 7)) then /* can't have SUB,SUB */
call error(7);
end;
ccp$flag2 = getscbbyte(ccp$flag2$offset);
if order$table(0) = 0 then
ccp$flag2 = ccp$flag2 and 111$0$1111b;
else
ccp$flag2 = ccp$flag2 or 000$1$0000b;
if order$table(1) = 0 then
ccp$flag2 = ccp$flag2 and 1111$0$111b;
else
ccp$flag2 = ccp$flag2 or 0000$1$000b;
call setscbbyte(ccp$flag2$offset,ccp$flag2);
if paren then do;
if delimiter <> 10 then
call error(1);
else
buf$ptr = buf$ptr + 1;
end;
else if delimiter = 10 then
call error(1);
if next$delim = ']' or next$delim = 0 then /* two delimiters */
delimiter = 11; /* eoln, so exit loop */
end;
/* PAGE Option */
do;
show$page = true;
val = 0;
if delimiter = 3 then do; /* = */
call opt$scanner(.options(0),.options$offset(0),.index);
if index <> 10 then
if index = 11 then
val = 0ffh;
else
call error(8);
end;
call setscbbyte(pg$mode$offset,val);
call setscbbyte(pg$def$offset,val);
end;
/* call error(4); page option now an error */
do; /* DISPLAY option */
show$display,val = true;
if delimiter = 3 then do; /* = */
call opt$scanner(.options(0),.options$offset(0),.index);
if index <> 10 then
if index = 11 then
val = false;
else
call error(8);
end;
ccp$flag2 = getscbbyte(ccp$flag2$offset);
if val then
ccp$flag2 = ccp$flag2 or 00000$0$11b; /* set bits */
else
ccp$flag2 = ccp$flag2 and 11111$1$00b; /* clear bits */
call setscbbyte(ccp$flag2$offset,ccp$flag2);
end;
/* call error(4); Display option now an error */
do; /* NO keyword */
call opt$scanner(.options(0),.options$offset(0),.index);
if (index <> 3) and (index <> 4) then
call error(4);
if index = 3 then do; /* NO PAGE option */
show$page = true;
call setscbbyte(pg$mode$offset,0FFh);
call setscbbyte(pg$def$offset,0FFh);
end;
else do; /* NO DISPLAY option */
show$display = true;
ccp$flag2 = getscbbyte(ccp$flag2$offset);
ccp$flag2 = ccp$flag2 and 11111$1$00b; /* clear bits */
call setscbbyte(ccp$flag2$offset,ccp$flag2);
end;
end;
/* call error(4); NO keyword is now an error */
call error(4); /* COM is not an option */
call error(4); /* SUB is not an option */
/* NOPAGE option */
do;
show$page = true;
call setscbbyte(pg$mode$offset,0FFh);
call setscbbyte(pg$def$offset,0FFh);
end;
/* NODISPLAY option */
do;
show$display = true;
ccp$flag2 = getscbbyte(ccp$flag2$offset);
ccp$flag2 = ccp$flag2 and 11111$1$00b; /* clear bits */
call setscbbyte(ccp$flag2$offset,ccp$flag2);
end;
call error(4); /* ON is not an option */
call error(4); /* OFF is not an option */
end;
end;
end process$options;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
input$found: procedure (buffer$adr) byte;
declare buffer$adr address;
declare char based buffer$adr byte;
do while (char = ' ') or (char = 9); /* tabs & spaces */
buffer$adr = buffer$adr + 1;
end;
if char = 0 then /* eoln */
return false; /* input not found */
else
return true; /* input found */
end input$found;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/**************************************
* *
* M A I N P R O G R A M *
* *
**************************************/
plm:
do;
if (low(version) < cpmversion) or (high(version) = 1) then do;
call print$buf(.('Requires CP/M 3.0$'));
call mon1(0,0);
end;
if not input$found(.tbuff(1)) then do;
/* SHOW DEFAULTS */
call display$path;
call mon1(0,0); /* & terminate */
end;
/* SET DEFAULTS */
i = 1; /* skip over leading spaces */
do while (tbuff(i) = ' ');
i = i + 1;
end;
show$drive,show$order,show$temp,show$page,show$display
= false;
begin$buffer = .tbuff(1); /* note beginning of input */
buf$length = tbuff(0); /* note length of input */
buf$ptr = .tbuff(i); /* set up for scanner */
if tbuff(i) = '[' then do; /* options, no drives */
buf$ptr = buf$ptr + 1; /* skip over '[' */
call process$options;
end;
else do; /* drives first, maybe options too */
call process$drives;
if delimiter = 1 then /* options, because we found an '[' */
call process$options;
end;
call display$path; /* show results */
call mon1(0,0); /* & terminate */
end;
end setdef;


Some files were not shown because too many files have changed in this diff Show More