seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-24 17:04:19 +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

320
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/Makefile Normal file
View File

@@ -0,0 +1,320 @@
#
# Unix Makefile for CP/M 3.1
#
OBJS=mcd80a.obj mcd80f.obj parse.obj
#
HEXS=copysys.hex ccp3.hex ccpdate.hex date.hex device.hex dir.hex \
dump.hex ed.hex erase.hex get.hex gencom.hex gencpm.hex help.hex \
hexcom.hex patch.hex pip.hex put.hex rename.hex set.hex setdef.hex \
show.hex submit.hex type.hex minhlp.hex
OBJS=copysys.obj ccp3.obj ccpdate.obj date.obj device.obj dir.obj \
dump.obj ed.obj erase.obj get.obj gencom.obj gencpm.obj help.obj \
objcom.obj patch.obj pip.obj put.obj rename.obj set.obj setdef.obj \
show.obj submit.obj type.obj minhlp.obj
BLKS=date device dir disp dpb80 ed erase gencom gencpm get hexcom hexpat \
help main80 minhlp pip put rename scan search set setdef show sort \
submit timest type util
MCOMS = copysys.com ccp.com date.com device.com dir.com dump.com ed.com \
erase.com get.com gencom.com gencpm.com help.com hexcom.com patch.com \
pip.com put.com rename.com save.com set.com setdef.com show.com \
submit.com type.com sid.com
BDOS = resbdos3.spr bdos3.spr bnkbdos3.spr
ZXCC = zxcc
THAMES = ./runthames
MAC=mac.com
RMAC=rmac.com
LINK=drlink.com
BINARIES= bdos3.spr date.com erase.com help.hlp README \
setdef.com bnkbdos3.spr device.com gencom.com hexcom.com \
rename.com show.com ccp.com dir.com gencpm.com \
patch.com resbdos3.spr submit.com copysys.com dump.com \
get.com pip.com save.com type.com cpmldr.rel \
ed.com help.com put.com set.com sid.com
SOURCES= assemble.txt disp.plm hexcom.asm parse.asm search.plm \
bdos30.asm dpb80.plm hexcom.c patch.asm setbuf.plm \
bios.bin dpb.lit hexpat.c pip.plm setdef.plm \
bioskrnl.asm drvtbl.asm inpout.asm plibios3.asm set.plm \
boot.asm dump.asm ldrlwr.asm plibios.asm show.plm \
callvers.asm echovers.asm _libios3.asm plidio.asm sopt.dcl \
ccp3.asm ed.plm _lidio.asm prs0mov.asm sopt.inc \
ccp3org.asm drlink.com prs1asm.asm sort.plm \
ccpdate.asm erase.plm loader3.asm prs2mon.asm submit.plm \
chario.asm fcb.lit mac.com putf.asm subrsx.asm \
comlit.lit fd1797sd.asm main80.plm put.plm timest.plm \
conbdos.asm finfo.lit main.plm putrsx.asm type.plm \
copyrt.lit format.lit makedate.lib random.asm _ump.asm \
copysys.asm gencom.plm Makefile README util.plm \
cpmbdos1.asm gencpm.plm making.txt rename.plm utl0mov.asm \
cpmbdos2.asm getdef.plm mcd80a.asm resbdos.asm utl1hst.asm \
cpmldr.asm getf.asm mcd80f.asm rmac.com utl2trc.asm \
crdef.plm get.plm minhlp.plm save.asm vers.lit \
date.plm getrsx.asm mon.plm scan.lit xfcb.lit \
datmod.asm getrsx.lib move.asm scan.plm \
device.plm help.dat newpip.plm scb.asm \
dirlbl.asm help.plm _opysys.asm search.lit runthames
all: $(MCOMS) $(BDOS) cpmldr.rel help.hlp
zip: cpm3src_unix.zip cpm3bin_unix.zip
cpm3src_unix.zip: $(SOURCES)
zip $@ $(SOURCES)
cpm3bin_unix.zip: $(BINARIES)
zip $@ $(BINARIES)
############################################################################
#
# Build tools
#
hexcom: hexcom.c
${CC} -o hexcom hexcom.c
hexpat: hexpat.c
${CC} -o hexpat hexpat.c
##############################################################################
#
# Help
#
help.hlp: help.dat minhlp.com
$(ZXCC) minhlp.com -[CREATE]
#
##############################################################################
#
# Specific build rules
#
# The redirection to CCPPHASE.* produces two lists of addresses (one in
# CCP3.COM and one in LOADER3.PRL) which should match.
#
loader3.rel: loader3.asm
$(ZXCC) $(RMAC) loader3 >ccpphase.lst
ccp3.hex: ccp3.asm
$(ZXCC) $(MAC) ccp3 >> ccpphase.lst
ccp.com: loader3d.tmp hexpat ccpdate.hex
./hexpat $< $@ < ccpdate.hex
loader3d.tmp: loader3c.tmp hexpat ccp3.hex
./hexpat $< $@ < ccp3.hex
loader3c.tmp: loader3a.tmp loader3b.tmp
cat loader3a.tmp loader3b.tmp > $@
# Shave the header off loader3.prl to get the loader image
loader3a.tmp: loader3.prl
dd if=loader3.prl of=loader3a.tmp bs=128 skip=2
# This empty space will be overwritten by ccp3.hex
loader3b.tmp:
dd if=/dev/zero of=loader3b.tmp bs=128 count=19
dir.tra: dir.mod
$(THAMES) :F3:locate $< code\(0100h\) stacksize\(50\) map print\($@\)
dir.mod: main80 scan search sort disp dpb80 util timest mcd80a.obj
$(THAMES) :F3:link mcd80a.obj,main80,scan,search,sort,disp,util,dpb80,timest,:F1:plm80.lib to dir.mod
erase.mod: erase.obj parse.obj mcd80a.obj
$(THAMES) :F3:link mcd80a.obj,parse.obj,$<,:F1:plm80.lib to $@
gencom.mod: gencom.obj parse.obj mcd80a.obj
$(THAMES) :F3:link mcd80a.obj,parse.obj,$<,:F1:plm80.lib to $@
gencpm.mod: gencpm.obj setbuf.obj getdef.obj crdef.obj ldrlwr.obj \
mcd80f.obj datmod.obj
$(THAMES) :F3:link mcd80f.obj,$<,setbuf.obj,getdef.obj,crdef.obj,ldrlwr.obj,datmod.obj,:F1:plm80.lib to $@
get.mod: get.obj mcd80a.obj parse.obj getf.obj
$(THAMES) :F3:link mcd80a.obj,$<,parse.obj,getf.obj,:F1:plm80.lib to $@
get.com: get.hex getrsx.rsx gencom.com hexcom
./hexcom $@ <$<
cp getrsx.rsx get.rsx
$(ZXCC) gencom.com $@ get.rsx
get.rsx: getrsx.rel
$(ZXCC) $(LINK) getrsx +-[OP]
mv -f getrsx.prl $@
pip.mod: pip.obj mcd80f.obj inpout.obj
$(THAMES) :F3:link mcd80f.obj,inpout.obj,$<,:F1:plm80.lib to $@
put.mod: put.obj mcd80a.obj parse.obj putf.obj
$(THAMES) :F3:link mcd80a.obj,$<,parse.obj,putf.obj,:F1:plm80.lib to $@
put.com: put.hex put.rsx gencom.com hexcom
./hexcom $@ <$<
$(ZXCC) gencom.com $@ put.rsx
put.rsx: putrsx.rel
$(ZXCC) $(LINK) putrsx +-[OP]
mv -f putrsx.prl $@
save.com: save.rsx gencom.com
rm -f $@
$(ZXCC) gencom save +-[NULL]
set.com: set.hex dirlbl.rsx gencom.com hexcom
./hexcom $@ <$<
$(ZXCC) gencom.com $@ dirlbl.rsx
sid.com: hexpat sid.spr prs0mov.hex
./hexpat sid.spr $@ <prs0mov.hex
submit.com: submit.hex subrsx.rsx gencom.com hexcom
./hexcom $@ <$<
cp subrsx.rsx sub.rsx
$(ZXCC) gencom.com $@ sub.rsx
rename.mod: rename.obj parse.obj mcd80a.obj
$(THAMES) :F3:link mcd80a.obj,$<,parse.obj,:F1:plm80.lib to $@
set.mod: set.obj parse.obj mcd80a.obj
$(THAMES) :F3:link mcd80a.obj,parse.obj,$<,:F1:plm80.lib to $@
submit.mod: submit.obj parse.obj getf.obj mcd80a.obj
$(THAMES) :F3:link mcd80a.obj,$<,parse.obj,getf.obj,:F1:plm80.lib to $@
type.mod: type.obj parse.obj mcd80a.obj
$(THAMES) :F3:link mcd80a.obj,$<,parse.obj,:F1:plm80.lib to $@
mcd80f.obj: mcd80f.asm
$(THAMES) :F2:asm80 $<
resbdos3.spr: resbdos.rel
$(ZXCC) $(LINK) resbdos3 +-= +resbdos +-[os]
bdos3.spr: cpmbdosx.rel
$(ZXCC) $(LINK) bdos3 +-= cpmbdosx +-[os]
bnkbdos3.spr: cpmbdos.rel
$(ZXCC) $(LINK) bnkbdos3 +-= cpmbdos +-[os]
cpmbdosx.asm: cpmbdos1.asm conbdos.asm bdos30.asm makedate.lib
cat cpmbdos1.asm conbdos.asm bdos30.asm > $@
cpmbdos.asm: cpmbdos2.asm conbdos.asm bdos30.asm makedate.lib
cat cpmbdos2.asm conbdos.asm bdos30.asm > $@
# Bits of DIR
main80: main80.plm
$(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\)
scan: scan.plm
$(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\)
search: search.plm
$(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\)
sort: sort.plm
$(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\)
disp: disp.plm
$(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\)
dpb80: dpb80.plm
$(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\)
util: util.plm
$(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\)
timest: timest.plm
$(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\)
##############################
#
# SID
#
sid.spr: prs1asm.rel prs2mon.rel
$(ZXCC) $(LINK) sid.spr +-= +prs1asm +-, +prs2mon +-[OS]
prs0mov.hex: prs0mov.asm makedate.lib
$(ZXCC) $(MAC) prs0mov
prs1asm.rel: prs1asm.asm
$(ZXCC) $(RMAC) prs1asm
prs2mon.rel: prs2mon.asm
$(ZXCC) $(RMAC) prs2mon
##############################################################################
#
# Generic build rules
#
%.obj: %.asm
$(THAMES) :F2:asm80 $< debug
###########################################################################
#
# COM files from hex files
#
%.com: %.hex hexcom
./hexcom $@ < $<
###########################################################################
#
# HEX files from asm source
#
%.hex: %.asm makedate.lib
$(ZXCC) $(MAC) `basename $< .asm`
###########################################################################
#
# HEX files from PL/M source
#
%.hex: %.tra
$(THAMES) :F3:objhex `basename $< .tra` to $@
# The "%.tra" rule also builds "%", which is what objhex actually uses, but
# I couldn't get a bare % rule to work.
%.tra: %.mod
$(THAMES) :F3:locate $< code\(0100h\) stacksize\(100\) map print\($@\)
%.mod: %.obj mcd80a.obj
$(THAMES) :F3:link mcd80a.obj,$<,:F1:plm80.lib to $@
%.obj: %.plm
$(THAMES) :F1:plm80 $< optimize debug
###########################################################################
#
# PRL and RSX files from .REL files
#
%.prl: %.rel
$(ZXCC) $(LINK) `basename $< .rel` +-[OP]
%.spr: %.rel loader*.tmp
$(ZXCC) $(LINK) `basename $< .rel` +-[OS]
%.rsx: %.rel
$(ZXCC) $(LINK) `basename $< .rel` +-[OP]
mv -f `basename $< .rel`.prl `basename $< .rel`.rsx
%.rel: %.asm
$(ZXCC) $(RMAC) `basename $< .asm`
#
#
#
clean:
rm -f $(MCOMS) $(HEXS) $(BLKS) *.lst *.rel *.sym *.tra *.rsx *.spr \
*.mod *.obj loader*.tmp help.hlp

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

@@ -0,0 +1,39 @@
CP/M 3
======
This archive contains an almost complete build of CP/M 3.
If you have the source distribution, the file making.txt explains how to
set up the build environment on your computer.
Differences from Digital Research CP/M 3
========================================
All the CP/M 3 patches described in the document CPM3FIX.PAT have been
applied to the source code, except those to INITDIR. Patches 1-18 (except
nos. 5 and 9) were applied.
CP/M 3 is now fully Year 2000 compliant. This affects the programs
DATE.COM, DIR.COM and SHOW.COM.
Dates can be displayed in US, UK or Year-Month-Day format. This is set by
SETDEF:
SETDEF [US]
SETDEF [UK]
SETDEF [YMD] respectively.
The CCP has a further bug fix: A command sequence such as:
C1
:C2
:C3
will now not execute the command C3 if the command C1 failed.
What's missing?
===============
INITDIR.COM - because it is written in PL/I and I can't make the
PL/I compiler at <http://cdl.uta.edu/cpm> compile it.
Apparently a more recent version of the compiler is
required.

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

@@ -0,0 +1,44 @@
The same as above to be built under Unix.
/README
CP/M 3
======
This archive contains an almost complete build of CP/M 3.
If you have the source distribution, the file making.txt explains how to
set up the build environment on your computer.
Differences from Digital Research CP/M 3
========================================
All the CP/M 3 patches described in the document CPM3FIX.PAT have been
applied to the source code, except those to INITDIR. Patches 1-18 (except
nos. 5 and 9) were applied.
CP/M 3 is now fully Year 2000 compliant. This affects the programs
DATE.COM, DIR.COM and SHOW.COM.
Dates can be displayed in US, UK or Year-Month-Day format. This is set by
SETDEF:
SETDEF [US]
SETDEF [UK]
SETDEF [YMD] respectively.
The CCP has a further bug fix: A command sequence such as:
C1
:C2
:C3
will now not execute the command C3 if the command C1 failed.
What's missing?
===============
INITDIR.COM - because it is written in PL/I and I can't make the
PL/I compiler at <http://cdl.uta.edu/cpm> compile it.
Apparently a more recent version of the compiler is
required.

152
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/_libios3.asm Normal file
View File

@@ -0,0 +1,152 @@
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
public bflush ;flush BIOS deblocking buffers
;
;
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
;
bflush: ;flush bios buffers
mvi a,24
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

607
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/_lidio.asm Normal file
View File

@@ -0,0 +1,607 @@
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)
;
;
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
;
; 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 ;length to a
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
;
;***********************************************************
;* *
;***********************************************************
end

835
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/_opysys.asm Normal file
View File

@@ -0,0 +1,835 @@
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

208
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/_ump.asm Normal file
View File

@@ -0,0 +1,208 @@
; Dump program, reads input file and displays hex data
;
org 100h
bdos equ 0005h ;dos entry point
cons equ 1 ;read console
typef equ 2 ;type function
printf equ 9 ;buffer print entry
brkf equ 11 ;break key function (true if char ready)
openf equ 15 ;file open
readf equ 20 ;read function
;
fcb equ 5ch ;file control block address
buff equ 80h ;input disk buffer address
;
; non graphic characters
cr equ 0dh ;carriage return
lf equ 0ah ;line feed
;
; file control block definitions
fcbdn equ fcb+0 ;disk name
fcbfn equ fcb+1 ;file name
fcbft equ fcb+9 ;disk file type (3 characters)
fcbrl equ fcb+12 ;file's current reel number
fcbrc equ fcb+15 ;file's record count (0 to 128)
fcbcr equ fcb+32 ;current (next) record number (0 to 127)
fcbln equ fcb+33 ;fcb length
;
; set up stack
lxi h,0
dad sp
; entry stack pointer in hl from the ccp
shld oldsp
; set sp to local stack area (restored at finis)
lxi sp,stktop
; read and print successive buffers
call setup ;set up input file
cpi 255 ;255 if file not present
jnz openok ;skip if open is ok
;
; file not there, give error message and return
lxi d,opnmsg
call err
jmp finis ;to return
;
openok: ;open operation ok, set buffer index to end
mvi a,80h
sta ibp ;set buffer pointer to 80h
; hl contains next address to print
lxi h,0 ;start with 0000
;
gloop:
push h ;save line position
call gnb
pop h ;recall line position
jc finis ;carry set by gnb if end file
mov b,a
; print hex values
; check for line fold
mov a,l
ani 0fh ;check low 4 bits
jnz nonum
; print line number
call crlf
;
; check for break key
call break
; accum lsb = 1 if character ready
rrc ;into carry
jc finis ;don't print any more
;
mov a,h
call phex
mov a,l
call phex
nonum:
inx h ;to next line number
mvi a,' '
call pchar
mov a,b
call phex
jmp gloop
;
finis:
; end of dump
call crlf
lhld oldsp
sphl
; stack pointer contains ccp's stack location
ret ;to the ccp
;
;
; subroutines
;
break: ;check break key (actually any key will do)
push h! push d! push b; environment saved
mvi c,brkf
call bdos
pop b! pop d! pop h; environment restored
ret
;
pchar: ;print a character
push h! push d! push b; saved
mvi c,typef
mov e,a
call bdos
pop b! pop d! pop h; restored
ret
;
crlf:
mvi a,cr
call pchar
mvi a,lf
call pchar
ret
;
;
pnib: ;print nibble in reg a
ani 0fh ;low 4 bits
cpi 10
jnc p10
; less than or equal to 9
adi '0'
jmp prn
;
; greater or equal to 10
p10: adi 'a' - 10
prn: call pchar
ret
;
phex: ;print hex char in reg a
push psw
rrc
rrc
rrc
rrc
call pnib ;print nibble
pop psw
call pnib
ret
;
err: ;print error message
; d,e addresses message ending with "$"
mvi c,printf ;print buffer function
call bdos
ret
;
;
gnb: ;get next byte
lda ibp
cpi 80h
jnz g0
; read another buffer
;
;
call diskr
ora a ;zero value if read ok
jz g0 ;for another byte
; end of data, return with carry set for eof
stc
ret
;
g0: ;read the byte at buff+reg a
mov e,a ;ls byte of buffer index
mvi d,0 ;double precision index to de
inr a ;index=index+1
sta ibp ;back to memory
; pointer is incremented
; save the current file address
lxi h,buff
dad d
; absolute character address is in hl
mov a,m
; byte is in the accumulator
ora a ;reset carry bit
ret
;
setup: ;set up file
; open the file for input
xra a ;zero to accum
sta fcbcr ;clear current record
;
lxi d,fcb
mvi c,openf
call bdos
; 255 in accum if open error
ret
;
diskr: ;read disk file record
push h! push d! push b
lxi d,fcb
mvi c,readf
call bdos
pop b! pop d! pop h
ret
;
; fixed message area
signon: db 'file dump version 2.0$'
opnmsg: db cr,lf,'no input file present on disk$'
; variable area
ibp: ds 2 ;input buffer pointer
oldsp: ds 2 ;entry sp value from ccp
;
; stack area
ds 64 ;reserve 32 level stack
stktop:
;
end

20
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/assemble.txt Normal file
View File

@@ -0,0 +1,20 @@
Assembling CP/M 3
=================
The original CP/M 3 build process seems to have been written for a CP/M 3
computer; it uses the MAC, RMAC, LINK, GENCOM and HEXCOM tools, which are
not readily available for other platforms in this day and age.
HEXCOM.C (based on LOAD.C in <ftp://oak.oakland.edu/pub/unix-c/> ) serves
as a suitable replacement for HEXCOM. The command syntax is:
HEXCOM comfile <hexfile
Similarly, to build SID and the CCP, HEXPAT.C has been supplied to overlay
a COM file with a HEX file.
The other tools are run under emulation rather than being ported. You will
need to install two emulators for this: ZXCC (version 0.3 or later) and
Thames (version 0.1.0 or later). ZXCC is used to run the CP/M-hosted build
tools, while Thames runs the ISIS-hosted build tools.

6280
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/bdos30.asm Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/bios.bin Normal file
View File

Binary file not shown.

653
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/bioskrnl.asm Normal file
View File

@@ -0,0 +1,653 @@
title 'Root module of relocatable BIOS for CP/M 3.0'
; version 1.0 15 Sept 82
true equ -1
false equ not true
banked equ true
; Copyright (C), 1982
; Digital Research, Inc
; P.O. Box 579
; Pacific Grove, CA 93950
; This is the invariant portion of the modular BIOS and is
; distributed as source for informational purposes only.
; All desired modifications should be performed by
; adding or changing externally defined modules.
; This allows producing "standard" I/O modules that
; can be combined to support a particular system
; configuration.
cr equ 13
lf equ 10
bell equ 7
ctlQ equ 'Q'-'@'
ctlS equ 'S'-'@'
ccp equ 0100h ; Console Command Processor gets loaded into the TPA
cseg ; GENCPM puts CSEG stuff in common memory
; variables in system data page
extrn @covec,@civec,@aovec,@aivec,@lovec ; I/O redirection vectors
extrn @mxtpa ; addr of system entry point
extrn @bnkbf ; 128 byte scratch buffer
; initialization
extrn ?init ; general initialization and signon
extrn ?ldccp,?rlccp ; load & reload CCP for BOOT & WBOOT
; user defined character I/O routines
extrn ?ci,?co,?cist,?cost ; each take device in <B>
extrn ?cinit ; (re)initialize device in <C>
extrn @ctbl ; physical character device table
; disk communication data items
extrn @dtbl ; table of pointers to XDPHs
public @adrv,@rdrv,@trk,@sect ; parameters for disk I/O
public @dma,@dbnk,@cnt ; '' '' '' ''
; memory control
public @cbnk ; current bank
extrn ?xmove,?move ; select move bank, and block move
extrn ?bank ; select CPU bank
; clock support
extrn ?time ; signal time operation
; general utility routines
public ?pmsg,?pdec ; print message, print number from 0 to 65535
public ?pderr ; print BIOS disk error message header
maclib modebaud ; define mode bits
; External names for BIOS entry points
public ?boot,?wboot,?const,?conin,?cono,?list,?auxo,?auxi
public ?home,?sldsk,?sttrk,?stsec,?stdma,?read,?write
public ?lists,?sctrn
public ?conos,?auxis,?auxos,?dvtbl,?devin,?drtbl
public ?mltio,?flush,?mov,?tim,?bnksl,?stbnk,?xmov
; BIOS Jump vector.
; All BIOS routines are invoked by calling these
; entry points.
?boot: jmp boot ; initial entry on cold start
?wboot: jmp wboot ; reentry on program exit, warm start
?const: jmp const ; return console input status
?conin: jmp conin ; return console input character
?cono: jmp conout ; send console output character
?list: jmp list ; send list output character
?auxo: jmp auxout ; send auxilliary output character
?auxi: jmp auxin ; return auxilliary input character
?home: jmp home ; set disks to logical home
?sldsk: jmp seldsk ; select disk drive, return disk parameter info
?sttrk: jmp settrk ; set disk track
?stsec: jmp setsec ; set disk sector
?stdma: jmp setdma ; set disk I/O memory address
?read: jmp read ; read physical block(s)
?write: jmp write ; write physical block(s)
?lists: jmp listst ; return list device status
?sctrn: jmp sectrn ; translate logical to physical sector
?conos: jmp conost ; return console output status
?auxis: jmp auxist ; return aux input status
?auxos: jmp auxost ; return aux output status
?dvtbl: jmp devtbl ; return address of device def table
?devin: jmp ?cinit ; change baud rate of device
?drtbl: jmp getdrv ; return address of disk drive table
?mltio: jmp multio ; set multiple record count for disk I/O
?flush: jmp flush ; flush BIOS maintained disk caching
?mov: jmp ?move ; block move memory to memory
?tim: jmp ?time ; Signal Time and Date operation
?bnksl: jmp bnksel ; select bank for code execution and default DMA
?stbnk: jmp setbnk ; select different bank for disk I/O DMA operations.
?xmov: jmp ?xmove ; set source and destination banks for one operation
jmp 0 ; reserved for future expansion
jmp 0 ; reserved for future expansion
jmp 0 ; reserved for future expansion
; BOOT
; Initial entry point for system startup.
dseg ; this part can be banked
boot:
lxi sp,boot$stack
mvi c,15 ; initialize all 16 character devices
c$init$loop:
push b ! call ?cinit ! pop b
dcr c ! jp c$init$loop
call ?init ; perform any additional system initialization
; and print signon message
lxi b,16*256+0 ! lxi h,@dtbl ; init all 16 logical disk drives
d$init$loop:
push b ; save remaining count and abs drive
mov e,m ! inx h ! mov d,m ! inx h ; grab @drv entry
mov a,e ! ora d ! jz d$init$next ; if null, no drive
push h ; save @drv pointer
xchg ; XDPH address in <HL>
dcx h ! dcx h ! mov a,m ! sta @RDRV ; get relative drive code
mov a,c ! sta @ADRV ; get absolute drive code
dcx h ; point to init pointer
mov d,m ! dcx h ! mov e,m ; get init pointer
xchg ! call ipchl ; call init routine
pop h ; recover @drv pointer
d$init$next:
pop b ; recover counter and drive #
inr c ! dcr b ! jnz d$init$loop ; and loop for each drive
jmp boot$1
cseg ; following in resident memory
boot$1:
call set$jumps
call ?ldccp ; fetch CCP for first time
jmp ccp
; WBOOT
; Entry for system restarts.
wboot:
lxi sp,boot$stack
call set$jumps ; initialize page zero
call ?rlccp ; reload CCP
jmp ccp ; then reset jmp vectors and exit to ccp
set$jumps:
if banked
mvi a,1 ! call ?bnksl
endif
mvi a,JMP
sta 0 ! sta 5 ; set up jumps in page zero
lxi h,?wboot ! shld 1 ; BIOS warm start entry
lhld @MXTPA ! shld 6 ; BDOS system call entry
ret
ds 64
boot$stack equ $
; DEVTBL
; Return address of character device table
devtbl:
lxi h,@ctbl ! ret
; GETDRV
; Return address of drive table
getdrv:
lxi h,@dtbl ! ret
; CONOUT
; Console Output. Send character in <C>
; to all selected devices
conout:
lhld @covec ; fetch console output bit vector
jmp out$scan
; AUXOUT
; Auxiliary Output. Send character in <C>
; to all selected devices
auxout:
lhld @aovec ; fetch aux output bit vector
jmp out$scan
; LIST
; List Output. Send character in <C>
; to all selected devices.
list:
lhld @lovec ; fetch list output bit vector
out$scan:
mvi b,0 ; start with device 0
co$next:
dad h ; shift out next bit
jnc not$out$device
push h ; save the vector
push b ; save the count and character
not$out$ready:
call coster ! ora a ! jz not$out$ready
pop b ! push b ; restore and resave the character and device
call ?co ; if device selected, print it
pop b ; recover count and character
pop h ; recover the rest of the vector
not$out$device:
inr b ; next device number
mov a,h ! ora l ; see if any devices left
jnz co$next ; and go find them...
ret
; CONOST
; Console Output Status. Return true if
; all selected console output devices
; are ready.
conost:
lhld @covec ; get console output bit vector
jmp ost$scan
; AUXOST
; Auxiliary Output Status. Return true if
; all selected auxiliary output devices
; are ready.
auxost:
lhld @aovec ; get aux output bit vector
jmp ost$scan
; LISTST
; List Output Status. Return true if
; all selected list output devices
; are ready.
listst:
lhld @lovec ; get list output bit vector
ost$scan:
mvi b,0 ; start with device 0
cos$next:
dad h ; check next bit
push h ; save the vector
push b ; save the count
mvi a,0FFh ; assume device ready
cc coster ; check status for this device
pop b ; recover count
pop h ; recover bit vector
ora a ; see if device ready
rz ; if any not ready, return false
inr b ; drop device number
mov a,h ! ora l ; see if any more selected devices
jnz cos$next
ori 0FFh ; all selected were ready, return true
ret
coster: ; check for output device ready, including optional
; xon/xoff support
mov l,b ! mvi h,0 ; make device code 16 bits
push h ; save it in stack
dad h ! dad h ! dad h ; create offset into device characteristics tbl
lxi d,@ctbl+6 ! dad d ; make address of mode byte
mov a,m ! ani mb$xonxoff
pop h ; recover console number in <HL>
jz ?cost ; not a xon device, go get output status direct
lxi d,xofflist ! dad d ; make pointer to proper xon/xoff flag
call cist1 ; see if this keyboard has character
mov a,m ! cnz ci1 ; get flag or read key if any
cpi ctlq ! jnz not$q ; if its a ctl-Q,
mvi a,0FFh ; set the flag ready
not$q:
cpi ctls ! jnz not$s ; if its a ctl-S,
mvi a,00h ; clear the flag
not$s:
mov m,a ; save the flag
call cost1 ; get the actual output status,
ana m ; and mask with ctl-Q/ctl-S flag
ret ; return this as the status
cist1: ; get input status with <BC> and <HL> saved
push b ! push h
call ?cist
pop h ! pop b
ora a
ret
cost1: ; get output status, saving <BC> & <HL>
push b ! push h
call ?cost
pop h ! pop b
ora a
ret
ci1: ; get input, saving <BC> & <HL>
push b ! push h
call ?ci
pop h ! pop b
ret
; CONST
; Console Input Status. Return true if
; any selected console input device
; has an available character.
const:
lhld @civec ; get console input bit vector
jmp ist$scan
; AUXIST
; Auxiliary Input Status. Return true if
; any selected auxiliary input device
; has an available character.
auxist:
lhld @aivec ; get aux input bit vector
ist$scan:
mvi b,0 ; start with device 0
cis$next:
dad h ; check next bit
mvi a,0 ; assume device not ready
cc cist1 ; check status for this device
ora a ! rnz ; if any ready, return true
inr b ; drop device number
mov a,h ! ora l ; see if any more selected devices
jnz cis$next
xra a ; all selected were not ready, return false
ret
; CONIN
; Console Input. Return character from first
; ready console input device.
conin:
lhld @civec
jmp in$scan
; AUXIN
; Auxiliary Input. Return character from first
; ready auxiliary input device.
auxin:
lhld @aivec
in$scan:
push h ; save bit vector
mvi b,0
ci$next:
dad h ; shift out next bit
mvi a,0 ; insure zero a (nonexistant device not ready).
cc cist1 ; see if the device has a character
ora a
jnz ci$rdy ; this device has a character
inr b ; else, next device
mov a,h ! ora l ; see if any more devices
jnz ci$next ; go look at them
pop h ; recover bit vector
jmp in$scan ; loop til we find a character
ci$rdy:
pop h ; discard extra stack
jmp ?ci
; Utility Subroutines
ipchl: ; vectored CALL point
pchl
?pmsg: ; print message @<HL> up to a null
; saves <BC> & <DE>
push b
push d
pmsg$loop:
mov a,m ! ora a ! jz pmsg$exit
mov c,a ! push h
call ?cono ! pop h
inx h ! jmp pmsg$loop
pmsg$exit:
pop d
pop b
ret
?pdec: ; print binary number 0-65535 from <HL>
lxi b,table10! lxi d,-10000
next:
mvi a,'0'-1
pdecl:
push h! inr a! dad d! jnc stoploop
inx sp! inx sp! jmp pdecl
stoploop:
push d! push b
mov c,a! call ?cono
pop b! pop d
nextdigit:
pop h
ldax b! mov e,a! inx b
ldax b! mov d,a! inx b
mov a,e! ora d! jnz next
ret
table10:
dw -1000,-100,-10,-1,0
?pderr:
lxi h,drive$msg ! call ?pmsg ; error header
lda @adrv ! adi 'A' ! mov c,a ! call ?cono ; drive code
lxi h,track$msg ! call ?pmsg ; track header
lhld @trk ! call ?pdec ; track number
lxi h,sector$msg ! call ?pmsg ; sector header
lhld @sect ! call ?pdec ; sector number
ret
; BNKSEL
; Bank Select. Select CPU bank for further execution.
bnksel:
sta @cbnk ; remember current bank
jmp ?bank ; and go exit through users
; physical bank select routine
xofflist db -1,-1,-1,-1,-1,-1,-1,-1 ; ctl-s clears to zero
db -1,-1,-1,-1,-1,-1,-1,-1
dseg ; following resides in banked memory
; Disk I/O interface routines
; SELDSK
; Select Disk Drive. Drive code in <C>.
; Invoke login procedure for drive
; if this is first select. Return
; address of disk parameter header
; in <HL>
seldsk:
mov a,c ! sta @adrv ; save drive select code
mov l,c ! mvi h,0 ! dad h ; create index from drive code
lxi b,@dtbl ! dad b ; get pointer to dispatch table
mov a,m ! inx h ! mov h,m ! mov l,a ; point at disk descriptor
ora h ! rz ; if no entry in table, no disk
mov a,e ! ani 1 ! jnz not$first$select ; examine login bit
push h ! xchg ; put pointer in stack & <DE>
lxi h,-2 ! dad d ! mov a,m ! sta @RDRV ; get relative drive
lxi h,-6 ! dad d ; find LOGIN addr
mov a,m ! inx h ! mov h,m ! mov l,a ; get address of LOGIN routine
call ipchl ; call LOGIN
pop h ; recover DPH pointer
not$first$select:
ret
; HOME
; Home selected drive. Treated as SETTRK(0).
home:
lxi b,0 ; same as set track zero
; SETTRK
; Set Track. Saves track address from <BC>
; in @TRK for further operations.
settrk:
mov l,c ! mov h,b
shld @trk
ret
; SETSEC
; Set Sector. Saves sector number from <BC>
; in @sect for further operations.
setsec:
mov l,c ! mov h,b
shld @sect
ret
; SETDMA
; Set Disk Memory Address. Saves DMA address
; from <BC> in @DMA and sets @DBNK to @CBNK
; so that further disk operations take place
; in current bank.
setdma:
mov l,c ! mov h,b
shld @dma
lda @cbnk ; default DMA bank is current bank
; fall through to set DMA bank
; SETBNK
; Set Disk Memory Bank. Saves bank number
; in @DBNK for future disk data
; transfers.
setbnk:
sta @dbnk
ret
; SECTRN
; Sector Translate. Indexes skew table in <DE>
; with sector in <BC>. Returns physical sector
; in <HL>. If no skew table (<DE>=0) then
; returns physical=logical.
sectrn:
mov l,c ! mov h,b
mov a,d ! ora e ! rz
xchg ! dad b ! mov l,m ! mvi h,0
ret
; READ
; Read physical record from currently selected drive.
; Finds address of proper read routine from
; extended disk parameter header (XDPH).
read:
lhld @adrv ! mvi h,0 ! dad h ; get drive code and double it
lxi d,@dtbl ! dad d ; make address of table entry
mov a,m ! inx h ! mov h,m ! mov l,a ; fetch table entry
push h ; save address of table
lxi d,-8 ! dad d ; point to read routine address
jmp rw$common ; use common code
; WRITE
; Write physical sector from currently selected drive.
; Finds address of proper write routine from
; extended disk parameter header (XDPH).
write:
lhld @adrv ! mvi h,0 ! dad h ; get drive code and double it
lxi d,@dtbl ! dad d ; make address of table entry
mov a,m ! inx h ! mov h,m ! mov l,a ; fetch table entry
push h ; save address of table
lxi d,-10 ! dad d ; point to write routine address
rw$common:
mov a,m ! inx h ! mov h,m ! mov l,a ; get address of routine
pop d ; recover address of table
dcx d ! dcx d ; point to relative drive
ldax d ! sta @rdrv ; get relative drive code and post it
inx d ! inx d ; point to DPH again
pchl ; leap to driver
; MULTIO
; Set multiple sector count. Saves passed count in
; @CNT
multio:
sta @cnt ! ret
; FLUSH
; BIOS deblocking buffer flush. Not implemented.
flush:
xra a ! ret ; return with no error
; error message components
drive$msg db cr,lf,bell,'BIOS Error on ',0
track$msg db ': T-',0
sector$msg db ', S-',0
; disk communication data items
@adrv ds 1 ; currently selected disk drive
@rdrv ds 1 ; controller relative disk drive
@trk ds 2 ; current track number
@sect ds 2 ; current sector number
@dma ds 2 ; current DMA address
@cnt db 0 ; record count for multisector transfer
@dbnk db 0 ; bank for DMA operations
cseg ; common memory
@cbnk db 0 ; bank for processor operations
end

122
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/boot.asm Normal file
View File

@@ -0,0 +1,122 @@
title 'Boot loader module for CP/M 3.0'
true equ -1
false equ not true
banked equ true
public ?init,?ldccp,?rlccp,?time
extrn ?pmsg,?conin
extrn @civec,@covec,@aivec,@aovec,@lovec
extrn @cbnk,?bnksl
maclib ports
maclib z80
bdos equ 5
if banked
tpa$bank equ 1
else
tpa$bank equ 0
endif
dseg ; init done from banked memory
?init:
lxi h,08000h ! shld @civec ! shld @covec ; assign console to CRT:
lxi h,04000h ! shld @lovec ; assign printer to LPT:
lxi h,02000h ! shld @aivec ! shld @aovec ; assign AUX to CRT1:
lxi h,init$table ! call out$blocks ; set up misc hardware
lxi h,signon$msg ! call ?pmsg ; print signon message
ret
out$blocks:
mov a,m ! ora a ! rz ! mov b,a
inx h ! mov c,m ! inx h
outir
jmp out$blocks
cseg ; boot loading most be done from resident memory
; This version of the boot loader loads the CCP from a file
; called CCP.COM on the system drive (A:).
?ldccp:
; First time, load the A:CCP.COM file into TPA
xra a ! sta ccp$fcb+15 ; zero extent
lxi h,0 ! shld fcb$nr ; start at beginning of file
lxi d,ccp$fcb ! call open ; open file containing CCP
inr a ! jz no$CCP ; error if no file...
lxi d,0100h ! call setdma ; start of TPA
lxi d,128 ! call setmulti ; allow up to 16k bytes
lxi d,ccp$fcb ! call read ; load the thing
; now,
; copy CCP to bank 0 for reloading
lxi h,0100h ! lxi b,0C80h ; clone 3K, just in case
lda @cbnk ! push psw ; save current bank
ld$1:
mvi a,tpa$bank ! call ?bnksl ; select TPA
mov a,m ! push psw ; get a byte
mvi a,2 ! call ?bnksl ; select extra bank
pop psw ! mov m,a ; save the byte
inx h ! dcx b ; bump pointer, drop count
mov a,b ! ora c ; test for done
jnz ld$1
pop psw ! call ?bnksl ; restore original bank
ret
no$CCP: ; here if we couldn't find the file
lxi h,ccp$msg ! call ?pmsg ; report this...
call ?conin ; get a response
jmp ?ldccp ; and try again
?rlccp:
lxi h,0100h ! lxi b,0C00h ; clone 3K
rl$1:
mvi a,2 ! call ?bnksl ; select extra bank
mov a,m ! push psw ; get a byte
mvi a,tpa$bank ! call ?bnksl ; select TPA
pop psw ! mov m,a ; save the byte
inx h ! dcx b ; bump pointer, drop count
mov a,b ! ora c ; test for done
jnz rl$1
ret
; No external clock.
?time:
ret
; CP/M BDOS Function Interfaces
open:
mvi c,15 ! jmp bdos ; open file control block
setdma:
mvi c,26 ! jmp bdos ; set data transfer address
setmulti:
mvi c,44 ! jmp bdos ; set record count
read:
mvi c,20 ! jmp bdos ; read records
signon$msg db 13,10,13,10,'CP/M Version 3.0, sample BIOS',13,10,0
ccp$msg db 13,10,'BIOS Err on A: No CCP.COM file',0
ccp$fcb db 1,'CCP ','COM',0,0,0,0
ds 16
fcb$nr db 0,0,0
init$table db 3,p$zpio$3a,0CFh,0FFh,07h ; set up config port
db 3,p$zpio$3b,0CFh,000h,07h ; set up bank port
db 1,p$bank$select,0 ; select bank 0
db 0 ; end of init$table
end

28
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/callvers.asm Normal file
View File

@@ -0,0 +1,28 @@
; CALLVERS program
bdos equ 5 ; entry point for BDOS
prtstr equ 9 ; print string function
vers equ 12 ; get version function
cr equ 0dh ; carriage return
lf equ 0ah ; line feed
org 100h
mvi d,5 ; Perform 5 times
loop: push d ; save counter
mvi c,prtstr
lxi d,call$msg ; print call message
call bdos
mvi c,vers
call bdos ; try to get version #
; CALLVERS will intercept
mov a,l
sta curvers
pop d
dcr d ; decrement counter
jnz loop
mvi c,0
jmp bdos
call$msg:
db cr,lf,'**** CALLVERS **** $'
curvers db 0
end

2841
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/ccp3.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/SOURCE/ccp3org.asm Normal file
View File

File diff suppressed because it is too large Load Diff

8
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/ccpdate.asm Normal file
View File

@@ -0,0 +1,8 @@
org 368h
maclib makedate
db ' '
@BDATE ;[JCE] Copyright & build date now in MAKEDATE.LIB
db ' '
@SCOPY

175
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/chario.asm Normal file
View File

@@ -0,0 +1,175 @@
title 'Character I/O handler for z80 chip based system'
; Character I/O for the Modular CP/M 3 BIOS
; limitations:
; baud rates 19200,7200,3600,1800 and 134
; are approximations.
; 9600 is the maximum baud rate that is likely
; to work.
; baud rates 50, 75, and 110 are not supported
public ?cinit,?ci,?co,?cist,?cost
public @ctbl
maclib Z80 ; define Z80 op codes
maclib ports ; define port addresses
maclib modebaud ; define mode bits and baud equates
max$devices equ 6
cseg
?cinit:
mov a,c ! cpi max$devices ! jz cent$init ; init parallel printer
rnc ; invalid device
mov l,c ! mvi h,0 ; make 16 bits from device number
push h ; save device in stack
dad h ! dad h ! dad h ; *8
lxi d,@ctbl+7 ! dad d ! mov l,m ; get baud rate
mov a,l ! cpi baud$600 ; see if baud > 300
mvi a,44h ! jnc hi$speed ; if >= 600, use *16 mode
mvi a,0C4h ; else, use *64 mode
hi$speed:
sta sio$reg$4
mvi h,0 ! lxi d,speed$table ! dad d ; point to counter entry
mov a,m ! sta speed ; get and save ctc count
pop h ; recover
lxi d,data$ports ! dad d ; point at SIO port address
mov a,m ! inr a ! sta sio$port ; get and save port
lxi d,baud$ports-data$ports ! dad d ; offset to baud rate port
mov a,m ! sta ctc$port ; get and save
lxi h,serial$init$tbl
jmp stream$out
cent$init:
lxi h,pio$init$tbl
stream$out:
mov a,m ! ora a ! rz
mov b,a ! inx h ! mov c,m ! inx h
outir
jmp stream$out
?ci: ; character input
mov a,b ! cpi 6 ! jnc null$input ; can't read from centronics
ci1:
call ?cist ! jz ci1 ; wait for character ready
dcr c ! inp a ; get data
ani 7Fh ; mask parity
ret
null$input:
mvi a,1Ah ; return a ctl-Z for no device
ret
?cist: ; character input status
mov a,b ! cpi 6 ! jnc null$status ; can't read from centronics
mov l,b ! mvi h,0 ; make device number 16 bits
lxi d,data$ports ! dad d ; make pointer to port address
mov c,m ! inr c ; get SIO status port
inp a ; read from status port
ani 1 ; isolate RxRdy
rz ; return with zero
ori 0FFh
ret
null$status:
xra a ! ret
?co: ; character output
mov a,b ! cpi 6 ! jz centronics$out
jnc null$output
mov a,c ! push psw ; save character from <C>
push b ; save device number
co$spin:
call ?cost ! jz co$spin ; wait for TxEmpty
pop h ! mov l,h ! mvi h,0 ; get device number in <HL>
lxi d,data$ports ! dad d ; make address of port address
mov c,m ; get port address
pop psw ! outp a ; send data
null$output:
ret
centronics$out:
in p$centstat ! ani 20h ! jnz centronics$out
mov a,c ! out p$centdata ; give printer data
in p$centstat ! ori 1 ! out p$centstat ; set strobe
ani 7Eh ! out p$centstat ; clear strobe
ret
?cost: ; character output status
mov a,b ! cpi 6 ! jz cent$stat
jnc null$status
mov l,b ! mvi h,0
lxi d,data$ports ! dad d
mov c,m ! inr c
inp a ; get input status
ani 4 ! rz ; test transmitter empty
ori 0FFh ! ret ; return true if ready
cent$stat:
in p$centstat ! cma
ani 20h ! rz
ori 0FFh ! ret
baud$ports: ; CTC ports by physical device number
db p$baud$con1,p$baud$lpt1,p$baud$con2,p$baud$con34
db p$baud$con34,p$baud$lpt2
data$ports: ; serial base ports by physical device number
db p$crt$data,p$lpt$data,p$con2data,p$con3data
db p$con4data,p$lpt2data
@ctbl db 'CRT ' ; device 0, CRT port 0
db mb$in$out+mb$serial+mb$softbaud
db baud$9600
db 'LPT ' ; device 1, LPT port 0
db mb$in$out+mb$serial+mb$softbaud+mb$xonxoff
db baud$9600
db 'CRT1 ' ; device 2, CRT port 1
db mb$in$out+mb$serial+mb$softbaud
db baud$9600
db 'CRT2 ' ; device 3, CRT port 2
db mb$in$out+mb$serial+mb$softbaud
db baud$9600
db 'CRT3 ' ; device 4, CRT port 3
db mb$in$out+mb$serial+mb$softbaud
db baud$9600
db 'VAX ' ; device 5, LPT port 1 used for VAX interface
db mb$in$out+mb$serial+mb$softbaud
db baud$9600
db 'CEN ' ; device 6, Centronics parallel printer
db mb$output
db baud$none
db 0 ; table terminator
speed$table db 0,255,255,255,233,208,104,208,104,69,52,35,26,17,13,7
serial$init$tbl
db 2 ; two bytes to CTC
ctc$port ds 1 ; port address of CTC
db 47h ; CTC mode byte
speed ds 1 ; baud multiplier
db 7 ; 7 bytes to SIO
sio$port ds 1 ; port address of SIO
db 18h,3,0E1h,4
sio$reg$4 ds 1
db 5,0EAh
db 0 ; terminator
pio$init$tbl db 2,p$zpio$2b,0Fh,07h
db 3,p$zpio$2a,0CFh,0F8h,07h
db 0
end

16
CPM OPERATING SYSTEMS/CPM 3.X/CPM 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',
date$flag$offset lit '0ch', /* [JCE] UK dates? */
page$len$offset lit '1ch',
nopage$mode$offset lit '2Ch',
sectorlen lit '128';

908
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/conbdos.asm Normal file
View File

@@ -0,0 +1,908 @@
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 ;[JCE] DRI Patch 13
ANI 10h
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 ;[JCE] DRI Patch 13
jnz patch$064b
mov a,m ;recall char
cpi ctlc ;set flags for reboot test
patch$064b: 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

8
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/copyrt.lit Normal file
View File

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

837
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/copysys.asm Normal file
View File

@@ -0,0 +1,837 @@
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
maclib makedate
@LCOPY
@BDATE
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


711
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/cpmbdos1.asm Normal file
View File

@@ -0,0 +1,711 @@
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
maclib makedate
if BANKED
@LCOPY
@BDATE
else
@SCOPY
@BDATE
; 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
call patch$1e25 ;[JCE] DRI patch 13
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

712
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/cpmbdos2.asm Normal file
View File

@@ -0,0 +1,712 @@
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 on
;
; 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
maclib makedate
if BANKED
@LCOPY
@BDATE
ds 5
else
@SCOPY
@BDATE
; 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
call patch$1e25 ;[JCE] DRI Patch 13
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

1572
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/cpmldr.asm Normal file
View File

File diff suppressed because it is too large Load Diff

201
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/crdef.plm Normal file
View File

@@ -0,0 +1,201 @@
$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;

672
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/date.plm Normal file
View File

@@ -0,0 +1,672 @@
$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.
Date: 17 May 1998
Programmer: John Elliott
Changes:
Year 2000 fixes (flagged [JCE] below)
Patch 17 implemented
Date: 18 Sep 1998
Programmer: John Elliott
Changes:
Added "YMD" date format
*/
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 date$flag$offset literally '0ch'; /* [JCE] Date format */
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;
get$date$flag: procedure byte; /* [JCE] Read the date format flag */
declare scbpb structure
(offset byte,
set byte,
value address);
scbpb.offset = date$flag$offset;
scbpb.set = 0;
return (mon2(49,.scbpb) and 3); /* [JCE 18-9-1998] extra date formats */
end get$date$flag; /* [JCE] ends */
/*****************************************************
Time & Date ASCII Conversion Code
*****************************************************/
declare BUFFER$ADR structure (
MAX$CHARS byte,
NUMB$OF$CHARS byte,
CONSOLE$BUFFER(23) byte) /* [JCE] size 21 -> 23 throughout */
initial(23,0,0,0,0,0,0,0,0,0,0,0, /* because of printing */
0,0,0,0,0,0,0,0,0,0,0,0,0); /* four-figure year nos. */
declare tod$adr address;
declare tod based tod$adr structure (
opcode byte,
date address,
hrs byte,
min byte,
sec byte,
ASCII (23) 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;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
emit$dash: /* [JCE 18-9-1998] for YMD format dates */
procedure(b);
declare b byte;
call emit$bin$pair(b);
call emitchar('-');
end emit$dash;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
declare chr byte;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
gnc:
procedure;
/* get next command byte */
if chr = 0 then return;
if index = 22 then /* [JCE] 20 -> 22 */
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 */
if get$date$flag = 2 then /* [JCE 18-9-1998] YMD format */
do;
year = scan$numeric(0,99);
month = scan$delimiter('-',1,12) - 1;
if (leap$flag := month = 1) then i = 29;
else i = month$size(month);
day = scan$delimiter('-',1,i);
end;
else
if get$date$flag = 1 then /* [JCE] UK format */
do;
day = scan$numeric(1,31);
month = scan$delimiter('/',1,12) - 1;
if (leap$flag := month = 1) then i = 29;
else i = month$size(month);
if day > i then go to error;
/* [JCE] year2000: Was year = scan$delimiter('/',base$year,99); */
year = scan$delimiter('/',0,99); /* [JCE] */
end;
else /* US format */
do;
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);
/* [JCE] year2000: Was year = scan$delimiter('/',base$year,99); */
year = scan$delimiter('/',0,99); /* [JCE] */
end;
if year < base$year /* [JCE] */
then year = year + 100; /* [JCE] Dates past 2000 */
/* 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;
declare century byte; /* [JCE] century */
century = 19; /* [JCE] start in the 1900s */
call emitn(.day$list(shl(week$day,2)));
call emitchar(' ');
century = century + (year / 100); /* [JCE] Y2000 fix for output */
year = year mod 100; /* [JCE] */
if get$date$flag = 0 then /* [JCE] US or UK format for dates? */
do;
call emit$slant(month);
call emit$slant(day);
call emit$bin$pair(century);
call emit$bin$pair(year);
end;
else
if get$date$flag = 1 then /* [JCE 18-9-1998] UK format */
do;
call emit$slant(day);
call emit$slant(month);
call emit$bin$pair(century);
call emit$bin$pair(year);
end;
else /* [JCE 18-9-1998] YMD format */
do;
call emit$bin$pair(century);
call emit$dash(year);
call emit$dash(month);
call emit$bin$pair(day);
end;
/* [JCE] end of Y2000 fix for output */
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 (23) byte ); /* [JCE] 21 -> 23 */
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 22; /* [JCE] 20 -> 22 */
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';
call mon1(105,.(0,0,0,0)); /* [JCE] this implements Patch 17 */
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 (','$')); /* [JCE] UK-format */
if get$date$flag =2 then /* [JCE] */
call print$buffer(.('YY-MM-DD): ','$')); /* [JCE 18-9-1998] YMD format */
else if get$date$flag = 1 then /* [JCE 18-9-1998] */
call print$buffer(.('DD/MM/YY): ','$')); /* [JCE] UK format */
else call print$buffer(.('MM/DD/YY): ','$')); /* [JCE] US format */
call move(23,.(000000000000000000000),.buffer$adr.console$buffer);
call read$console$buffer(.buffer$adr);
if buffer$adr.numb$of$chars > 0
then do;
call move(23,.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(23,.(000000000000000000000),.buffer$adr.console$buffer);
call read$console$buffer(.buffer$adr);
if buffer$adr.numb$of$chars > 0
then do;
call move(23,.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 (23,.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;

169
CPM OPERATING SYSTEMS/CPM 3.X/CPM 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


1333
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/device.plm Normal file
View File

File diff suppressed because it is too large Load Diff

546
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/dirlbl.asm Normal file
View File

@@ -0,0 +1,546 @@
;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
;
;[JCE] CP/M 3 Patch 10
mov e,m
inx h
mov d,m
xchg
;[JCE] end of patch
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
ds 32 ;[JCE] Add extra stack as per CP/M Patch 10
loc$stack:
end


677
CPM OPERATING SYSTEMS/CPM 3.X/CPM 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;

13
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/dpb.lit Normal file
View File

@@ -0,0 +1,13 @@
/* 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';

45
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/dpb80.plm Normal file
View File

@@ -0,0 +1,45 @@
$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;

BIN
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/drlink.com Normal file
View File

Binary file not shown.

9
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/drvtbl.asm Normal file
View File

@@ -0,0 +1,9 @@
public @dtbl
extrn fdsd0,fdsd1
cseg
@dtbl dw fdsd0,fdsd1
dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0 ; drives C-P non-existant
end

488
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/dump.asm Normal file
View File

@@ -0,0 +1,488 @@
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
maclib makedate ;[JCE] one file for all dates/copyrights
@LCOPY
@BDATE ;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:


46
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/echovers.asm Normal file
View File

@@ -0,0 +1,46 @@
; ECHOVERS RSX
pstring equ 9 ; string print function
cr equ 0dh
lf equ 0ah
;
; RSX PREFIX STRUCTURE
;
db 0,0,0,0,0,0 ; room for serial number
jmp ftest ; begin of program
next db 0c3H ; jump
dw 0 ; next module in line
prev: dw 0 ; previous module
remov: db 0ffh ; remove flag set
nonbnk: db 0
db 'ECHOVERS'
space: ds 3
ftest: ; is this function 12?
mov a,c
cpi 12
jz begin ; yes - intercept
jmp next ; some other function
begin:
lxi h,0
dad sp ;save stack
shld ret$stack
lxi sp,loc$stack
mvi c,pstring
lxi d,test$msg ; print message
call next ; call BDOS
lhld ret$stack ; restore user stack
sphl
lxi h,0031h ; return version number = 0031h
ret
test$msg:
db cr,lf,'**** ECHOVERS **** $'
ret$stack:
dw 0
ds 32 ; 16 level stack
loc$stack:
end

2647
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/ed.plm Normal file
View File

File diff suppressed because it is too large Load Diff

824
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/erase.plm Normal file
View File

@@ -0,0 +1,824 @@
$ 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;

21
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/fcb.lit Normal file
View File

@@ -0,0 +1,21 @@
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 */

384
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/fd1797sd.asm Normal file
View File

@@ -0,0 +1,384 @@
title 'wd1797 w/ Z80 DMA Single density diskette handler'
; CP/M-80 Version 3 -- Modular BIOS
; Disk I/O Module for wd1797 based diskette systems
; Initial version 0.01,
; Single density floppy only. - jrp, 4 Aug 82
dseg
; Disk drive dispatching tables for linked BIOS
public fdsd0,fdsd1
; Variables containing parameters passed by BDOS
extrn @adrv,@rdrv
extrn @dma,@trk,@sect
extrn @dbnk
; System Control Block variables
extrn @ermde ; BDOS error mode
; Utility routines in standard BIOS
extrn ?wboot ; warm boot vector
extrn ?pmsg ; print message @<HL> up to 00, saves <BC> & <DE>
extrn ?pdec ; print binary number in <A> from 0 to 99.
extrn ?pderr ; print BIOS disk error header
extrn ?conin,?cono ; con in and out
extrn ?const ; get console status
; Port Address Equates
maclib ports
; CP/M 3 Disk definition macros
maclib cpm3
; Z80 macro library instruction definitions
maclib z80
; common control characters
cr equ 13
lf equ 10
bell equ 7
; Extended Disk Parameter Headers (XPDHs)
dw fd$write
dw fd$read
dw fd$login
dw fd$init0
db 0,0 ; relative drive zero
fdsd0 dph trans,dpbsd,16,31
dw fd$write
dw fd$read
dw fd$login
dw fd$init1
db 1,0 ; relative drive one
fdsd1 dph trans,dpbsd,16,31
cseg ; DPB must be resident
dpbsd dpb 128,26,77,1024,64,2
dseg ; rest is banked
trans skew 26,6,1
; Disk I/O routines for standardized BIOS interface
; Initialization entry point.
; called for first time initialization.
fd$init0:
lxi h,init$table
fd$init$next:
mov a,m ! ora a ! rz
mov b,a ! inx h ! mov c,m ! inx h
outir
jmp fd$init$next
fd$init1: ; all initialization done by drive 0
ret
init$table db 4,p$zpio$1A
db 11001111b, 11000010b, 00010111b,11111111b
db 4,p$zpio$1B
db 11001111b, 11011101b, 00010111b,11111111b
db 0
fd$login:
; This entry is called when a logical drive is about to
; be logged into for the purpose of density determination.
; It may adjust the parameters contained in the disk
; parameter header pointed at by <DE>
ret ; we have nothing to do in
; simple single density only environment.
; disk READ and WRITE entry points.
; these entries are called with the following arguments:
; relative drive number in @rdrv (8 bits)
; absolute drive number in @adrv (8 bits)
; disk transfer address in @dma (16 bits)
; disk transfer bank in @dbnk (8 bits)
; disk track address in @trk (16 bits)
; disk sector address in @sect (16 bits)
; pointer to XDPH in <DE>
; they transfer the appropriate data, perform retries
; if necessary, then return an error code in <A>
fd$read:
lxi h,read$msg ; point at " Read "
mvi a,88h ! mvi b,01h ; 1797 read + Z80DMA direction
jmp rw$common
fd$write:
lxi h,write$msg ; point at " Write "
mvi a,0A8h ! mvi b,05h ; 1797 write + Z80DMA direction
; jmp wr$common
rw$common: ; seek to correct track (if necessary),
; initialize DMA controller,
; and issue 1797 command.
shld operation$name ; save message for errors
sta disk$command ; save 1797 command
mov a,b ! sta zdma$direction ; save Z80DMA direction code
lhld @dma ! shld zdma$dma ; get and save DMA address
lda @rdrv ! mov l,a ! mvi h,0 ; get controller-relative disk drive
lxi d,select$table ! dad d ; point to select mask for drive
mov a,m ! sta select$mask ; get select mask and save it
out p$select ; select drive
more$retries:
mvi c,10 ; allow 10 retries
retry$operation:
push b ; save retry counter
lda select$mask ! lxi h,old$select ! cmp m
mov m,a
jnz new$track ; if not same drive as last, seek
lda @trk ! lxi h,old$track ! cmp m
mov m,a
jnz new$track ; if not same track, then seek
in p$fdmisc ! ani 2 ! jnz same$track ; head still loaded, we are OK
new$track: ; or drive or unloaded head means we should . . .
call check$seek ; . . read address and seek if wrong track
lxi b,16667 ; 100 ms / (24 t states*250 ns)
spin$loop: ; wait for head/seek settling
dcx b
mov a,b ! ora c
jnz spin$loop
same$track:
lda @trk ! out p$fdtrack ; give 1797 track
lda @sect ! out p$fdsector ; and sector
lxi h,dma$block ; point to dma command block
lxi b,dmab$length*256 + p$zdma ; command block length and port address
outir ; send commands to Z80 DMA
in p$bankselect ; get old value of bank select port
ani 3Fh ! mov b,a ; mask off DMA bank and save
lda @dbnk ! rrc ! rrc ; get DMA bank to 2 hi-order bits
ani 0C0h ! ora b ; merge with other bank stuff
out p$bankselect ; and select the correct DMA bank
lda disk$command ; get 1797 command
call exec$command ; start it then wait for IREQ and read status
sta disk$status ; save status for error messages
pop b ; recover retry counter
ora a ! rz ; check status and return to BDOS if no error
ani 0001$0000b ; see if record not found error
cnz check$seek ; if a record not found, we might need to seek
dcr c ! jnz retry$operation
; suppress error message if BDOS is returning errors to application...
lda @ermde ! cpi 0FFh ! jz hard$error
; Had permanent error, print message like:
; BIOS Err on d: T-nn, S-mm, <operation> <type>, Retry ?
call ?pderr ; print message header
lhld operation$name ! call ?pmsg ; last function
; then, messages for all indicated error bits
lda disk$status ; get status byte from last error
lxi h,error$table ; point at table of message addresses
errm1:
mov e,m ! inx h ! mov d,m ! inx h ; get next message address
add a ! push psw ; shift left and push residual bits with status
xchg ! cc ?pmsg ! xchg ; print message, saving table pointer
pop psw ! jnz errm1 ; if any more bits left, continue
lxi h,error$msg ! call ?pmsg ; print "<BEL>, Retry (Y/N) ? "
call u$conin$echo ; get operator response
cpi 'Y' ! jz more$retries ; Yes, then retry 10 more times
hard$error: ; otherwise,
mvi a,1 ! ret ; return hard error to BDOS
cancel: ; here to abort job
jmp ?wboot ; leap directly to warmstart vector
; subroutine to seek if on wrong track
; called both to set up new track or drive
check$seek:
push b ; save error counter
call read$id ; try to read ID, put track in <B>
jz id$ok ; if OK, we're OK
call step$out ; else step towards Trk 0
call read$id ; and try again
jz id$ok ; if OK, we're OK
call restore ; else, restore the drive
mvi b,0 ; and make like we are at track 0
id$ok:
mov a,b ! out p$fdtrack ; send current track to track port
lda @trk ! cmp b ! pop b ! rz ; if its desired track, we are done
out p$fddata ; else, desired track to data port
mvi a,00011010b ; seek w/ 10 ms. steps
jmp exec$command
step$out:
mvi a,01101010b ; step out once at 10 ms.
jmp exec$command
restore:
mvi a,00001011b ; restore at 15 ms
; jmp exec$command
exec$command: ; issue 1797 command, and wait for IREQ
; return status
out p$fdcmnd ; send 1797 command
wait$IREQ: ; spin til IREQ
in p$fdint ! ani 40h ! jz wait$IREQ
in p$fdstat ; get 1797 status and clear IREQ
ret
read$id:
lxi h,read$id$block ; set up DMA controller
lxi b,length$id$dmab*256 + p$zdma ; for READ ADDRESS operation
outir
mvi a,11000100b ; issue 1797 read address command
call exec$command ; wait for IREQ and read status
ani 10011101b ; mask status
lxi h,id$buffer ! mov b,m ; get actual track number in <B>
ret ; and return with Z flag true for OK
u$conin$echo: ; get console input, echo it, and shift to upper case
call ?const ! ora a ! jz u$c1 ; see if any char already struck
call ?conin ! jmp u$conin$echo ; yes, eat it and try again
u$c1:
call ?conin ! push psw
mov c,a ! call ?cono
pop psw ! cpi 'a' ! rc
sui 'a'-'A' ; make upper case
ret
disk$command ds 1 ; current wd1797 command
select$mask ds 1 ; current drive select code
old$select ds 1 ; last drive selected
old$track ds 1 ; last track seeked to
disk$status ds 1 ; last error status code for messages
select$table db 0001$0000b,0010$0000b ; for now use drives C and D
; error message components
read$msg db ', Read',0
write$msg db ', Write',0
operation$name dw read$msg
; table of pointers to error message strings
; first entry is for bit 7 of 1797 status byte
error$table dw b7$msg
dw b6$msg
dw b5$msg
dw b4$msg
dw b3$msg
dw b2$msg
dw b1$msg
dw b0$msg
b7$msg db ' Not ready,',0
b6$msg db ' Protect,',0
b5$msg db ' Fault,',0
b4$msg db ' Record not found,',0
b3$msg db ' CRC,',0
b2$msg db ' Lost data,',0
b1$msg db ' DREQ,',0
b0$msg db ' Busy,',0
error$msg db ' Retry (Y/N) ? ',0
; command string for Z80DMA device for normal operation
dma$block db 0C3h ; reset DMA channel
db 14h ; channel A is incrementing memory
db 28h ; channel B is fixed port address
db 8Ah ; RDY is high, CE/ only, stop on EOB
db 79h ; program all of ch. A, xfer B->A (temp)
zdma$dma ds 2 ; starting DMA address
dw 128-1 ; 128 byte sectors in SD
db 85h ; xfer byte at a time, ch B is 8 bit address
db p$fddata ; ch B port address (1797 data port)
db 0CFh ; load B as source register
db 05h ; xfer A->B
db 0CFh ; load A as source register
zdma$direction ds 1 ; either A->B or B->A
db 0CFh ; load final source register
db 87h ; enable DMA channel
dmab$length equ $-dma$block
read$id$block db 0C3h ; reset DMA channel
db 14h ; channel A is incrementing memory
db 28h ; channel B is fixed port address
db 8Ah ; RDY is high, CE/ only, stop on EOB
db 7Dh ; program all of ch. A, xfer A->B (temp)
dw id$buffer ; starting DMA address
dw 6-1 ; Read ID always xfers 6 bytes
db 85h ; byte xfer, ch B is 8 bit address
db p$fddata ; ch B port address (1797 data port)
db 0CFh ; load dest (currently source) register
db 01h ; xfer B->A
db 0CFh ; load source register
db 87h ; enable DMA channel
length$id$dmab equ $-read$id$block
cseg ; easier to put ID buffer in common
id$buffer ds 6 ; buffer to hold ID field
; track
; side
; sector
; length
; CRC 1
; CRC 2
end

15
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/finfo.lit Normal file
View File

@@ -0,0 +1,15 @@
/* 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)';

5
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/format.lit Normal file
View File

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

1999
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/gencom.plm Normal file
View File

File diff suppressed because it is too large Load Diff

1478
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/gencpm.plm Normal file
View File

File diff suppressed because it is too large Load Diff

939
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/get.plm Normal file
View File

@@ -0,0 +1,939 @@
$ 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;

338
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/getdef.plm Normal file
View File

@@ -0,0 +1,338 @@
$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/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


873
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/getrsx.asm Normal file
View File

@@ -0,0 +1,873 @@
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
;
maclib getrsx ;[JCE] The Get/Submit equate
maclib makedate ;[JCE] Build date
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 ' '
@BDATE
db ' '
@SCOPY
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


1
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/getrsx.lib Normal file
View File

@@ -0,0 +1 @@
submit equ true ;true if submit RSX

2043
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/help.dat Normal file
View File

File diff suppressed because it is too large Load Diff

1091
CPM OPERATING SYSTEMS/CPM 3.X/CPM 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/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'
maclib makedate ;[JCE] Build date
@LCOPY
@BDATE ; 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

118
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/hexcom.c Normal file
View File

@@ -0,0 +1,118 @@
/*
* load - convert a hex file to a com file
*
* Expanded to HEXCOM by John Elliott, 25-5-1998
*
* Compiles with gcc or Pacific C
*
*/
#include <stdio.h>
#include <stdlib.h>
unsigned char checksum;
int L;
FILE *fpout;
unsigned char getbyte () {
register int c;
unsigned char x;
c = getchar ();
if ('0' <= c && c <= '9')
x = c - '0';
else
if ('A' <= c && c <= 'F')
x = c - 'A' + 10;
else
goto funny;
x <<= 4;
c = getchar ();
if ('0' <= c && c <= '9')
x |= c - '0';
else
if ('A' <= c && c <= 'F')
x |= c - 'A' + 10;
else {
funny:
fprintf (stderr, "Funny hex letter %c\n", c);
exit (2);
}
checksum += x;
return x;
}
main (int argc, char **argv) {
register unsigned i, n;
char c, buf[64];
unsigned type;
unsigned int al, ah, addr = 0, naddr;
L = 0;
if (argc < 2) fpout = stdout;
else fpout = fopen(argv[1],"wb");
do {
do {
c = getchar ();
if (c == EOF) {
fprintf (stderr, "Premature EOF colon missing\n");
exit (1);
}
} while (c != ':');
++L;
checksum = 0;
n = getbyte (); /* bytes / line */
ah = getbyte ();
al = getbyte ();
switch (type = getbyte ())
{
case 0:
if (!n) /* MAC uses a line with no bytes as EOF */
{
type = 1;
break;
}
naddr = (ah << 8) | al;
if (!addr) addr = naddr;
else while (addr < naddr)
{
fwrite("", 1, 1, fpout);
++addr;
}
if (addr > naddr)
{
fprintf(stderr,"Line %d: Records out of sequence at %x > %x\n", L, naddr, addr);
exit(1);
}
for (i = 0; i < n; i++)
buf[i] = getbyte ();
fwrite (buf, 1, n, fpout);
break;
case 1:
break;
default:
fprintf (stderr, "Line %d: Funny record type %d\n", L, type);
exit (1);
}
(void) getbyte ();
if (checksum != 0)
{
fprintf (stderr, "Line %d: Checksum error", L);
exit (2);
}
addr += n;
} while (type != 1);
exit(0);
}

134
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/hexpat.c Normal file
View File

@@ -0,0 +1,134 @@
/*
* load - convert a hex file to a com file
*
* Converted to HEXPAT by John Elliott, 25-5-1998
*
* Compiles with gcc or Pacific C
*
*/
#include <stdio.h>
#include <stdlib.h>
unsigned char checksum;
int L;
FILE *fpout, *fpcom;
unsigned char getbyte () {
register int c;
unsigned char x;
c = getchar ();
if ('0' <= c && c <= '9')
x = c - '0';
else
if ('A' <= c && c <= 'F')
x = c - 'A' + 10;
else
goto funny;
x <<= 4;
c = getchar ();
if ('0' <= c && c <= '9')
x |= c - '0';
else
if ('A' <= c && c <= 'F')
x |= c - 'A' + 10;
else {
funny:
fprintf (stderr, "Funny hex letter %c\n", c);
exit (2);
}
checksum += x;
return x;
}
main (int argc, char **argv) {
register unsigned i, n;
char c, buf[64];
int j;
unsigned type;
unsigned int al, ah, addr = 0x100, naddr;
L = 0;
if (argc < 3) fpout = stdout;
else fpout = fopen(argv[2],"wb");
fpcom = fopen(argv[1], "rb");
do {
do {
c = getchar ();
if (c == EOF) {
fprintf (stderr, "Premature EOF colon missing\n");
exit (1);
}
} while (c != ':');
++L;
checksum = 0;
n = getbyte (); /* bytes / line */
ah = getbyte ();
al = getbyte ();
switch (type = getbyte ())
{
case 0:
if (!n) /* MAC uses a line with no bytes as EOF */
{
type = 1;
break;
}
naddr = (ah << 8) | al;
while (addr < naddr)
{
j = fgetc(fpcom);
if (j == EOF) fputc(0, fpout);
else fputc(j, fpout);
++addr;
}
if (addr > naddr)
{
fprintf(stderr,"Line %d: Records out of sequence at %x > %x\n", L, naddr, addr);
exit(1);
}
for (i = 0; i < n; i++)
{
/* Step through the COM file */
(void)fgetc(fpcom);
buf[i] = getbyte ();
}
fwrite (buf, 1, n, fpout);
break;
case 1:
break;
default:
fprintf (stderr, "Line %d: Funny record type %d\n", L, type);
exit (1);
}
(void) getbyte ();
if (checksum != 0)
{
fprintf (stderr, "Line %d: Checksum error", L);
exit (2);
}
addr += n;
} while (type != 1);
j = fgetc(fpcom);
while (j != EOF)
{
fputc(j, fpout);
j = fgetc(fpcom);
}
exit(0);
}

32
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/inpout.asm Normal file
View File

@@ -0,0 +1,32 @@
$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/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


739
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/loader3.asm Normal file
View File

@@ -0,0 +1,739 @@
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 401h ;[JCE] was 41A before patches
;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


BIN
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/mac.com Normal file
View File

Binary file not shown.

632
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/main.plm Normal file
View File

@@ -0,0 +1,632 @@
/* 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 public; /* [JCE] public so the timest */
declare offset byte; /* code can use it */
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;

10
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/main80.plm Normal file
View File

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

16
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/makedate.lib Normal file
View File

@@ -0,0 +1,16 @@
;
; [JCE] Have the date and copyright messages in only one source file
;
@BDATE MACRO
db '101198'
ENDM
@LCOPY MACRO
db 'Copyright 1998, '
db 'Caldera, Inc. '
ENDM
@SCOPY MACRO
db '(c) 98 Caldera'
ENDM

39
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/making.txt Normal file
View File

@@ -0,0 +1,39 @@
Compiling Caldera CP/M 3
========================
The supplied source is (I hope) all that is necessary to build the CP/M 3
binary distribution under Unix.
The Makefile has been written for GNU Make. You will need:
* The PL/M development system from the Unofficial CP/M Website
<http://www.cpm.z80.de/binary.html>
* The zxcc emulator (version 0.3 or later) installed
<http://www.seasip.info/Unix/Zxcc/>
* The thames emulator (version 0.1.0 or later) installed
<http://www.seasip.info/Unix/Thames/>
The PL/M system contains the PLM80 compiler, the ASM80 assembler, and the
ISIS emulator. Unpack these to separate directories.
Edit the shell script run_thames to set the four directories:
ISIS_F0 source code directory
ISIS_F1 PLM80 compiler
ISIS_F2 ASM80 assembler
ISIS_F3 ISIS emulator and libraries
'make all' will then set the build in motion. Since the build tools do not
return error codes, you will have to watch for error messages yourself,
and stop the build if you see one.
When GENCOM is being run, you may see a "corrupt FCB" message. This is
caused by GENCOM closing a file it didn't open, and you may safely ignore it.
The build date is stored in three files:
MCD80A.ASM
MCD80F.ASM
MAKEDATE.LIB
and you should change all of these if you are making a new release.

94
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/mcd80a.asm Normal file
View File

@@ -0,0 +1,94 @@
$title ('COM Externals')
name mcd80a
CSEG
; September 14, 1982
offset equ 0000h
boot equ 0000h ;[JCE] to make SHOW compile
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, boot
;*******************************************************
; 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
;
;[JCE 17-5-1998] Guard code prevents this program being run under DOS
;
db 0EBh,7 ;Sends 8086s to I8086:
lxi sp, stack
JMP PLM
db 0 ;Packing.
;
I8086: db 0CDh,020h ;INT 20h - terminate immediately
; 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'
;
;[JCE] Since I can't work out how to get ASM80 to use macro libraries,
; the date and copyright are here as well as in MAKEDATE.LIB
;
db 'Copyright 1998, '
db 'Caldera, Inc. '
db '101198' ; version date day-month-year
db 0,0,0,0 ; patch bit map
db '654321' ; Serial no.
END
EOF

97
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/mcd80f.asm Normal file
View File

@@ -0,0 +1,97 @@
$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:
;[JCE 17-5-1998] Protect against being run under DOS
db 0EBh,0Bh ;Sends 8086s to I8086: below
lxi sp, stack
call plm ; call program
mvi c,0
call bdos
I8086: db 0CDh,020h ;8086 processors come here - INT 20h
; 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
db 0
db 'CP/M Version 3.0'
db 'Copyright 1998, '
db 'Caldera, Inc. '
db '101198' ; version date day-month-year
db 0,0,0,0 ; patch bit map
db '654321' ; Serial no.
END
EOF

779
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/minhlp.plm Normal file
View File

@@ -0,0 +1,779 @@
$title ('Help Utility Version 1.1')
help:
do;
/* [JCE] Cut-down version of help that only does [C]reate */
/*
Copyright (C) 1982
Digital Research
P.O. 579
Pacific Grove, CA 93950
Revised:
06 Dec 82 by Bruce Skidmore
*/
declare plm label public;
/**********************************************
Interface Procedures
**********************************************/
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;
/**********************************************
Global Variables
**********************************************/
declare (list$mode,nopage$mode,create$mode,extract$mode,page$mode) byte;
declare (offset,eod) byte;
declare cmdrv (1) byte external; /* [JCE] Help patch 2 */
declare fcb (13) byte external;
declare fcb2 (36) byte;
declare maxb address external;
declare fcb16 (1) byte external;
declare tbuff (128) byte external;
declare control$z literally '1AH';
declare cr literally '0DH';
declare lf literally '0AH';
declare tab literally '09H';
declare slash literally '''/''';
declare true literally '0FFH';
declare false literally '00H';
declare (cnt,index) byte;
declare sub(12) byte;
declare com(11) structure(
name(15) byte);
declare sysbuff(8) structure(
subject(12) byte,
record address,
rec$offset byte,
level byte) at (.memory);
declare name(12) byte;
declare level byte;
declare gindex address;
declare tcnt byte;
declare version address;
/**************************************
* *
* B D O S Externals *
* *
**************************************/
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$console$buf:
procedure (buff$adr);
declare buff$adr address;
call mon1 (9,buff$adr);
end print$console$buf;
read$console$buff:
procedure (buff$adr);
declare buff$adr address;
call mon1(10,buff$adr);
end read$console$buff;
direct$con$io:
procedure(func) byte;
declare func byte;
return mon2(6,func);
end direct$con$io;
get$version:
procedure address;
return mon3(12,0);
end get$version;
delete$file:
procedure (fcb$address);
declare fcb$address address;
call mon1(19,fcb$address);
end delete$file;
open$file:
procedure (fcb$address) byte;
declare fcb$address address;
declare fcb based fcb$address (1) byte;
fcb(12) = 0; /* EX = 0 */
fcb(32) = 0; /* CR = 0 */
return mon2 (15,fcb$address);
end open$file;
close$file:
procedure (fcb$address) byte;
declare fcb$address address;
return mon2 (16,fcb$address);
end close$file;
read$record:
procedure (fcb$address) byte;
declare fcb$address address;
return mon2 (20,fcb$address);
end read$record;
write$record:
procedure (fcb$address) byte;
declare fcb$address address;
return mon2(21,fcb$address);
end write$record;
make$file:
procedure (fcb$address) byte;
declare fcb$address address;
declare fcb based fcb$address (1) byte;
fcb(12) = 0; /* EX = 0 */
fcb(32) = 0; /* CR = 0 */
return mon2(22,fcb$address);
end make$file;
read$rand:
procedure (fcb$address) byte;
declare fcb$address address;
return mon2(33,fcb$address);
end read$rand;
set$dma:
procedure (dma$address);
declare dma$address address;
call mon1(26,dma$address);
end set$dma;
set$rand$rec:
procedure (fcb$address);
declare fcb$address address;
call mon1(36,fcb$address);
end set$rand$rec;
terminate:
procedure;
call mon1 (0,0);
end terminate;
/*********************************************
Error Procedure
Displays error messages and
terminates if required.
*********************************************/
error:
procedure(term$code,err$msg$adr);
declare term$code byte;
declare err$msg$adr address;
call print$console$buf(.(cr,lf,'ERROR: $'));
call print$console$buf(err$msg$adr);
call print$console$buf(.(cr,lf,'$'));
if term$code then
call terminate;
end error;
/*********************************************
Move Procedure
Moves specified number of bytes
from the Source address to the
Destination address.
*********************************************/
movef:
procedure (mvcnt,source$addr,dest$addr);
declare (source$addr,dest$addr) address;
declare mvcnt byte;
call move(mvcnt,source$addr,dest$addr);
return;
end movef;
/*********************************************
Compare Function
Compares 12 byte strings
Results: 0 - string1 = string2
1 - string1 < string2
2 - string1 > string2
*********************************************/
compare:
procedure(str1$addr,str2$addr) byte;
declare (str1$addr,str2$addr) address;
declare string1 based str1$addr (12) byte;
declare string2 based str2$addr (12) byte;
declare (result,i) byte;
result,
i = 0;
do while ((i < 12) and (string1(i) <> ' '));
if string1(i) <> string2(i) then
do;
if string1(i) < string2(i) then
do;
result = 1;
end;
else
do;
result = 2;
end;
i = 11;
end;
i = i + 1;
end;
return result;
end compare;
/*********************************************
Increment Procedure
Increments through a record.
*********************************************/
inc:
procedure (inci) byte;
declare inci byte;
inci = inci + 1;
if inci > 127 then
do;
if read$record(.fcb) = 0 then
do;
inci = 0;
end;
else
do;
eod = true;
inci = 0;
end;
end;
return inci;
end inc;
/*******************************************
Init Procedure
Reads the index into memory
*******************************************/
init:
procedure;
declare (buf$size,max$buf,init$i) address;
declare end$index byte;
buf$size = maxb - .memory;
max$buf = buf$size;
end$index = 0;
init$i = 7;
do while (not end$index) and (max$buf > 127);
call set$dma(.sysbuff(init$i-7).subject);
if read$record(.fcb) <> 0 then
do;
init$i = close$file(.fcb);
call error(true,.('Reading HELP.HLP index.$'));
end;
if sysbuff(init$i).subject(0) = '$' then end$index = true;
if not end$index then
do;
max$buf = max$buf - 128;
init$i = init$i + 8;
end;
end;
call set$dma(.tbuff);
if (max$buf < 128) and (not end$index) then
do;
init$i = close$file(.fcb);
call error(true,.('Too many entries in Index Table.',
' Not enough memory.$'));
end;
end init;
/*******************************************
Parse Procedure
Parses the command tail
*******************************************/
parse:
procedure byte;
declare (index,begin,cnt,i,stop,bracket) byte;
index = 0;
if tbuff(0) <> 0 then
do;
do index = 1 to tbuff(0);
if tbuff(index) = tab then tbuff(index) = ' ';
else if tbuff(index) = ',' then tbuff(index) = ' ';
end;
index = 1;
do while(index < tbuff(0)) and (tbuff(index) = ' ');
index = index + 1;
end;
if tbuff(index) = '.' then
do;
begin = level;
tbuff(index) = ' ';
end;
else
begin = 0;
do index = begin to 10;
call movef(15,.(' ',cr,'$'),.com(index).name);
end;
index = begin;
cnt = 1;
stop,
bracket = 0;
do while (tbuff(cnt) <> 0) and (not stop);
if (tbuff(cnt) <> 20H) then
do;
i = 0;
do while (((tbuff(cnt) <> 20H) and (tbuff(cnt) <> '[')) and
(tbuff(cnt) <> 0)) and ((i < 12) and (index < 11));
if (tbuff(cnt) > 60H) and (tbuff(cnt) < 7BH) then
do;
com(index).name(i) = tbuff(cnt) - 20H;
end;
else
do;
com(index).name(i) = tbuff(cnt);
end;
cnt = cnt + 1;
i = i + 1;
end;
index = index + 1;
if (bracket or (index > 10)) then
do;
stop = true;
end;
else
if tbuff(cnt) = '[' then
do;
if com(index-1).name(0) = ' ' then index = index - 1;
com(index).name(0) = '[';
cnt = cnt + 1;
index = index + 1;
bracket = true;
end;
end;
else
do;
cnt = cnt + 1;
end;
end;
end;
list$mode,
nopage$mode,
create$mode,
extract$mode = false;
if index > 0 then
do;
i = 0;
do while (i < 10);
if com(i).name(0) = '[' then
do;
if (com(i+1).name(0) = 'C') then
do;
create$mode = true;
index = index - 2;
end;
else if (com(i+1).name(0) = 'E') then
do;
extract$mode = true;
index = index - 2;
end;
else if (com(i+1).name(0) = 'N') then
do;
nopage$mode =true;
index = index - 2;
end;
else if (com(i+1).name(0) = 'L') then
do;
list$mode = true;
nopage$mode = true;
index = index - 2;
end;
else if (com(i+1).name(0) <> ' ') then
do;
index = index - 2;
end;
else
do;
index = index - 1;
end;
i = 10;
end;
i = i + 1;
end;
end;
return index;
end parse;
/******************************************
Create$index Procedure
Creates HELP.HLP from HELP.DAT
******************************************/
create$index:
procedure;
declare (cnt, i, rec$cnt) byte;
declare (index,count,count2,max$buf,save$size) address;
declare fcb3(36) byte;
call print$console$buf(.(cr,lf,'Creating HELP.HLP....$'));
do i = 0 to 7;
call movef(12,.('$ '),.sysbuff(i).subject);
end;
rec$cnt,
index = 0;
save$size = maxb - .memory;
max$buf = save$size;
call movef(13,.(0,'HELP DAT',0),.fcb);
if open$file(.fcb) = 0FFH then
do;
call error(true,.('HELP.DAT not on current drive.$'));
end;
eod = 0;
do while (not eod) and (read$record(.fcb) = 0);
i = 0;
do while(i < 128) and (not eod);
if tbuff(i) = control$z then
do;
eod = true;
end;
else
do;
if tbuff(i) = slash then
do;
cnt = 0;
do while(not eod) and (tbuff(i) = slash);
i = inc(i);
cnt = cnt + 1;
end;
if (cnt = 3) and (not eod) then
do;
sysbuff(index).level = tbuff(i) - '0';
i = inc(i);
cnt = 0;
do while ((cnt < 12) and (not eod)) and (tbuff(i) <> cr);
if (tbuff(i) > 60H) and (tbuff(i) < 7BH) then
do;
sysbuff(index).subject(cnt) = tbuff(i) - 20H;
end;
else
do;
sysbuff(index).subject(cnt) = tbuff(i);
end;
i = inc(i);
cnt = cnt + 1;
end;
if (not eod) then
do;
call set$rand$rec(.fcb);
call movef(1,.fcb(33),.sysbuff(index).record);
call movef(1,.fcb(34),.sysbuff(index).record+1);
sysbuff(index).record = sysbuff(index).record - 0001H;
sysbuff(index).rec$offset = i;
index = index + 1;
if ((index mod 8) = 0) then
do;
rec$cnt = rec$cnt + 1;
max$buf = max$buf - 128;
if (max$buf < 128) and (not eod) then
do;
cnt = close$file(.fcb);
call error(true,
.('Too many entries in Index Table.',
' Not enough memory.$'));
end;
else
do count = index to index + 7;
call movef(12,.('$ '),
.sysbuff(count).subject);
end;
end;
end;
end;
end;
else
do;
i = inc(i);
end;
end;
end;
end;
call set$dma(.sysbuff);
rec$cnt = rec$cnt + 1;
/********************************
create HELP.HLP
********************************/
call movef(13,.(0,'HELP HLP',0),.fcb3);
call delete$file(.fcb3);
if make$file(.fcb3) = 0FFH then
do;
cnt = close$file(.fcb2);
call delete$file(.fcb2);
cnt = close$file(.fcb);
call error(true,.('Unable to Make HELP.HLP.$'));
end;
call movef(4,.(0,0,0,0),.fcb2+32);
cnt = read$rand(.fcb2);
do count = 0 to index - 1;
sysbuff(count).record = sysbuff(count).record + rec$cnt;
end;
do count = 0 to rec$cnt - 1;
call set$dma(.memory(shl(count,7)));
if write$record(.fcb3) = 0FFH then
do;
cnt = close$file(.fcb3);
call delete$file(.fcb3);
cnt = close$file(.fcb2);
call delete$file(.fcb2);
cnt = close$file(.fcb);
call error(true,.('Writing file HELP.HLP.$'));
end;
end;
call movef(4,.(0,0,0,0),.fcb+32);
cnt = read$rand(.fcb);
eod = 0;
do while (not eod);
count = 0;
max$buf = save$size;
do while (not eod) and (max$buf > 127);
call set$dma(.memory(shl(count,7)));
if read$record(.fcb) <> 0 then
do;
eod = true;
end;
else
do;
max$buf = max$buf - 128;
count = count + 1;
end;
end;
do count2 = 0 to count-1;
call set$dma(.memory(shl(count2,7)));
if write$record(.fcb3) = 0FFH then
do;
i = close$file(.fcb3);
call delete$file(.fcb3);
i = close$file(.fcb);
call error(true,.('Writing file HELP.HLP.$'));
end;
end;
end;
if close$file(.fcb) = 0FFH then
do;
cnt = close$file(.fcb3);
call error(true,.('Closing file HELP.DAT.$'));
end;
if close$file(.fcb3) = 0FFH then
do;
call error(true,.(false,'Closing file HELP.HLP.$'));
end;
call print$console$buf(.('HELP.HLP created',cr,lf,'$'));
end create$index;
/********************************************
Extract$file Procedure
Creates HELP.DAT from HELP.HLP
********************************************/
extract$file:
procedure;
declare (end$index,i) byte;
declare (count,count2,max$buf,save$size) address;
call print$console$buf(.(cr,lf,'Extracting data....$'));
call movef(13,.(0,'HELP HLP',0),.fcb);
if open$file(.fcb) = 0FFH then
do;
call error(true,.('Unable to find file HELP.HLP.$'));
end;
call movef(13,.(0,'HELP DAT',0),.fcb2);
call delete$file(.fcb2);
if make$file(.fcb2) = 0FFH then
do;
i = close$file(.fcb);
call error(true,.('Unable to Make HELP.DAT.$'));
end;
call set$dma(.sysbuff);
end$index = 0;
do while ((i := read$record(.fcb)) = 0) and (not end$index);
if sysbuff(7).subject(0) = '$' then end$index = true;
end;
eod = 0;
if i <> 0 then eod = true;
i = write$record(.fcb2);
save$size = maxb - .memory;
do while (not eod);
count = 0;
max$buf = save$size;
do while (not eod) and (max$buf > 127);
call set$dma(.memory(shl(count,7)));
if read$record(.fcb) <> 0 then
do;
eod = true;
end;
else
do;
max$buf = max$buf - 128;
count = count + 1;
end;
end;
do count2 = 0 to count-1;
call set$dma(.memory(shl(count2,7)));
if write$record(.fcb2) = 0FFH then
do;
i = close$file(.fcb2);
call delete$file(.fcb2);
i = close$file(.fcb);
call error(true,.('Writing file HELP.DAT.$'));
end;
end;
end;
if close$file(.fcb) = 0FFH then
do;
call error(false,.('Unable to Close HELP.HLP.$'));
end;
if close$file(.fcb2) = 0FFH then
do;
call delete$file(.fcb2);
call error(true,.('Unable to Close HELP.DAT.$'));
end;
call print$console$buf(.('Extraction complete',cr,lf,lf,
'HELP.DAT created',cr,lf,'$'));
end extract$file;
/*********************************************
Search$file Procedure
Searches the index table for the key
*********************************************/
search$file:
procedure byte;
declare (eod, error, cnt, found, saved, save$level) byte;
declare index address;
eod,
error,
found,
saved,
index = 0;
do while(not eod) and (not error);
if sysbuff(index).subject(0) <> '$' then
do;
if sysbuff(index).level = level + 1 then
do;
cnt = compare(.com(level).name,.sysbuff(index).subject);
if cnt = 0 then
do;
call movef(12,.sysbuff(index).subject,.com(level).name);
level = level + 1;
if (not saved) then
do;
save$level = level;
saved = true;
end;
if ((level > 8) or (com(level).name(0) = ' '))
or (com(level).name(0) = '[') then
do;
found = true;
eod = true;
end;
else
do;
index = index + 1;
found = 0;
end;
end;
else
do;
index = index + 1;
end;
end;
else
do;
if saved then
do;
if save$level < sysbuff(index).level then
do;
index = index + 1;
end;
else
do;
error = true;
end;
end;
else
do;
index = index + 1;
end;
end;
end;
else
do;
error = true;
end;
end;
if found then
do;
gindex = index + 1;
call movef(1,.sysbuff(index).record,.fcb(33));
call movef(1,.sysbuff(index).record+1,.fcb(34));
fcb(35) = 0;
offset = sysbuff(index).rec$offset;
level = sysbuff(index).level;
end;
return error;
end search$file;
/**************************************
Main Program
**************************************/
declare last$dseg$byte byte
initial (0);
plm:
do;
eod,
tcnt = 0;
version = get$version;
if (high(version) = 1) or (low(version) < 30h) then
do;
call error(true,.('Requires CP/M Version 3$'));
end;
cnt = parse;
if create$mode then
do;
call create$index;
end;
else
if extract$mode then
do;
call extract$file;
end;
end;
call terminate;
end help;

19
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/mon.plm Normal file
View File

@@ -0,0 +1,19 @@
/* 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;

33
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/move.asm Normal file
View File

@@ -0,0 +1,33 @@
title 'bank & move module for CP/M3 linked BIOS'
cseg
public ?move,?xmove,?bank
extrn @cbnk
maclib z80
maclib ports
?xmove: ; ALTOS can't perform interbank moves
ret
?move:
xchg ; we are passed source in DE and dest in HL
ldir ; use Z80 block move instruction
xchg ; need next addresses in same regs
ret
; by exiting through bank select
?bank:
push b ; save register b for temp
ral ! ral ! ral ! ani 18h ; isolate bank in proper bit position
mov b,a ; save in reg B
in p$bankselect ; get old memory control byte
ani 0E7h ! ora b ; mask out old and merge in new
out p$bankselect ; put new memory control byte
pop b ; restore register b
ret
; 128 bytes at a time
end

1928
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/newpip.plm Normal file
View File

File diff suppressed because it is too large Load Diff

234
CPM OPERATING SYSTEMS/CPM 3.X/CPM 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


1068
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/patch.asm Normal file
View File

File diff suppressed because it is too large Load Diff

1927
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/pip.plm Normal file
View File

File diff suppressed because it is too large Load Diff

170
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/plibios.asm Normal file
View File

@@ -0,0 +1,170 @@
name 'PLIBIOS'
title 'Direct BIOS Calls From PL/I-80'
;
;***********************************************************
;* *
;* bios calls from pl/i for track, sector io *
;* *
;***********************************************************
public seldsk ;select disk drive
public settrk ;set track number
public setsec ;set sector number
public rdsec ;read sector
public wrsec ;write sector
public sectrn ;translate sector number
public bstdma ;set dma
public bflush ;flush deblocking buffers
;
;
extrn ?boot ;system reboot entry point
extrn ?bdos ;bdos entry point
;
;***********************************************************
;* *
;* equates for interface to cp/m bios *
;* *
;***********************************************************
cr equ 0dh ;carriage return
lf equ 0ah ;line feed
eof equ 1ah ;end of file
;
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
sdma equ 21h ;bios set dma entry point
read equ 24h ;bios read sector entry point
write equ 27h ;bios write sector entry point
stran equ 2dh ;bios sector translation entry point
;
; utility functions
;
;***********************************************************
;***********************************************************
;* *
;* general purpose routines used upon entry *
;* *
;***********************************************************
;
;
getp: ;get parameter
mov e,m ;low (addr)
inx h
mov d,m ;high (addr)
inx h
push h ;save for next parameter
xchg ;hl = .char
mov e,m ;to register e
inx h
mov d,m ;get high byte as well
pop h ;ready for next parameter
ret
;
;
;***********************************************************
;* *
;***********************************************************
seldsk: ;select drive number 0-15, in C
;1-> drive no.
;returns-> pointer to translate table in HL
call getp
mov c,e ;c = drive no.
lxi d,sdsk
jmp gobios
;
;***********************************************************
;* *
;***********************************************************
settrk: ;set track number 0-76, 0-65535 in BC
;1-> track no.
call getp
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.
call getp
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
call getp ;first parameter
mov b,d
mov c,e ;bc = logical sector no.
call getp ;second parameter
push d ;save it
lxi d,stran
lhld wboot
dad d ;hl = sectran entry point
pop d ;de = .translate-table
pchl
;
;***********************************************************
;*
;*
;***********************************************************
bstdma: ;set dma
call getp
mov b,d
mov c,e
lxi d,sdma
jmp gobios
;
bflush: ;flush deblocking buffers
; lxi b,0ffffh
; lxi d,setdmf
; jmp gobios
ret
;***********************************************************
;***********************************************************
;***********************************************************
;* *
;* 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
pchl
;
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
db 0
end

147
CPM OPERATING SYSTEMS/CPM 3.X/CPM 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/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/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'
maclib makedate
@LCOPY ;[JCE] Copyright & build date moved to their own
@BDATE ; files.
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


1093
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/prs1asm.asm Normal file
View File

File diff suppressed because it is too large Load Diff

3859
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/prs2mon.asm Normal file
View File

File diff suppressed because it is too large Load Diff

975
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/put.plm Normal file
View File

@@ -0,0 +1,975 @@
$ 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/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


881
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/putrsx.asm Normal file
View File

@@ -0,0 +1,881 @@
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
maclib makedate ;[JCE] move all dates to one file
db ' '
@BDATE
db ' '
@SCOPY
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


358
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/random.asm Normal file
View File

@@ -0,0 +1,358 @@
;***************************************************
;* *
;* sample random access program for cp/m 3 *
;* *
;***************************************************
org 100h ;base of tpa
;
reboot equ 0000h ;system reboot
bdos equ 0005h ;bdos entry point
;
coninp equ 1 ;console input function
conout equ 2 ;console output function
pstring equ 9 ;print string until '$'
rstring equ 10 ;read console buffer
version equ 12 ;return version number
openf equ 15 ;file open function
closef equ 16 ;close function
makef equ 22 ;make file function
readr equ 33 ;read random
writer equ 34 ;write random
wrtrzf equ 40 ;write random zero fill
parsef equ 152 ;parse function
;
fcb equ 005ch ;default file control block
ranrec equ fcb+33 ;random record position
ranovf equ fcb+35 ;high order (overflow) byte
buff equ 0080h ;buffer address
;
cr equ 0dh ;carriage return
lf equ 0ah ;line feed
;
;***************************************************
;* *
;* load SP, set-up file for random access *
;* *
;***************************************************
lxi sp,stack
;
; version 3.1?
mvi c,version
call bdos
cpi 31h ;version 3.1 or better?
jnc versok
; bad version, message and go back
lxi d,badver
call print
jmp reboot
;
versok:
; correct version for random access
mvi c,openf ;open default fcb
rdname: lda fcb+1
cpi ' '
jnz opfile
lxi d,entmsg
call print
call parse
jmp versok
opfile: lxi d,fcb
call bdos
inr a ;err 255 becomes zero
jnz ready
;
; cannot open file, so create it
mvi c,makef
lxi d,fcb
call bdos
inr a ;err 255 becomes zero
jnz ready
;
; cannot create file, directory full
lxi d,nospace
call print
jmp reboot ;back to ccp
;
;***************************************************
;* *
;* loop back to "ready" after each command *
;* *
;***************************************************
;
ready:
; file is ready for processing
;
call readcom ;read next command
shld ranrec ;store input record#
lxi h,ranovf
mov m,c ;set ranrec high byte
cpi 'Q' ;quit?
jnz notq
;
; quit processing, close file
mvi c,closef
lxi d,fcb
call bdos
inr a ;err 255 becomes 0
jz error ;error message, retry
jmp reboot ;back to ccp
;
;***************************************************
;* *
;* end of quit command, process write *
;* *
;***************************************************
notq:
; not the quit command, random write?
cpi 'W'
jnz notw
;
; this is a random write, fill buffer until cr
lxi d,datmsg
call print ;data prompt
mvi c,127 ;up to 127 characters
lxi h,buff ;destination
rloop: ;read next character to buff
push b ;save counter
push h ;next destination
call getchr ;character to a
pop h ;restore counter
pop b ;restore next to fill
cpi cr ;end of line?
jz erloop
; not end, store character
mov m,a
inx h ;next to fill
dcr c ;counter goes down
jnz rloop ;end of buffer?
erloop:
; end of read loop, store 00
mvi m,0
;
; write the record to selected record number
mvi c,writer
lxi d,fcb
call bdos
ora a ;error code zero?
jnz error ;message if not
jmp ready ;for another record
;
;
;********************************************************
;* *
;* end of write command, process write random zero fill *
;* *
;********************************************************
notw:
; not the quit command, random write zero fill?
cpi 'F'
jnz notf
;
; this is a random write, fill buffer until cr
lxi d,datmsg
call print ;data prompt
mvi c,127 ;up to 127 characters
lxi h,buff ;destination
rloop1: ;read next character to buff
push b ;save counter
push h ;next destination
call getchr ;character to a
pop h ;restore counter
pop b ;restore next to fill
cpi cr ;end of line?
jz erloop1
; not end, store character
mov m,a
inx h ;next to fill
dcr c ;counter goes down
jnz rloop1 ;end of buffer?
erloop1:
; end of read loop, store 00
mvi m,0
;
; write the record to selected record number
mvi c,wrtrzf
lxi d,fcb
call bdos
ora a ;error code zero?
jnz error ;message if not
jmp ready ;for another record
;
;***************************************************
;* *
;* end of write commands, process read *
;* *
;***************************************************
notf:
; not a write command, read record?
cpi 'R'
jnz error ;skip if not
;
; read random record
mvi c,readr
lxi d,fcb
call bdos
ora a ;return code 00?
jnz error
;
; read was successful, write to console
call crlf ;new line
mvi c,128 ;max 128 characters
lxi h,buff ;next to get
wloop:
mov a,m ;next character
inx h ;next to get
ani 7fh ;mask parity
jz ready ;for another command if 00
push b ;save counter
push h ;save next to get
cpi ' ' ;graphic?
cnc putchr ;skip output if not
pop h
pop b
dcr c ;count=count-1
jnz wloop
jmp ready
;
;***************************************************
;* *
;* end of read command, all errors end-up here *
;* *
;***************************************************
;
error:
lxi d,errmsg
call print
jmp ready
;
;***************************************************
;* *
;* utility subroutines for console i/o *
;* *
;***************************************************
getchr:
;read next console character to a
mvi c,coninp
call bdos
ret
;
putchr:
;write character from a to console
mvi c,conout
mov e,a ;character to send
call bdos ;send character
ret
;
crlf:
;send carriage return line feed
mvi a,cr ;carriage return
call putchr
mvi a,lf ;line feed
call putchr
ret
;
parse:
;read and parse filespec
lxi d,conbuf
mvi c,rstring
call bdos
lxi d,pfncb
mvi c,parsef
call bdos
ret
;
print:
;print the buffer addressed by de until $
push d
call crlf
pop d ;new line
mvi c,pstring
call bdos ;print the string
ret
;
readcom:
;read the next command line to the conbuf
lxi d,prompt
call print ;command?
mvi c,rstring
lxi d,conbuf
call bdos ;read command line
; command line is present, scan it
mvi c,0 ;start with 00
lxi h,0 ; 0000
lxi d,conlin;command line
readc: ldax d ;next command character
inx d ;to next command position
ora a ;cannot be end of command
rz
; not zero, numeric?
sui '0'
cpi 10 ;carry if numeric
jnc endrd
; add-in next digit
push psw
mov a,c ;value = ahl
dad h
adc a ;*2
push a ;save value * 2
push h
dad h ;*4
adc a
dad h ;*8
adc a
pop b ;*2 + *8 = *10
dad b
pop b
adc b
pop b ;+digit
mov c,b
mvi b,0
dad b
aci 0
mov c,a
jnc readc
jmp readcom
endrd:
; end of read, restore value in a
adi '0' ;command
cpi 'a' ;translate case?
rc
; lower case, mask lower case bits
ani 101$1111b
ret ;return with value in chl
;
;***************************************************
;* *
;* string data area for console messages *
;* *
;***************************************************
badver:
db 'sorry, you need cp/m version 3$'
nospace:
db 'no directory space$'
datmsg:
db 'type data: $'
errmsg:
db 'error, try again.$'
prompt:
db 'next command? $'
entmsg:
db 'enter filename: $'
;
;***************************************************
;* *
;* fixed and variable data area *
;* *
;***************************************************
conbuf: db conlen ;length of console buffer
consiz: ds 1 ;resulting size after read
conlin: ds 32 ;length 32 buffer
conlen equ $-consiz
;
pfncb:
dw conlin
dw fcb
;
ds 32 ;16 level stack
stack:
end

608
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/rename.plm Normal file
View File

@@ -0,0 +1,608 @@
$ 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;

713
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/resbdos.asm Normal file
View File

@@ -0,0 +1,713 @@
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
sta fx ;[JCE] DRI patch 1
lxi h,functab! mvi b,0
dad b! dad b! mov a,m
inx h! mov h,m! mov l,a! pchl
maclib makedate ;[JCE] Dates all go in one file
@LCOPY
@BDATE
dw 0,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 0fch! rz ;[JCE] DRI Patch 13: F8 -> FC
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
dw 0
olog: dw 0
rlog: dw 0
patch$flgs: db 0,0,0,7 ;[JCE] Patchlevel 7
; 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


BIN
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/rmac.com Normal file
View File

Binary file not shown.

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

@@ -0,0 +1,11 @@
#! /bin/sh
#
# Set up environment variables for thames, and run it
#
ISIS_F0=`pwd`
ISIS_F1=`pwd`/PLM80
ISIS_F2=`pwd`/ASM80
ISIS_F3=`pwd`/Utils
export ISIS_F0 ISIS_F1 ISIS_F2 ISIS_F3
thames $*

820
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/save.asm Normal file
View File

@@ -0,0 +1,820 @@
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.
; *
; * Modified:
; * 17 May 1998 - John Elliott
; * Apply DRI patch 18 and "multiple calls" bug fix
; *
; *********************************************************
;
; 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 31 ;[JCE] Version 3.1
;
; Buffer size
;
CONMAX equ 14 ;[JCE] Patch 18: console buffer maximum should be 14
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
NOPME: jz START ;[JCE] For the bug fix, see below
lhld NEXT ;get address for continue
pchl ;get going.....
;
;
;
START:
;
;[JCE] Bug. This rewires the jump vectors every time the Loader is called,
; and some programs call the Loader more than once to load overlays.
; The second time it is called, SAVE is left pointing at itself rather
; than the real BIOS.
;
; 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
;
;
; [JCE] Fix for the bug I mentioned earlier
;
lxi h,0 ;[JCE] Nop out the jump to this routine. Crude
shld NOPME ;[JCE] but effective!
shld NOPME+1 ;[JCE]
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


22
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/scan.lit Normal file
View File

@@ -0,0 +1,22 @@
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';

731
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/scan.plm Normal file
View File

@@ -0,0 +1,731 @@
$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;

49
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/scb.asm Normal file
View File

@@ -0,0 +1,49 @@
title 'System Control Block Definition for CP/M3 BIOS'
public @civec, @covec, @aivec, @aovec, @lovec, @bnkbf
public @crdma, @crdsk, @vinfo, @resel, @fx, @usrcd
public @mltio, @ermde, @erdsk, @media, @bflgs
public @date, @hour, @min, @sec, ?erjmp, @mxtpa
scb$base equ 0FE00H ; Base of the SCB
@CIVEC equ scb$base+22h ; Console Input Redirection
; Vector (word, r/w)
@COVEC equ scb$base+24h ; Console Output Redirection
; Vector (word, r/w)
@AIVEC equ scb$base+26h ; Auxiliary Input Redirection
; Vector (word, r/w)
@AOVEC equ scb$base+28h ; Auxiliary Output Redirection
; Vector (word, r/w)
@LOVEC equ scb$base+2Ah ; List Output Redirection
; Vector (word, r/w)
@BNKBF equ scb$base+35h ; Address of 128 Byte Buffer
; for Banked BIOS (word, r/o)
@CRDMA equ scb$base+3Ch ; Current DMA Address
; (word, r/o)
@CRDSK equ scb$base+3Eh ; Current Disk (byte, r/o)
@VINFO equ scb$base+3Fh ; BDOS Variable "INFO"
; (word, r/o)
@RESEL equ scb$base+41h ; FCB Flag (byte, r/o)
@FX equ scb$base+43h ; BDOS Function for Error
; Messages (byte, r/o)
@USRCD equ scb$base+44h ; Current User Code (byte, r/o)
@MLTIO equ scb$base+4Ah ; Current Multi-Sector Count
; (byte,r/w)
@ERMDE equ scb$base+4Bh ; BDOS Error Mode (byte, r/o)
@ERDSK equ scb$base+51h ; BDOS Error Disk (byte,r/o)
@MEDIA equ scb$base+54h ; Set by BIOS to indicate
; open door (byte,r/w)
@BFLGS equ scb$base+57h ; BDOS Message Size Flag (byte,r/o)
@DATE equ scb$base+58h ; Date in Days Since 1 Jan 78
; (word, r/w)
@HOUR equ scb$base+5Ah ; Hour in BCD (byte, r/w)
@MIN equ scb$base+5Bh ; Minute in BCD (byte, r/w)
@SEC equ scb$base+5Ch ; Second in BCD (byte, r/w)
?ERJMP equ scb$base+5Fh ; BDOS Error Message Jump
; (word, r/w)
@MXTPA equ scb$base+62h ; Top of User TPA
; (address at 6,7)(word, r/o)
end

22
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/search.lit Normal file
View File

@@ -0,0 +1,22 @@
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 */

436
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/search.plm Normal file
View File

@@ -0,0 +1,436 @@
$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;

1853
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/set.plm Normal file
View File

File diff suppressed because it is too large Load Diff

1077
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/setbuf.plm Normal file
View File

File diff suppressed because it is too large Load Diff

907
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/setdef.plm Normal file
View File

@@ -0,0 +1,907 @@
$ 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
Modified: 18 May 1998 by John Elliott
Modified: 18 Sep 1998 by John Elliott
*/
/********************************************
* *
* 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',
date$flag$offset literally '0ch', /* [JCE] Date in UK order? */
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 date$flag byte; /* [JCE] Date in UK form? */
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 show$date byte initial(true); /* [JCE] */
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~UK~US~YMD',0ffh), /* [JCE] added US / UK / YMD */
options$offset(*) byte data
(0,10,16,21,29,32,36,40,47,57,60,64,67,70),
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,date) byte; /* [JCE] Date */
/* 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);
date$flag = getscbbyte(date$flag$offset);
display$flag = ccp$flag2 and 00$000$011b;
order = shr((ccp$flag2 and 00$011$000b),3);
date = (date$flag and 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;
/* [JCE] TIME FORMAT DISPLAY */
if show$date then do;
call crlf;
call print$buf(.('Date format used - $'));
if date = 0 then
call print$buf(.('US$'));
else if date = 1 then
call print$buf(.('UK$'));
else
call print$buf(.('YMD$')); /* [JCE 18-9-1998] */
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 */
/* [JCE] UK option */
do;
show$date = true;
date$flag = getscbbyte(date$flag$offset);
date$flag = date$flag and 11111100b; /* Clear time settings */
date$flag = date$flag or 1; /* Set that bit */
call setscbbyte(date$flag$offset, date$flag);
end;
/* [JCE] US option */
do;
show$date = true;
date$flag = getscbbyte(date$flag$offset);
date$flag = date$flag and 11111100b; /* Clear time settings */
call setscbbyte(date$flag$offset, date$flag);
end;
/* [JCE] YMD option */
do;
show$date = true;
date$flag = getscbbyte(date$flag$offset);
date$flag = date$flag and 11111100b; /* Clear time settings */
date$flag = date$flag or 2; /* Set that bit */
call setscbbyte(date$flag$offset, date$flag);
end;
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,show$date /*[JCE]*/
= 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;

1913
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/show.plm Normal file
View File

File diff suppressed because it is too large Load Diff

63
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/sopt.dcl Normal file
View File

@@ -0,0 +1,63 @@
declare
opt$mod(19) structure(modifier(8) byte)
data(1,1,1,0,0,0,0,0, /* 0 access */
1,1,1,0,0,0,0,0, /* 1 archive */
1,1,1,0,0,0,0,0, /* 2 create */
1,0,0,0,0,0,0,1, /* 3 default */
0,0,0,0,0,0,0,0, /* 4 directory */
1,1,1,0,0,0,0,0, /* 5 f1 */
1,1,1,0,0,0,0,0,
1,1,1,0,0,0,0,0,
1,1,1,0,0,0,0,0,
1,0,0,0,0,0,0,1, /* 9 name */
1,0,0,0,0,0,0,1, /* 10 password */
1,1,1,1,1,1,1,0, /* 11 protect */
0,0,0,0,0,0,0,0, /* 12 ro */
0,0,0,0,0,0,0,0, /* 13 rw */
0,0,0,0,0,0,0,0, /* 14 sys */
1,1,1,0,0,0,0,0, /* 15 update */
0,0,0,0,0,0,0,0, /* 16 page */
0,0,0,0,0,0,0,0), /* 17 nopage */
options(*) byte
data('ACCESS0ARCHIVE0CREATE0DEFAULT0DIR0F10F20F30F40',
'NAME0PASSWORD0PROTECT0RO0RW0SYS',
'0UPDATE0PAGE0NOPAGE',0ffh),
off$opt(20) byte data(0,7,15,22,30,34,37,40,43,46,51,60,68,71,
74,78,85,90,96),
mods(*) byte
data('OFF0ON0READ0WRITE0DELETE0NONE',0ffh),
off$mods(7) byte data(0,4,7,12,18,25,29),
end$list byte data (0ffh),
end$of$string byte data(0),
delimiters(*) byte data (0,'[]=, :;<>%\|"()/#!@&+-*?',0,0ffh),
SPACE byte data (5), /* index in delim to space */
RBRACKET byte data(2), /* ] in delim */
ENDFF byte data(25),
EQUAL byte data (3),
LBRACKET byte data (1),
option$map(19) byte,
mods$map(19) byte;
declare
sfamsg byte initial(false),
drvmsg byte initial(false),
j byte initial(0),
string$ptr address,
defpass address,
labname address,
passname address,
lendef byte,
lenpass byte,
lenlab byte,
buf$ptr address,
index byte,
endbuf byte,
mindex byte,
delimiter byte;
$ eject

286
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/sopt.inc Normal file
View File

@@ -0,0 +1,286 @@
$eject
check$choice: procedure(index,mindex) byte;
/* does this modifier go with this
option? */
declare
index byte,
mindex byte;
return(opt$mod(index).modifier(mindex));
end check$choice;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * 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) byte;
/* list$ptr - pointer to list of known strings
off$ptr - pointer to offsets into known string
list
buf$ptr - pointer to input string
Scans the known string list for an occurrance of the input
string. If the input string is not found in the known list
then return(0). Otherwise, return the index of the known string
that matches the input.
1. Find the known string that matches the input string on the
first letter.
do i = 1 to #known_strings
if Known_string(i,1) = input(1) then do
if length(Known_string(i)) < end_of_input
then return(0)
do j = 2 to end_of_input
if Known_string(i,j) ~= input(j) then
go to again
end
go to 2
end
again: end
return (0) !no matchs
2. Test to see if the input string does not match another Known
string. This may happen if the input string is not a
unique sub-string of the Known string, ie., DI is a
sub-string of DIRECTORY and DISK.
index = i
do i = index+1 to #known_strings
do j = 1 to end of input
if Known_string(i,j) ~= input(j) then
go to next
end
return(0) !not unique
next: end;
return(index) !unique substring
P.Balma 10/82 */
declare
buff based buf$ptr (1) byte,
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 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);
do while ((delimiter <> 2) and (delimiter <> 4) and (delimiter <> 5)
and (delimiter <> 25));
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(0);
/* 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 */
call skip; /* skip input field to next delimiter*/
return(0);
finished: /* unambiguous reference */
buf$ptr = buf$ptr + endbuf;
call eat$blanks;
if delimiter <> 0 then buf$ptr = buf$ptr + 1;
else delimiter = SPACE;
return(save$index);
end opt$scanner;
error$prt: procedure;
declare i byte,
t address,
char based t byte;
t = buf$ptr - endbuf - 1;
do i = 1 to endbuf;
call printchar(char);
t = t + 1;
end;
end error$prt;

119
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/sort.plm Normal file
View File

@@ -0,0 +1,119 @@
$title ('SDIR - Sort Module')
sort:
do;
/* sort module for extended dir */
$include(comlit.lit)
print: procedure(str$adr) external; /* in util.plm */
dcl str$adr address;
end print;
dcl sorted boolean public; /* set by this module if successful sort */
$include(finfo.lit)
declare
buf$fcb$adr address external, /* index into directory buffer */
buf$fcb based buf$fcb$adr (32) byte,
/* fcb template for dir */
(f$i$adr, first$f$i$adr, last$f$i$adr, x$i$adr, filesfound)
address external,
/* indices into file$info array */
file$info based f$i$adr f$info$structure,
mid$adr address,
mid$file$info based mid$adr f$info$structure;
mult23: procedure(index) address public;
dcl index address; /* return address of file$info numbered by index */
return shl(index, 4) + shl(index,2) + shl(index,1) + index + first$f$i$adr;
/* index * size(file$info) + base of file$info array */
end mult23;
lessthan: procedure( str1$adr, str2$adr) boolean;
dcl (i,c1,c2) byte, /* true if str1 < str2 */
(str1$adr, str2$adr) address, /* sorting on name and type field */
str1 based str1$adr (1) byte, /* only, assumed to be first in */
str2 based str2$adr (1) byte; /* file$info record */
do i = 1 to 11;
if (c1:=(str1(i) and 7fh)) <> (c2:=(str2(i) and 7fh)) then
return(c1 < c2);
end;
return(false);
end lessthan;
dcl f$i$indices$base address public,
f$i$indices based f$i$indices$base (1) address;
qsort: procedure(l,r); /* no recursive quick sort, sorting largest */
dcl (l,r,i,j,temp) address,/* partition first */
stacksiz lit '14', /* should always be able to sort 2 ** stacksiz */
stack (stack$siz) structure (l address, r address),
sp byte;
sp = 0; stack(0).l = l; stack(0).r = r;
do while sp < stack$siz - 1;
l = stack(sp).l; r = stack(sp).r; sp = sp - 1;
do while l < r;
i = l; j = r;
mid$adr = mult23(f$i$indices(shr(l+r,1)));
do while i <= j;
f$i$adr = mult23(f$i$indices(i));
do while lessthan(f$i$adr,mid$adr);
i = i + 1;
f$i$adr = mult23(f$i$indices(i));
end;
f$i$adr = mult23(f$i$indices(j));
do while lessthan(mid$adr,f$i$adr);
j = j - 1;
f$i$adr = mult23(f$i$indices(j));
end;
if i <= j then
do; temp = f$i$indices(i); f$i$indices(i) = f$i$indices(j);
f$i$indices(j) = temp;
i = i + 1;
if j > 0 then j = j - 1;
end;
end; /* while i <= j */
if j - l < r - i then /* which partition is larger */
do; if i < r then
do; sp = sp + 1; stack(sp).l = i; stack(sp).r = r;
end;
r = j; /* continue sorting left partition */
end;
else
do; if l < j then
do; sp = sp + 1; stack(sp).l = l; stack(sp).r = j;
end;
l = i; /* continue sorting right partition */
end;
end; /* while l < r */
end; /* while sp < stack$siz - 1 */
if sp <> 255 then
call print(.(cr,lf,lf,'Sort Stack Overflow',cr,lf,'$'));
else sorted = true;
end qsort;
sort: procedure public;
dcl i address;
f$i$indices$base = last$f$i$adr + size(file$info);
if filesfound < 2 then
return;
if shr((x$i$adr - f$i$indices$base),1) < filesfound then
do;
call print(.('Not Enough Memory for Sort',cr,lf,'$'));
return;
end;
do i = 0 to filesfound - 1;
f$i$indices(i) = i; /* initialize f$i$indices */
end;
call print(.(cr,lf,'Sorting Directory...',cr,lf,'$'));
call qsort(0,filesfound - 1);
sorted = true;
end sort;
end sort;

663
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/submit.plm Normal file
View File

@@ -0,0 +1,663 @@
$ TITLE('CP/M 3.0 --- SUBMIT')
sub:
do;
$include (copyrt.lit)
/*
Revised:
26 July 79 for CP/M 2.0
01 July 82 for CP/M 3.0 by John Knight
23 Aug 82 for CP/M 3.0 by Doug Huskey
11 Sept 82 for CP/M 3.0 by Doug Huskey
1 Nov 82 for CP/M 3.0 by Doug Huskey
*/
/*
generation procedure
seteof submit.plm
seteof copyrt.lit
is14
asm80 mcd80a.asm debug
asm80 getf.asm debug
asm80 parse.asm debug
plm80 submit.plm 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
objcpm submit
rmac getrsx
xref getrsx
link getrsx[op]
era get.rsx
ren get.rsx=getrsx.prl
gencom submit.com get.rsx
*/
declare plm label public;
/*********************************
* *
* B D O S I N T E R F A C E *
* *
*********************************/
declare
sfcb(33) byte external, /* default fcb */
buff(128) byte external; /* default buffer */
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 */
mon1: procedure(f,a) external;
declare f byte, a address;
/* bdos interface, no returned value */
end mon1;
mon2a: procedure(f,a) external;
declare f byte, a byte;
/* bdos interface, no returned value */
end mon2a;
mon2: procedure(f,a) byte external;
declare f byte, a address;
/* bdos interface, return byte value */
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;
getf:
procedure (input$type) external; /* does submit file processing */
declare input$type address;
end getf;
/************************************
* *
* L I T E R A L S *
* *
************************************/
declare lit literally 'literally',
dcl lit 'declare',
proc lit 'procedure',
addr lit 'address',
ctll lit '0ch',
lca lit '110$0001b', /* lower case a */
lcz lit '111$1010b', /* lower case z */
endfile lit '1ah', /* cp/m end of file */
sysin$endfile lit '0ffh',
true literally '1',
false literally '0',
forever literally 'while true',
cr literally '13',
lf literally '10',
what literally '63',
temp$file$drive$offset literally '50h',
con$type literally '0',
cpmversion literally '30h',
ctrli literally '09h';
/****************************************
* *
* G L O B A L V A R I A B L E S *
* *
****************************************/
declare
ln(9) byte initial('00001 : $'),
ln1 byte at(.ln(0)),
ln2 byte at(.ln(1)),
ln3 byte at(.ln(2)),
ln4 byte at(.ln(3)),
ln5 byte at(.ln(4)),
dfcb(36) byte initial(0,'SYSIN $$$',0,0,0),
drec byte at(.dfcb(32)), /* current record */
drrec address at(.dfcb(33)), /* random record */
drr2 byte at(.dfcb(35)), /* random record byte 3 */
dcnt byte,
get$init$pb byte initial(128), /* getrsx sub-functions */
get$kill$pb byte initial(129),
get$fcb$pb byte initial(130),
sstring(128) byte, /* substitute string */
sbp byte, /* source buffer pointer */
ssbp byte, /* sub string buffer pointer */
ver address,
a address, /* calling program's stack pointer */
prog$flag based a address;
declare scbpd structure
(offset byte,
set byte,
value address);
declare parse$fn structure
(buff$adr address,
fcb$adr address);
declare subpb structure
(io$type byte,
echo$flag byte,
filtered$flag byte,
program$flag byte)
initial (con$type,true,true,false);
declare
ctrlc literally '3',
ctrlx literally '18h',
bksp literally '8',
submit$file$drv literally '15';
/****************************************
* *
* B D O S F U N C T I O N C A L L S *
* *
****************************************/
printchar:
procedure(char);
declare char byte;
call mon1(2,char);
end printchar;
conin:
procedure byte;
return mon2(6,0fdh);
end conin;
print: procedure(a);
declare a address;
/* print the string starting at address a until the
next dollar sign is encountered */
call mon1(9,a);
end print;
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;
open: procedure(fcb) address;
declare fcb address;
return (mon3(15,fcb));
end open;
close: procedure(fcb);
declare fcb address;
dcnt = mon2(16,fcb);
end close;
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;
ranread: procedure(fcb) byte;
declare fcb address;
return mon2(33,fcb);
end ranread;
make: procedure(fcb);
declare fcb address;
dcnt = mon2(22,fcb);
end make;
setdma: procedure(dma);
declare dma address;
call mon1(26,dma);
end setdma;
errormode: procedure(mode);
declare mode byte;
call mon2a(45,mode);
end errormode;
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;
/*************************************************
* *
* M A I N S U B R O U T I N E S *
* *
*************************************************/
move: procedure(s,d,n);
declare (s,d) address, n byte;
declare 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;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
crlf: proc;
call printchar(cr);
call printchar(lf);
end crlf;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
bad$file: proc;
call print(.('Invalid file name $'));
call mon1(0,0);
end bad$file;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* 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;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
error: procedure(a);
declare a address;
call crlf;
call print(.('Error On Line $'));
call print(.ln1);
call print(a);
call move(.dfcb(0),.sfcb(0),33);
call delete(.sfcb(0)); /* cleanup before exit */
call mon1(0,0);
/* return to ccp */
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(.('Enter Password: $'));
retry:
call fill(.fcb16,' ',8);
do i=0 to 7;
nxtchr:
if (c:=getucase) >= ' ' then
fcb16(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;
fcb16(i := i - 1) = ' ';
goto nxtchr;
end;
end;
if c = 3 then
call mon1(0,0);
end;
end getpasswd;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
deblankparm: procedure;
/* clear to next non-blank substitute string */
do while (sstring(ssbp) = ' ' or sstring(ssbp) = ctrli);
ssbp = ssbp + 1;
end;
end deblankparm;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
try$open: procedure;
declare error$code address;
call fill(.fcb16,' ',8); /* blank storage for password */
if len0 <> 0 then
call move(pass0,.fcb16,len0);
call error$mode(0feh);
call setdma(.fcb16); /* set dma to password */
error$code = open(.sfcb);
if low(error$code) = 0ffh then
if high(error$code) = 7 then do;
call getpasswd;
call crlf;
call setdma(.fcb16);
call error$mode(0);
error$code=open(.sfcb);
end;
else do;
if high(error$code) = 0 then
call print(.('ERROR: No ''SUB'' File Found$'));
call mon1(0,0);
end;
call setdma(.buff(0));
call error$mode(0);
end try$open;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
setup: procedure;
declare no$chars byte;
declare pstatus address;
declare b byte;
/* move buffer to substitute string */
call move(.buff(1),.sstring(0),127);
sstring(buff(0))=0; /* mark end of string */
/* check to see if there are parameters */
ssbp = 0;
call deblankparm; /* skip over leading spaces */
if sstring(ssbp) = 0 then do; /* no sub file, prompt for it */
call print(.('CP/M 3 SUBMIT Version 3.0',cr,lf,'$'));
call print(.('Enter File to SUBMIT: $'));
no$chars = read$console$buf(.buff(0),40);
buff(no$chars+2)=0; /* mark end of input */
call crlf;
parse$fn.buff$adr = .buff(2);
parse$fn.fcb$adr = .sfcb(0);
pstatus = parse(.parse$fn);
if pstatus = 0FFFFh then
call bad$file;
call move(.buff(2),.sstring(0),127);
end;
call move(.('SUB'),.sfcb(9),3); /* set file type to SUB */
if sfcb(0) = 0 then
if (b:=getscbbyte(submit$file$drv)) > 0 then do;
sfcb(0)=b; /* set file drive to that saved by CCP */
call setscbbyte(submit$file$drv,0);
end;
call try$open;
do while (sstring(ssbp) <> ' ' and sstring(ssbp) <> 0
and sstring(ssbp) <> ctrli);
ssbp = ssbp + 1; /* skip over file name */
end;
call deblankparm; /* skip over any spaces */
b = sstring(ssbp);
/* File is open if this point reached */
sbp = 128; /* causes read below */
end setup;
getsource: procedure byte;
/* read the next source character */
declare b byte;
if sbp > 127 then
do; if diskread(.sfcb(0)) <> 0 then
return endfile;
sbp = 0;
end;
if (b := buff((sbp:=sbp+1)-1)) = cr then do;
/* increment line */
if (ln5:=ln5+1) > '9' then do;
ln5 = '0';
if (ln4:=ln4+1) > '9' then do;
ln4 = '0';
if (ln3:=ln3+1) > '9' then do;
ln3 = '0';
if (ln2:=ln2+1) > '9' then do;
ln2 = '0';
ln1 = ln1 + 1;
end;
end;
end;
end;
end;
return b;
end getsource;
writebuff: procedure;
/* write the contents of the buffer to disk */
if diskwrite(.dfcb) <> 0 then /* error */
call error(.('Disk Write Error$'));
end writebuff;
declare rbuff(2048) byte, /* jcl buffer */
rbp address, /* jcl buffer pointer */
rlen byte; /* length of current command */
fillrbuff: procedure;
declare s byte; /* sub string buffer pointer */
notend: procedure byte;
/* look at next character in sstring, return
true if not at the end of the string - char passed
back in 's' */
if not ((s := sstring(ssbp)) = ' ' or s = 0) then
do;
ssbp = ssbp + 1;
return true;
end;
return false;
end notend;
write$rbuff: procedure;
declare j byte;
declare i address;
rbp=0; i=0;
do while (i < 2048);
do j=0 to 127;
if rbuff(i+j)=sysin$endfile
then goto close$file;
end;
call setdma(.rbuff(i));
call writebuff;
i=i+128;
end;
call setdma(.buff(0));
return;
close$file:
call setdma(.rbuff(i));
call writebuff;
call setdma(.buff(0));
drrec, drr2 = 0; /* set to 1st record in file */
dcnt = ranread(.dfcb); /* read to position at start */
if dcnt <> 0 then
call error(.('Random Read $'));
goto exit$from$process;
end write$rbuff;
putrbuff: procedure(b);
declare b byte;
if (rbp > last(rbuff)) then do;
call print(.('.$'));
call write$rbuff;
end;
rbuff(rbp) = b;
if b = sysin$endfile then
call write$rbuff;
rbp = rbp + 1;
end putrbuff;
declare (reading,b,newline,progline) byte;
/* fill the jcl buffer */
rbp = 0;
reading = true;
do while reading;
rlen = 0; /* reset command length */
newline,progline = true;
do while (b:=getsource) <> endfile and b <> cr;
if b <> lf then
do; if b = sysin$endfile then
call error(.('Invalid ASCII Character$'));
if newline then do; /* program input begins with < */
newline = false;
if b <> '<' then
progline = false;
end;
if b = '$' then /* copy substitute string */
do; if (b:=getsource) = '$' then
/* $$ replaced by $ */
call putrbuff(b); else
if (b := b - '0') > 9 then
call error(.('Parameter Error$')); else
do; /* find string 'b' in sstring */
ssbp = 0; call deblankparm; /* ready to scan string */
do while b <> 0; b = b - 1;
/* clear next parameter */
do while notend;
end;
call deblankparm;
end;
/* ready to copy substitute string from position ssbp */
do while notend;
call putrbuff(s);
end;
end;
end; else /* not a '$' */
if b = '^' then do; /* possible control character */
b=getsource;
if b = '^' then
call putrbuff('^'); /* '^^' ==> '^' */
else do;
if b < '@' then /* number symbols */
call putrbuff(b-' ');
else
if b < '`' then /* upper case */
call putrbuff(b-'@');
else
call putrbuff(b-'`'); /* lower case */
end;
end;
/* check for multiple commands <com>!<com>!<com> */
else if b = '!' and not progline then do;
call putrbuff(cr); /* mark eoln with cr, lf */
call putrbuff(lf);
end;
else /* not $ or ^ */
call putrbuff(b);
end;
end; /* of line or input file - compute length */
reading = b = cr;
call putrbuff(cr); /* mark eoln with cr, lf */
call putrbuff(lf);
end;
/* entire file has been read and processed */
rbp = rbp - 2; /* back up; too many cr,lf's on last line */
call putrbuff(sysin$endfile); /* mark end of file */
end fillrbuff;
makefile: procedure;
declare i byte;
declare rsxadr addr;
declare rsxbase based rsxadr addr;
rsxadr = rsx$call(.get$init$pb);
i = high(rsxbase); /* rsxbase = addr of kill flag */
i = shr(i,2);
dfcb(6) = i/10 + '0';
dfcb(7) = i mod 10 + '0';
call errormode(0ffh); /* set to return errors */
drec = 0; /* zero the next record to write */
call make(.dfcb);
if dcnt = 255 then do;
call delete(.dfcb); /* file might exist */
call errormode(0);
call make(.dfcb); /* try make again */
if dcnt = 255 then do;
call print(.('ERROR: Directory Full$'));
call mon1(0,0);
end;
end;
call errormode(0);
end makefile;
/*************************************************
* *
* M A I N P R O G R A M *
* *
*************************************************/
plm:
ver = version;
if (low(ver) < cpmversion) or (high(ver) = 1) then do;
call print(.('Requires CP/M 3.0 $'));
call mon1(0,0);
end;
dfcb(0)=getscbbyte(temp$file$drive$offset);
call setup;
call makefile;
call fillrbuff;
exit$from$process:
/* check if GET is above us and about to abort */
a = rsx$call(.get$fcb$pb);
if a <> 0ffh then do;
a = a - 2;
if prog$flag then
a = rsx$call(.get$kill$pb);
end;
call move(.dfcb(0),.sfcb(0),33); /* move to fcb @ 5ch */
call getf(.subpb); /* GETF also does submit processing */
end sub;

873
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/subrsx.asm Normal file
View File

@@ -0,0 +1,873 @@
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
;
maclib getrsx ;[JCE] The Get/Submit equate
maclib makedate ;[JCE] Build date
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 ' '
@BDATE
db ' '
@SCOPY
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


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