diff --git a/.gitignore b/.gitignore index 5bf54d5..e284632 100644 --- a/.gitignore +++ b/.gitignore @@ -60,4 +60,87 @@ software/MZF/BASIC.mzf software/OriginalSA-1510.BIN software/asm/.cbios.asm.swo software/dump - +software/NASCAS +software/CAS +software/MZF +software/BAS +software/CPM/CPM00_MZ800 +software/CPM/CPM00_SYSTEM +software/CPM/CPM01_TURBOP +software/CPM/CPM02_HI_C +software/CPM/CPM03_FORTRAN80 +software/CPM/CPM04_MBASIC +software/CPM/CPM05_COBOL80_v13 +software/CPM/CPM06_COBOL80_v20 +software/CPM/CPM07_COBOL80 +software/CPM/CPM08_Z80FORTH +software/CPM/CPM09_CPMTEX +software/CPM/CPM10_DISKUTILFUNC5 +software/CPM/CPM11_MAC80 +software/CPM/CPM12_PASCALMTP_v561 +software/CPM/CPM13_MTPUG_01 +software/CPM/CPM14_MTPUG_02 +software/CPM/CPM15_MTPUG_03 +software/CPM/CPM16_MTPUG_04 +software/CPM/CPM17_MTPUG_05 +software/CPM/CPM18_MTPUG_06 +software/CPM/CPM19_MTPUG_07 +software/CPM/CPM20_MTPUG_08 +software/CPM/CPM21_MTPUG_09 +software/CPM/CPM22_MTPUG_10 +software/CPM/CPM23_PLI +software/CPM/CPM24_PLI80_v13 +software/CPM/CPM25_PLI80_v14 +software/CPM/CPM26_TPASCAL_v300a +software/CPM/CPM27_WORDSTAR_v30 +software/CPM/CPM28_PLM80 +software/CPM/CPM29_ZSID_v14 +software/CPM/CPM30_WORDSTAR_v400 +software/CPM/CPM31_WORDSTAR_v330 +software/CPM/CPM32_ZCPR3 +software/CPM/CPM33_ZCPR3_COMMON +software/CPM/CPM_MC_5 +software/CPM/CPM_MC_C0 +software/CPM/CPM_MC_C1 +software/CPM/CPM_MC_C2 +software/CPM/CPM_MC_C3 +software/CPM/CPM_MC_C4 +software/CPM/CPM_MC_C5 +software/CPM/CPM_MC_C6 +software/CPM/CPM_MC_C7 +software/CPM/CPM_MC_C8 +software/CPM/CPM_MC_C9 +software/CPM/CPM_MC_D0 +software/CPM/CPM_MC_D1 +software/CPM/CPM_MC_D2 +software/CPM/CPM_MC_D3 +software/CPM/CPM_MC_D4 +software/CPM/CPM_MC_D5 +software/CPM/CPM_MC_D6 +software/CPM/CPM_MC_D7 +software/CPM/CPM_MC_D8 +software/CPM/CPM_MC_D9 +software/CPM/CPM_MC_E0 +software/CPM/CPM_MC_E1 +software/CPM/CPM_MC_E2 +software/CPM/CPM_MC_E3 +software/CPM/CPM_MC_E4 +software/CPM/CPM_MC_E5 +software/CPM/CPM_MC_E6 +software/CPM/CPM_MC_E7 +software/CPM/CPM_MC_E8 +software/CPM/CPM_MC_E9 +software/CPM/CPM_MC_F0 +software/CPM/CPM_MC_F1 +software/CPM/CPM_MC_F2 +software/CPM/CPM_MC_F3 +software/CPM/CPM_MC_F4 +software/CPM/CPM_MC_F5 +software/CPM/CPM_MC_F6 +software/CPM/CPM_MC_F7 +software/CPM/CPM_MC_F8 +software/CPM/CPM_MC_F9 +software/CPM/CPM_RFS_1 +software/CPM/CPM_RFS_2 +software/CPM/PLM80 +software/MZB diff --git a/software/CPM/CPM00_MZ800/asm.com b/software/CPM/CPM00_MZ800/asm.com deleted file mode 100644 index a6a54da..0000000 Binary files a/software/CPM/CPM00_MZ800/asm.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/copy.asm b/software/CPM/CPM00_MZ800/copy.asm deleted file mode 100644 index 4e1fa73..0000000 --- a/software/CPM/CPM00_MZ800/copy.asm +++ /dev/null @@ -1,142 +0,0 @@ - page 55 - title 'Sample file-to-file copy program' -; tstcpy: test copy program ( file-to-file ) -; at the ccp level, the command -; copy a:x.y b:u.v -; copies the file named x.y from -; drive a to a file named u.v on -; drive b. -; -; address equates -; -boot equ 0000h ;system reboot address -bdos equ 0005h ;bdos entry point -fcb1 equ 005ch ;1st file name (default fcb) -sfcb equ fcb1 ;source file name -fcb2 equ 006ch ;2nd file name (from command) -dbuff equ 0080h ;default buffer -tpa equ 0100h ;beginning of tpa -; -; bdos function numbers -; -printf equ 9 ;print buffer -openf equ 15 ;open file -closef equ 16 ;close file -deletef equ 19 ;delete file -readf equ 20 ;sequential read -writef equ 21 ;sequential read -makef equ 22 ;make file -; -; start program: tstcpy -; - org tpa ;beginning of tpa - lxi sp,stack ;initialize local stack -; -; move 2nd file name to dfcb -; - mvi c,16 ;half an fcb - lxi d,fcb2 ;source of move - lxi h,dfcb ;destination fcb -mfcb ldax d ;source fcb - inx d ;ready next - mov m,a ;dest fcb - inx h ;ready next - dcr c ;byte count down - jnz mfcb ;loop 16 times -; -; name has been moved, zero cr -; - xra a ;a = 00 - sta dfcbcr ;current rec = 0 -; -; source and destination fcb's ready -; - lxi d,sfcb ;source fcb - call open ;error if 255 - lxi d,nofile ;ready message - inr a ;255 becomes 0 - cz finis ;done if no file -; -; source file open, prep destination -; - lxi d,dfcb ;destination - call make ;create the file - lxi d,nodir ;ready message - inr a ;255 becomes 0 - cz finis ;done if no dir space -; -; source file open, dest file open; -; copy until end of file on source -; -copy lxi d,sfcb ;source - call read ;read next record - ora a ;end of file ? - jnz eofile ;skip write if eof -; -; not end of file, write the record -; - lxi d,dfcb ;destination - call write ;write record - lxi d,space ;ready message - ora a ;00 if write OK - cnz finis ;end if not OK - jmp copy ;loop until EOF -; -; end of file, close destination -; -eofile: - lxi d,dfcb ;destination - call close ;255 if error - lxi h,wrprot ;ready message - inr a ;255 becomes 0 - cz finis ;shouldn't happen -; -; copy operation complete, end -; - lxi d,normal ;ready message -; -; write message given by de & reboot -; -finis: - mvi c,printf ;print line funct - call bdos ;write message - jmp boot ;reboot system -; -; system interface sub routines -; (all return directly from bdos) -; -open mvi c,openf ;open file fnct - jmp bdos -; -close mvi c,closef ;close file fnct - jmp bdos -; -delete mvi c,deletef ;delete file fnct - jmp bdos -; -read mvi c,readf ;read file fnct - jmp bdos -; -write mvi c,writef ;write file fnct - jmp bdos -; -make mvi c,makef ;make file fnct - jmp bdos -; -; console messages -; -nofile db 'no source file$' -nodir db 'no directory space$' -space db 'out of data space$' -wrprot db 'write protected ?$' -normal db 'copy complete$' -; -; data areas -; -dfcb ds 33 ;destination fcb -dfcbcr equ dfcb+32 ;current record -; - ds 32 ;16 level stack -stack: - end - \ No newline at end of file diff --git a/software/CPM/CPM00_MZ800/copydisk.com b/software/CPM/CPM00_MZ800/copydisk.com deleted file mode 100644 index fb737df..0000000 Binary files a/software/CPM/CPM00_MZ800/copydisk.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/copysys.com b/software/CPM/CPM00_MZ800/copysys.com deleted file mode 100644 index 4eae69e..0000000 Binary files a/software/CPM/CPM00_MZ800/copysys.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/ddt.com b/software/CPM/CPM00_MZ800/ddt.com deleted file mode 100644 index 83f8603..0000000 Binary files a/software/CPM/CPM00_MZ800/ddt.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/del.com b/software/CPM/CPM00_MZ800/del.com deleted file mode 100644 index 8cfcfda..0000000 Binary files a/software/CPM/CPM00_MZ800/del.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/diskdef.com b/software/CPM/CPM00_MZ800/diskdef.com deleted file mode 100644 index f38f21d..0000000 Binary files a/software/CPM/CPM00_MZ800/diskdef.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/diskedit.com b/software/CPM/CPM00_MZ800/diskedit.com deleted file mode 100644 index dbfbe84..0000000 Binary files a/software/CPM/CPM00_MZ800/diskedit.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/dump.asm b/software/CPM/CPM00_MZ800/dump.asm deleted file mode 100644 index c2f9ec4..0000000 --- a/software/CPM/CPM00_MZ800/dump.asm +++ /dev/null @@ -1,209 +0,0 @@ -; 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 - \ No newline at end of file diff --git a/software/CPM/CPM00_MZ800/ed.com b/software/CPM/CPM00_MZ800/ed.com deleted file mode 100644 index a0f0f54..0000000 Binary files a/software/CPM/CPM00_MZ800/ed.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/eject.com b/software/CPM/CPM00_MZ800/eject.com deleted file mode 100644 index cbfe03a..0000000 Binary files a/software/CPM/CPM00_MZ800/eject.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/files.com b/software/CPM/CPM00_MZ800/files.com deleted file mode 100644 index b798e14..0000000 Binary files a/software/CPM/CPM00_MZ800/files.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/format.com b/software/CPM/CPM00_MZ800/format.com deleted file mode 100644 index 5d39042..0000000 Binary files a/software/CPM/CPM00_MZ800/format.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/load.com b/software/CPM/CPM00_MZ800/load.com deleted file mode 100644 index b9601e0..0000000 Binary files a/software/CPM/CPM00_MZ800/load.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/pcpm.sys b/software/CPM/CPM00_MZ800/pcpm.sys deleted file mode 100644 index faebe97..0000000 Binary files a/software/CPM/CPM00_MZ800/pcpm.sys and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/pip.com b/software/CPM/CPM00_MZ800/pip.com deleted file mode 100644 index 2193dc7..0000000 Binary files a/software/CPM/CPM00_MZ800/pip.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/random.asm b/software/CPM/CPM00_MZ800/random.asm deleted file mode 100644 index d581df0..0000000 --- a/software/CPM/CPM00_MZ800/random.asm +++ /dev/null @@ -1,345 +0,0 @@ -;*************************************************** -;* * -;* sample random access program for Personal CP/M * -;* * -;*************************************************** - 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 -; -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 2.3? - mvi c,version - call bdos - cpi 20h ;version 2.3 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 - jmp reboot -; -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 -; -; -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 Personal CP/M $' -nospace: - db 'no directory space$' -datmsg: - db 'type data: $' -errmsg: - db 'error, try again.$' -prompt: - db 'next command? $' -entmsg: - db 'You must enter a filename on command line $' -; -;*************************************************** -;* * -;* 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 -; - ds 32 ;16 level stack -stack: - end - \ No newline at end of file diff --git a/software/CPM/CPM00_MZ800/setup.com b/software/CPM/CPM00_MZ800/setup.com deleted file mode 100644 index ef62086..0000000 Binary files a/software/CPM/CPM00_MZ800/setup.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/stat.com b/software/CPM/CPM00_MZ800/stat.com deleted file mode 100644 index 8d70ae2..0000000 Binary files a/software/CPM/CPM00_MZ800/stat.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/submit.com b/software/CPM/CPM00_MZ800/submit.com deleted file mode 100644 index 400ce2f..0000000 Binary files a/software/CPM/CPM00_MZ800/submit.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/terminal.asm b/software/CPM/CPM00_MZ800/terminal.asm deleted file mode 100644 index 8b5bd8f..0000000 --- a/software/CPM/CPM00_MZ800/terminal.asm +++ /dev/null @@ -1,53 +0,0 @@ -; simple minded terminal emulator (with no buffering) - org 100h -boot equ 0 -bdos equ 5 - -auxin equ 3 -auxout equ 4 -auxist equ 7 -auxost equ 8 - -dcio equ 6 -input equ 0FFh -status equ 0FEh - -term: ;start of main program -con$char: - mvi e,input ;get character or status via function #6 - mvi c,dcio - call bdos - ora a ;which returns zero to indictate nothing - jz Aux$ready$chk ;available, so branch to Auxin Stat test - - cpi 3 ;or returns the keyboard character which we - jz boot ;test for control "C" meaning exit program now. - - mov e,a -send$aux: - push d ;save character - mvi c,auxost ;call aux_out_status function - call bdos - pop d - ora a - jz send$aux ;wait for auxout to be ready - - mvi c,auxout ;send (e)'s character out Aux - call bdos - -Aux$ready$chk: - mvi c,auxist ;check if Aux has any characters available - call bdos - ora a ;if return ==false then go back to top of loop - jz con$char - - mvi c,auxin ; else, get the character from Auxin - call bdos - ani 7Fh ;mask any bit 7 parity bits - mov e,a - mvi c,dcio ; then send the character to the console - call bdos - jmp con$char ;jump back to main loop for more. - - end - \ No newline at end of file diff --git a/software/CPM/CPM00_MZ800/time.com b/software/CPM/CPM00_MZ800/time.com deleted file mode 100644 index 76dff34..0000000 Binary files a/software/CPM/CPM00_MZ800/time.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/vccp.cfg b/software/CPM/CPM00_MZ800/vccp.cfg deleted file mode 100644 index f8f7e4a..0000000 --- a/software/CPM/CPM00_MZ800/vccp.cfg +++ /dev/null @@ -1,13 +0,0 @@ -0 ;EXAMPLE 2 -;Files ;Add no.1 command -;Format ; no.2 command - ; no.3 command - ; no.4 command - ; no.5 command - ; no.6 command - ; no.7 command - ; no.8 command - ; no.9 command -;MAX COMMAND=9 -;Set number in First line - \ No newline at end of file diff --git a/software/CPM/CPM00_MZ800/vccp.com b/software/CPM/CPM00_MZ800/vccp.com deleted file mode 100644 index 3017246..0000000 Binary files a/software/CPM/CPM00_MZ800/vccp.com and /dev/null differ diff --git a/software/CPM/CPM00_MZ800/xsub.com b/software/CPM/CPM00_MZ800/xsub.com deleted file mode 100644 index 154333b..0000000 Binary files a/software/CPM/CPM00_MZ800/xsub.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/BBCBASIC.COM b/software/CPM/CPM00_SYSTEM/BBCBASIC.COM deleted file mode 100644 index a3c0ac0..0000000 Binary files a/software/CPM/CPM00_SYSTEM/BBCBASIC.COM and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/DDT.COM b/software/CPM/CPM00_SYSTEM/DDT.COM deleted file mode 100644 index ed0cf29..0000000 Binary files a/software/CPM/CPM00_SYSTEM/DDT.COM and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/ZSID-FIX.DOC b/software/CPM/CPM00_SYSTEM/ZSID-FIX.DOC deleted file mode 100644 index 6052ea7..0000000 --- a/software/CPM/CPM00_SYSTEM/ZSID-FIX.DOC +++ /dev/null @@ -1,74 +0,0 @@ - - - **************************************************************** - - PATCH TO MAKE ZSID.COM THE SAME DUMP DISPLAY AS DDT AND SID - - RESEARCH BY DATAFACS SYSTEMS, INC. - - **************************************************************** - - - DO THE FOLLOWING: - - ZSID ZSID.COM - - S125F 5F AF <--- PUT THIS IN HIT RETURN - 1260 ?? . "" - - S12C0 CD 00 <---- PUT THIS IN HIT RETURN - 12C1 ?? 00 "" - 12C2 ?? 00 "" - 12C3 06 ?? <---- LEAVE THIS ALONE - 12C4 06 01 <---- PUT THIS IN HIT RETURN - 12C5 ?? . "" - -* S12E1 CD 00 <---- PUT THIS IN HIT RETURN -* 12E2 ?? 00 "" -* 12E3 ?? 00 "" -* 12E4 CD 00 "" -* 12E5 ?? 00 "" -* 12E6 ?? 00 "" - 12E7 13 . <-- **** DONE **** - - CONTROL C OR G0 ZERO AND SAVE THE PROPER AMOUNT - - - IF YOU DON'T TRUST THIS SAVE IT AS A DIFFERENT NAME FIRST - - ******* HAVE FUN AND ENJOY ****** - -* CALLS THE SAME ADDRESS - ------------------------------------------------------------------ - -Addendum by Bob Fisher - De Paul University - -The above patch MAY work, but it depends on what address your cpm -runs at. Try instead the following: - - S125F - 125F 5F AF (SAME AS ABOVE) - 1260 ?? . - - S12C0 CD 18 (PUT IN A RELATIVE JUMP) - 12C1 ?? 01 - 12C2 ?? 00 (THIS DOESN'T MATTER) - 12C3 06 06 (DON'T CHANGE) - 12C4 06 01 - 12C5 ?? . - - S12E1 - 12E1 CD 18 (ANOTHER RELATIVE JUMP) - 12E2 ?? 04 - 12E3 ?? ?? - 12E4 CD 18 (YET ANOTHER RELATIVE JUMP) - 12E5 ?? 01 - 12E6 ?? . - -When ZSID relocates itself an offset is added to bytes 12c2, 12e3, and -12e6. The previous patch left this offset to be interpreted as an opcode. -The result can be benign or disastrous depending on the size of your -cpm. - - \ No newline at end of file diff --git a/software/CPM/CPM00_SYSTEM/ZSID-PAT.COM b/software/CPM/CPM00_SYSTEM/ZSID-PAT.COM deleted file mode 100644 index 30423c9..0000000 Binary files a/software/CPM/CPM00_SYSTEM/ZSID-PAT.COM and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/ZSID.COM b/software/CPM/CPM00_SYSTEM/ZSID.COM deleted file mode 100644 index 91f6689..0000000 Binary files a/software/CPM/CPM00_SYSTEM/ZSID.COM and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/ZSID.PAT b/software/CPM/CPM00_SYSTEM/ZSID.PAT deleted file mode 100644 index 7aa2319..0000000 --- a/software/CPM/CPM00_SYSTEM/ZSID.PAT +++ /dev/null @@ -1,37 +0,0 @@ -======== -Newsgroups: comp.os.cpm -Subject: Re: CP/M web page has new stuff -From: hp@kbbs.org (Holger Petersen) -Date: Mon, 25 Aug 1997 07:19:08 GMT - -timolmst@cyberramp.net writes: - -> Also, ZSID binary is now available. - -Could you please mention the patch from "Dr. Dobbs Journal #62, Dec 1981 -page 519: ZSID Bug and (Risky?) Patch" ? -It changed the byte at 02AE from C2 to C3. - -Befor, some adresses of FF80 to FFFF would be handled bad in (A)ssemble, -(F)ill, (M)ove and (D)ump - commands: - -A>ZSID -ZSID VERS 1.4 -#A100 -0100 LD HL,0FF7F -0103 LD HL,0FF80 -0106 LD HL,0FFFF -0109 -#L100,108 - 0100 LD HL,FF7F - 0103 LD HL,0080 - 0106 LD HL,00FF - 0109 - -=========================== - -Some months later, I got a letter from Digital Research which 'begged' -for the allowence to use this patch, which I did... - -Greetings, Holger - diff --git a/software/CPM/CPM00_SYSTEM/ZSID_ORIG.COM b/software/CPM/CPM00_SYSTEM/ZSID_ORIG.COM deleted file mode 100644 index 221c0ae..0000000 Binary files a/software/CPM/CPM00_SYSTEM/ZSID_ORIG.COM and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/asciart.bas b/software/CPM/CPM00_SYSTEM/asciart.bas deleted file mode 100644 index dc90e8d..0000000 --- a/software/CPM/CPM00_SYSTEM/asciart.bas +++ /dev/null @@ -1,23 +0,0 @@ -1 REM asciiart.bas benchmark for Rienk's sbc-2g-512 7.3728Mhz Z80 board running NASCOM ROM BASIC Ver 4.7 -2 REM https://www.retrobrewcomputers.org/forum/index.php?t=msg&th=201&goto=4704&#msg_4704 -3 REM 2m43s -4 REM -10 FOR Y=-12 TO 12 -20 FOR X=-39 TO 39 -30 CA=X*0.0458 -40 CB= Y*0.08333 -50 A=CA -60 B=CB -70 FOR I=0 TO 15 -80 T=A*A-B*B+CA -90 B=2*A*B+CB -100 A=T -110 IF (A*A+B*B)>4 THEN GOTO 200 -120 NEXT I -130 PRINT " "; -140 GOTO 210 -200 IF I>9 THEN I=I+7 -205 PRINT CHR$(48+I); -210 NEXT X -220 PRINT -230 NEXT Y diff --git a/software/CPM/CPM00_SYSTEM/asm.com b/software/CPM/CPM00_SYSTEM/asm.com deleted file mode 100644 index a63e5ae..0000000 Binary files a/software/CPM/CPM00_SYSTEM/asm.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/autoexec.sub b/software/CPM/CPM00_SYSTEM/autoexec.sub deleted file mode 100644 index 54fa4d7..0000000 --- a/software/CPM/CPM00_SYSTEM/autoexec.sub +++ /dev/null @@ -1,3 +0,0 @@ -type autoexec.txt -mbasic userled - \ No newline at end of file diff --git a/software/CPM/CPM00_SYSTEM/autoexec.txt b/software/CPM/CPM00_SYSTEM/autoexec.txt deleted file mode 100644 index fda563d..0000000 --- a/software/CPM/CPM00_SYSTEM/autoexec.txt +++ /dev/null @@ -1,12 +0,0 @@ -************************************************************************ - -This is an example to show how the Autoexec feature works. -When you activate it from the "boot mode or system parameters" IOS menu -all the CP/M commands inside the file A:AUTOEXEC.SUB will be executed -when (after) there is a CP/M cold boot. -The A:AUTOEXEC.SUB commands file is not executed after a CP/M warm -boot (Ctrl+C). -To change the commands executed after a CP/M cold boot edit the file -A:AUTOEXEC.SUB using the ED editor. - -************************************************************************ \ No newline at end of file diff --git a/software/CPM/CPM00_SYSTEM/d.com b/software/CPM/CPM00_SYSTEM/d.com deleted file mode 100644 index fcf34eb..0000000 Binary files a/software/CPM/CPM00_SYSTEM/d.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/ddt.com b/software/CPM/CPM00_SYSTEM/ddt.com deleted file mode 100644 index 83f8603..0000000 Binary files a/software/CPM/CPM00_SYSTEM/ddt.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/dump.com b/software/CPM/CPM00_SYSTEM/dump.com deleted file mode 100644 index 03a77c3..0000000 Binary files a/software/CPM/CPM00_SYSTEM/dump.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/ed.com b/software/CPM/CPM00_SYSTEM/ed.com deleted file mode 100644 index a0f0f54..0000000 Binary files a/software/CPM/CPM00_SYSTEM/ed.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/genhex.com b/software/CPM/CPM00_SYSTEM/genhex.com deleted file mode 100644 index 8314d35..0000000 Binary files a/software/CPM/CPM00_SYSTEM/genhex.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/gpeled.bas b/software/CPM/CPM00_SYSTEM/gpeled.bas deleted file mode 100644 index a328e9d..0000000 --- a/software/CPM/CPM00_SYSTEM/gpeled.bas +++ /dev/null @@ -1,61 +0,0 @@ -01 REM ************************************************ -02 REM -03 REM Z80-MBC2 GPE led blink demo: -04 REM -05 REM Blink a led attached to PIN 8 (GPA5) of the GPIO -06 REM connector (J7) until USER key is pressed -07 REM (see A040618 schematic). -08 REM The GPE option must be installed. -09 REM -10 REM ************************************************ -11 REM -12 REM Demo HW wiring (see A040618 schematic): -13 REM -14 REM GPIO -15 REM (J7) -16 REM +-----+ -17 REM | 1 2 | -18 REM | 3 4 | LED RESISTOR -19 REM | 5 6 | 680 -20 REM | 7 8-+--->|-----------/\/\/--+ -21 REM | 9 10| | -22 REM |11 12| | -23 REM |13 14| | -24 REM |15 16| | -25 REM |17 18| | -26 REM |19 20+-----------------------+ GND -27 REM +-----+ -28 REM -29 REM ************************************************ -30 REM -31 PRINT "Press USER key to exit" -32 REM -33 REM * * * * SET USED OPCODES FOR I/O -34 REM -35 KEYUSER = 128 : REM USER KEY read Opcode (0x80) -36 IODIRA = 5 : REM IODIRA write Opcode (0x05) -37 GPIOA = 3 : REM GPIOA write Opcode (0x03) -38 REM -50 OUT 1,IODIRA : OUT 0,0 : REM Set all GPAx as output (IODIRA=0x00) -60 PRINT "Now blinking GPA5 (GPIO port pin 8)..." -64 REM -65 REM * * * * * BLINK LOOP -66 REM -70 OUT 1,GPIOA : OUT 0,32 : REM Set GPA5=1, GPAx=0 (GPIOA=B00100000=32) -80 GOSUB 505 : REM Delay sub -90 OUT 1,GPIOA : OUT 0,0 : REM Clear all pins GPAx (MCP23017) -100 GOSUB 505 : REM Delay sub -130 GOTO 70 -490 REM -500 REM * * * * * DELAY SUB -501 REM -505 FOR J=0 TO 150 -506 OUT 1,KEYUSER : REM Write the USER KEY read Opcode -507 IF INP(0)=1 THEN GOTO 700 : REM Exit if USER key is pressed -510 NEXT J -520 RETURN -690 REM -691 REM * * * * * PROGRAM END -692 REM -700 OUT 1,GPIOA : OUT 0,0 : REM Clear all pins GPAx (MCP23017) -720 PRINT "Terminated by USER Key" diff --git a/software/CPM/CPM00_SYSTEM/gpio.bas b/software/CPM/CPM00_SYSTEM/gpio.bas deleted file mode 100644 index 740555f..0000000 --- a/software/CPM/CPM00_SYSTEM/gpio.bas +++ /dev/null @@ -1,82 +0,0 @@ -1 REM * * * GPIO EXPANSION MODULE (A080117) DEMO * * * -2 REM -3 REM (USER Key -> slow led, GPIO-A(9) Key -> fast led) -4 REM -------------------------------------------------- -5 REM Demo HW wiring (see A080117 schematic): -6 REM -7 REM GPIO-B -8 REM (J3) -9 REM +----+ LED -10 REM | 2 |--->|---+ -11 REM | 3 |--->|---+ RESISTOR -12 REM | 4 |--->|---+ 680 -13 REM | 5 |--->|---+-------/\/\/-----o GND -14 REM | 6 |--->|---+ -15 REM | 7 |--->|---+ -16 REM | 8 |--->|---+ -17 REM | 9 |--->|---+ -18 REM +----+ | -19 REM | -20 REM | -21 REM GPIO-A | -22 REM (J4) | -23 REM +----+ LED | -24 REM | 2 |--->|---+ -25 REM | 3 |--->|---+ -26 REM | 4 |x -27 REM | 5 |x -28 REM | 6 |x -29 REM | 7 |x PUSH BUTTON RESISTOR -30 REM | 8 |x --- 1K -31 REM | 9 |---------o o------------------/\/\/-----o GND -32 REM +----+ -33 REM -34 REM -35 REM -36 REM -------------------------------------------------- -37 REM -38 REM Set MCP23017 GPIOB all pins as output (IODIRB=0x00) -39 OUT 6, 0 -40 REM Set MCP23017 GPIOA 0-1 as output, others as input (IODIRA=0xFC) -41 OUT 5, 252 -42 REM Set MCP23017 GPIOA 2-7 pull-up resistor on (GPPUA=0xFC) -43 OUT 7, 252 -45 REM Left Shift user funcion definition -50 DEF FNLSH(X)=((X*2) AND 255) -55 REM Init GPIO output ports -60 OUT 3, 0 : REM Clear MCP23017 GPIOA port -62 OUT 4, 0 : REM Clear MCP23017 GPIOB port -64 GOSUB 700 : REM Set slow shift -68 REM Main -70 A=1 -80 FOR I=0 TO 7 -90 OUT 4, A : REM Write to MCP23017 GPIOB port -100 GOSUB 500 -110 A=FNLSH(A) -120 NEXT I -130 OUT 4, 0 : REM Clear MCP23017 GPIOB port -135 A=1 -140 FOR I=0 TO 1 -150 OUT 3, A : REM Write to MCP23017 GPIOA port -160 GOSUB 500 -170 A=FNLSH(A) -190 NEXT I -200 OUT 3, 0 : REM Clear MCP23017 GPIOA port -210 GOTO 70 : REM Play it again, Sam... -220 REM -500 REM * * * * * DELAY SUB -505 FOR J=0 TO K -507 IF INP(0)=1 THEN GOSUB 700 : REM Read USER key -508 IF (INP(3) AND 128)=0 THEN GOSUB 600 : REM Read MCP23017 GPIOA 7 key -510 NEXT J -520 RETURN -530 REM -600 REM * * * * * SET FAST SHIFT SUB -610 K=1 -620 OUT 0, 1 : REM USER led ON -630 RETURN -640 REM -700 REM * * * * * SET SLOW SHIFT SUB -710 K=30 -720 OUT 0, 0 : REM USER led OFF -730 RETURN diff --git a/software/CPM/CPM00_SYSTEM/hello.asm b/software/CPM/CPM00_SYSTEM/hello.asm deleted file mode 100644 index bfdb81b..0000000 --- a/software/CPM/CPM00_SYSTEM/hello.asm +++ /dev/null @@ -1,33 +0,0 @@ -;This is a example of the Hello World program. -;Uses 8080 assembler mnemonics. - ORG 100h ;cpm programs start address. - JMP START ;go to program start. -;Variable storage space -MsgStr: DB 13,10,'Hello world.',13,10,0 -Stack1: DW 0 ;place to save old stack. -SBOT: DS 32 ;temp stack for us to use. -;Constants -STOP: EQU $-1 ;top of our stack. -BDOS: EQU 5 ;address of BDOS entry. -;Start of code segment -START: LXI H, 0 ;HL = 0. - DAD SP ;HL = SP. - SHLD Stack1 ;save original stack. - LXI H, STOP ;HL = address of new stack top.? - SPHL ;stack pointer = our stack. - LXI H, MsgStr ;HL = address of staring. - LOOP1: MOV A, M ;read string char. - ORA A ;set cpu flags. - JZ EXIT ;if char = 0 done. - MOV E, A ;E = char to send. - MVI C, 2 ;we want BDOS func 2. - PUSH H ;save HL register. - CALL BDOS ;call BDOS function. - POP H ;restore HL register - INX H ;point to next char. - JMP LOOP1 ;do next char. -;Exit and return code -EXIT: LHLD Stack1 ;read our original stack address. - SPHL ;register SP = value on entry. - RET ;return control back to CPM. - END \ No newline at end of file diff --git a/software/CPM/CPM00_SYSTEM/hello.com b/software/CPM/CPM00_SYSTEM/hello.com deleted file mode 100644 index 4a077dc..0000000 Binary files a/software/CPM/CPM00_SYSTEM/hello.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/load.com b/software/CPM/CPM00_SYSTEM/load.com deleted file mode 100644 index b9601e0..0000000 Binary files a/software/CPM/CPM00_SYSTEM/load.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/mac.com b/software/CPM/CPM00_SYSTEM/mac.com deleted file mode 100644 index 8505de9..0000000 Binary files a/software/CPM/CPM00_SYSTEM/mac.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/mbasic.com b/software/CPM/CPM00_SYSTEM/mbasic.com deleted file mode 100644 index 4bd7f5d..0000000 Binary files a/software/CPM/CPM00_SYSTEM/mbasic.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/mbasic85.com b/software/CPM/CPM00_SYSTEM/mbasic85.com deleted file mode 100644 index a3a50d3..0000000 Binary files a/software/CPM/CPM00_SYSTEM/mbasic85.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/peg.com b/software/CPM/CPM00_SYSTEM/peg.com deleted file mode 100644 index be8ec2a..0000000 Binary files a/software/CPM/CPM00_SYSTEM/peg.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/pip.com b/software/CPM/CPM00_SYSTEM/pip.com deleted file mode 100644 index a0f3c75..0000000 Binary files a/software/CPM/CPM00_SYSTEM/pip.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/rtc.bas b/software/CPM/CPM00_SYSTEM/rtc.bas deleted file mode 100644 index 8b6ce26..0000000 --- a/software/CPM/CPM00_SYSTEM/rtc.bas +++ /dev/null @@ -1,19 +0,0 @@ -15 OUT 1,132 : REM Write the DATETIME read Opcode -20 SEC = INP(0) : REM Read a RTC parameter -30 MINUTES = INP(0) : REM Read a RTC parameter -40 HOURS = INP(0) : REM Read a RTC parameter -50 DAY = INP(0) : REM Read a RTC parameter -60 MNTH = INP(0) : REM Read a RTC parameter -70 YEAR = INP(0) : REM Read a RTC parameter -80 TEMP = INP(0) : REM Read a RTC parameter -83 IF TEMP < 128 THEN 90 : REM Two complement correction -85 TEMP = TEMP - 256 -90 PRINT -100 PRINT "THE TIME IS: "; -110 PRINT HOURS; : PRINT ":"; : PRINT MINUTES; : PRINT ":"; : PRINT SEC -120 PRINT "THE DATE IS: "; -125 YEAR= YEAR+ 2000 -130 PRINT DAY; : PRINT "/"; : PRINT MNTH; : PRINT "/"; : PRINT YEAR -135 PRINT "THE TEMPERATURE IS: "; -140 PRINT TEMP; : PRINT "C" -145 PRINT diff --git a/software/CPM/CPM00_SYSTEM/startrek.bas b/software/CPM/CPM00_SYSTEM/startrek.bas deleted file mode 100644 index 64d0170..0000000 --- a/software/CPM/CPM00_SYSTEM/startrek.bas +++ /dev/null @@ -1,446 +0,0 @@ -10 REM SUPER STARTREK - MAY 16,1978 - REQUIRES 24K MEMORY (AT LEAST) -30 REM -40 REM **** **** STAR TREK **** **** -50 REM **** SIMULATION OF A MISSION OF THE STARSHIP ENTERPRISE, -60 REM **** AS SEEN ON THE STAR TREK TV SHOW. -70 REM **** ORIGINAL PROGRAM BY MIKE MAYFIELD, MODIFIED VERSION -80 REM **** PUBLISHED IN DEC'S "101 BASIC GAMES", BY DAVE AHL. -90 REM **** MODIFICATIONS TO THE LATTER (PLUS DEBUGGING) BY BOB -100 REM *** LEEDOM - APRIL & DECEMBER 1974, -110 REM *** WITH A LITTLE HELP FROM HIS FRIENDS . . . -120 REM *** COMMENTS, EPHITETS, AND SUGGESTIONS SOLICITED -- -130 REM *** SEND TO: R.C. LEEDOM -140 REM *** WESTINGHOSE DEFENSE & ELECTRONICS SYSTEMS CNIR -150 REM *** BOX 746, M.S. 338 -160 REM *** BALTIMORE, MD 21203 -170 REM *** -180 REM *** CONVERTED TO MICROSOFT 8 K BASIC 3/16/78 BY JOHN BORDERS -190 REM *** LINE NUMBERS FROM VERSION TREK7 OF 1/12/75 PRESERVED AS -200 REM *** MUCH AS POSSIBLE WHILE USING MULTIPLE STATEMENTS PER LINE -201 REM *** - MODIFIED TO RUN ON GRANT SEARLE'S 9-CHIP Z80 COMPUTER -202 REM *** AND DERIVATIVES 04-AUG-2018 BY N.KENDRICK -203 REM *** (LINKER3000-AT-GMAIL.COM) -205 WIDTH 80 -209 REM NK: POSITIONING USING ANSI ESCAPE SEQUENCES... -210 PRINT CHR$(27);"[2J";:PRINT CHR$(27);"[3;1H"; -211 PRINT "THE USS ENTERPRISE --- NCC-1701" -212 PRINT CHR$(27);"[4;1H";:PRINT -222 FOR YY=1 TO 40 STEP 2:FOR XX=1 TO 200 : NEXT XX -223 PRINT TAB(YY);" ,------*------," -224 PRINT TAB(YY);" ,------------- '--- ------'" -225 PRINT TAB(YY);" '-------- --' / /" -226 PRINT TAB(YY);" ,---' '-------/ /--," -227 PRINT TAB(YY);" '----------------'" -228 PRINT CHR$(27);"[4;1H";:PRINT:NEXT YY -229 PRINT CHR$(27);"[11;1H"; -260 CLEAR 600 -270 Z$=" " -330 DIM G(8,8),C(9,2),K(3,3),N(3),Z(8,8),D(8) -370 T=INT(RND(1)*20+20)*100:T0=T:T9=25+INT(RND(1)*10):D0=0:E=3000:E0=E -440 P=10:P0=P:S9=200:S=0:B9=0:K9=0:X$="":X0$=" IS " -470 DEF FND(D)=SQR((K(I,1)-S1)^2+(K(I,2)-S2)^2) -475 DEF FNR(R)=INT(RND(R)*7.98+1.01) -490 Q1=FNR(1):Q2=FNR(1):S1=FNR(1):S2=FNR(1) -530 FOR I=1 TO 9:C(I,1)=0:C(I,2)=0:NEXT I -540 C(3,1)=-1:C(2,1)=-1:C(4,1)=-1:C(4,2)=-1:C(5,2)=-1:C(6,2)=-1 -600 C(1,2)=1:C(2,2)=1:C(6,1)=1:C(7,1)=1:C(8,1)=1:C(8,2)=1:C(9,2)=1 -670 FOR I=1 TO 8:D(I)=0:NEXT I -710 A1$="NAVSRSLRSPHATORSHEDAMCOMXXX" -820 FOR I=1 TO 8:FOR J=1 TO 8:K3=0:Z(I,J)=0:R1=RND(1) -850 IF R1>.98 THEN K3=3:K9=K9+3:GOTO 980 -860 IF R1>.95 THEN K3=2:K9=K9+2:GOTO 980 -870 IF R1>.8 THEN K3=1:K9=K9+1 -980 B3=0:IF RND(1)>.96 THEN B3=1:B9=B9+1 -1040 G(I,J)=K3*100+B3*10+FNR(1):NEXT J:NEXT I:IF K9>T9 THEN T9=K9+1 -1100 IF B9<>0 THEN 1200 -1150 IF G(Q1,Q2)<200 THEN G(Q1,Q2)=G(Q1,Q2)+100:K9=K9+1 -1160 B9=1:G(Q1,Q2)=G(Q1,Q2)+10:Q1=FNR(1):Q2=FNR(1) -1200 K7=K9:IF B9<>1 THEN X$="S":X0$=" ARE " -1230 PRINT"YOUR ORDERS ARE AS FOLLOWS:" -1235 PRINT "--------------------------" -1240 PRINT" DESTROY THE";K9;"KLINGON WARSHIPS WHICH HAVE INVADED" -1250 PRINT" THE GALAXY BEFORE THEY CAN ATTACK FEDERATION HEADQUARTERS" -1260 PRINT" ON STARDATE";T0+T9;CHR$(8);". THIS GIVES YOU";T9; -1261 PRINT"DAYS. THERE";X0$ -1270 PRINT" ";B9; -1271 PRINT"STARBASE";X$;" IN THE GALAXY FOR RESUPPLYING YOUR SHIP." -1280 PRINT: PRINT "PRESS Y TO ACCEPT COMMAND"; -1300 INPUT I5$: -1302 IF LEFT$(I5$,1)="Y" OR LEFT$(I5$,1)="y" THEN 1310 -1303 GOTO 1280 -1310 PRINT CHR$(26) -1320 Z4=Q1:Z5=Q2:K3=0:B3=0:S3=0:G5=0:D4=.5*RND(1):Z(Q1,Q2)=G(Q1,Q2) -1390 IF Q1<1 OR Q1>8 OR Q2<1 OR Q2>8 THEN 1600 -1430 GOSUB 9030:PRINT:IF T0<>T THEN 1490 -1460 PRINT"YOUR MISSION BEGINS WITH YOUR STARSHIP LOCATED" -1470 PRINT"IN THE GALACTIC QUADRANT, '";G2$;"'.":GOTO 1500 -1490 PRINT"NOW ENTERING ";G2$;" QUADRANT . . ." -1500 PRINT:K3=INT(G(Q1,Q2)*.01):B3=INT(G(Q1,Q2)*.1)-10*K3 -1540 S3=G(Q1,Q2)-100*K3-10*B3:IF K3=0 THEN 1590 -1560 PRINT TAB(3);CHR$(22);" COMBAT AREA CONDITION RED ";CHR$(22) -1561 IF S>200 THEN PRINT:GOTO 1590 -1580 PRINT TAB(3);CHR$(22);" SHIELDS DANGEROUSLY LOW ";CHR$(22) -1581 PRINT -1590 FOR I=1 TO 3:K(I,1)=0:K(I,2)=0:NEXT I -1600 FOR I=1 TO 3:K(I,3)=0:NEXT I:Q$=Z$+Z$+Z$+Z$+Z$+Z$+Z$+LEFT$(Z$,17) -1680 A$="":Z1=S1:Z2=S2:GOSUB 8670:IF K3<1 THEN 1820 -1720 FOR I=1 TO K3:GOSUB 8590:A$="+K+":Z1=R1:Z2=R2 -1780 GOSUB 8670:K(I,1)=R1:K(I,2)=R2:K(I,3)=S9*(.5+RND(1)):NEXT I -1820 IF B3<1 THEN 1910 -1880 GOSUB 8590:A$=">B<":Z1=R1:B4=R1:Z2=R2:B5=R2:GOSUB 8670 -1910 FOR I=1 TO S3:GOSUB 8590:A$=" * ":Z1=R1:Z2=R2:GOSUB 8670:NEXT I -1980 GOSUB 6430 -1990 IF S+E>10 THEN IF E>10 OR D(7)=0 THEN 2060 -2020 PRINT:PRINT TAB(10);CHR$(22);"** FATAL ERROR **";CHR$(22) -2021 PRINT"YOU'VE JUST STRANDED YOUR SHIP IN SPACE." -2030 PRINT"YOU HAVE INSUFFICIENT MANEUVERING ENERGY," -2040 PRINT"AND SHIELD CONTROL IS PRESENTLY INCAPABLE OF" -2050 PRINT"CROSS-CIRCUITING TO ENGINE ROOM!!":PRINT:GOTO 6220 -2060 PRINT:INPUT"COMMAND";A$:PRINT -2080 FOR I=1 TO 9:IF LEFT$(A$,3)<>MID$(A1$,3*I-2,3)THEN 2160 -2140 ON I GOTO 2300,1980,4000,4260,4700,5530,5690,7290,6270 -2160 NEXT I:PRINT"ENTER ONE OF THE FOLLOWING:" -2170 PRINT "--------------------------" -2180 PRINT" NAV (TO SET COURSE)" -2190 PRINT" SRS (FOR SHORT RANGE SENSOR SCAN)" -2200 PRINT" LRS (FOR LONG RANGE SENSOR SCAN)" -2210 PRINT" PHA (TO FIRE PHASERS)" -2220 PRINT" TOR (TO FIRE PHOTON TORPEDOES)" -2230 PRINT" SHE (TO RAISE OR LOWER SHIELDS)" -2240 PRINT" DAM (FOR DAMAGE CONTROL REPORTS)" -2250 PRINT" COM (TO CALL ON LIBRARY-COMPUTER)" -2260 PRINT" XXX (TO RESIGN YOUR COMMAND)":PRINT:GOTO 1990 -2300 INPUT"COURSE (0-9)";C1:IF C1=9 THEN C1=1 -2310 IF C1>=1 AND C1<9 THEN 2350 -2330 PRINT" LT. SULU: 'INCORRECT COURSE DATA, SIR!'":GOTO 1990 -2350 X$="8":IF D(1)<0 THEN X$="0.2" -2360 PRINT"WARP FACTOR (0-";X$;")";:INPUT W1:PRINT -2361 IF D(1)<0 AND W1>.2 THEN 2470 -2380 IF W1>0 AND W1<=8 THEN 2490 -2390 IF W1=0 THEN 1990 -2420 PRINT" CHIEF ENGINEER SCOTT: 'THE ENGINES WON'T TAKE"; -2430 PRINT" WARP";W1;CHR$(8);"!'":GOTO 1990 -2470 PRINT"WARP ENGINES ARE DAMAGED. MAXIUM SPEED = WARP 0.2":GOTO 1990 -2490 N=INT(W1*8+.5):IF E-N>=0 THEN 2590 -2500 PRINT"ENGINEERING: 'INSUFFICIENT ENERGY AVAILABLE" -2510 PRINT" FOR MANEUVERING AT WARP";W1;CHR$(8);"!'" -2530 IF S=1 THEN D6=1 -2770 FOR I=1 TO 8:IF D(I)>=0 THEN 2880 -2790 D(I)=D(I)+D6:IF D(I)>-.1 AND D(I)<0 THEN D(I)=-.1:GOTO 2880 -2800 IF D(I)<0 THEN 2880 -2810 IF D1<>1 THEN D1=1:PRINT"DAMAGE CONTROL REPORT: "; -2840 PRINT TAB(8);:R1=I:GOSUB 8790:PRINT G2$;" REPAIR COMPLETED." -2880 NEXT I:IF RND(1)>.2 THEN 3070 -2910 R1=FNR(1):IF RND(1)>=.6 THEN 3000 -2930 D(R1)=D(R1)-(RND(1)*5+1):PRINT"DAMAGE CONTROL REPORT: "; -2960 GOSUB 8790:PRINT G2$;" DAMAGED":PRINT:GOTO 3070 -3000 D(R1)=D(R1)+RND(1)*3+1:PRINT"DAMAGE CONTROL REPORT: "; -3030 GOSUB 8790:PRINT G2$;" STATE OF REPAIR IMPROVED":PRINT -3070 A$=" ":Z1=INT(S1):Z2=INT(S2):GOSUB 8670 -3110 X1=C(C1,1)+(C(C1+1,1)-C(C1,1))*(C1-INT(C1)):X=S1:Y=S2 -3140 X2=C(C1,2)+(C(C1+1,2)-C(C1,2))*(C1-INT(C1)):Q4=Q1:Q5=Q2 -3170 FOR I=1 TO N:S1=S1+X1:S2=S2+X2 -3171 IF S1<1 OR S1>=9 OR S2<1 OR S2>=9 THEN 3500 -3240 S8=INT(S1)*24+INT(S2)*3-26:IF MID$(Q$,S8,2)=" "THEN 3360 -3320 S1=INT(S1-X1):S2=INT(S2-X2):PRINT"WARP ENGINES SHUT DOWN AT "; -3350 PRINT"SECTOR";S1;CHR$(8);",";S2;"DUE TO BAD NAVIGATION":GOTO 3370 -3360 NEXT I:S1=INT(S1):S2=INT(S2) -3370 A$="":Z1=INT(S1):Z2=INT(S2):GOSUB 8670:GOSUB 3910:T8=1 -3430 IF W1<1 THEN T8=.1*INT(10*W1) -3450 T=T+T8:IF T>T0+T9 THEN 6220 -3480 GOTO 1980 -3500 X=8*Q1+X+N*X1:Y=8*Q2+Y+N*X2:Q1=INT(X/8):Q2=INT(Y/8):S1=INT(X-Q1*8) -3550 S2=INT(Y-Q2*8):IF S1=0 THEN Q1=Q1-1:S1=8 -3590 IF S2=0 THEN Q2=Q2-1:S2=8 -3620 X5=0:IF Q1<1 THEN X5=1:Q1=1:S1=1 -3670 IF Q1>8 THEN X5=1:Q1=8:S1=8 -3710 IF Q2<1 THEN X5=1:Q2=1:S2=1 -3750 IF Q2>8 THEN X5=1:Q2=8:S2=8 -3790 IF X5=0 THEN 3860 -3800 PRINT"LT. UHURA: MESSAGE FROM STARFLEET COMMAND --" -3810 PRINT" 'PERMISSION TO ATTEMPT CROSSING OF GALACTIC PERIMETER" -3820 PRINT" IS HEREBY *DENIED*. SHUT DOWN YOUR ENGINES.'" -3830 PRINT"CHIEF ENGINEER SCOTT: 'WARP ENGINES SHUT DOWN" -3840 PRINT" AT SECTOR";S1;CHR$(8);",";S2;"OF QUADRANT"; -3841 PRINT Q1;CHR$(8);",";Q2;CHR$(8);".'" -3850 IF T>T0+T9 THEN 6220 -3860 IF 8*Q1+Q2=8*Q4+Q5 THEN 3370 -3870 T=T+1:GOSUB 3910:GOTO 1320 -3910 E=E-N-10:IF E>=0 THEN RETURN -3930 PRINT"SHIELD CONTROL SUPPLIES ENERGY TO COMPLETE THE MANEUVER." -3940 S=S+E:E=0:IF S<=0 THEN S=0 -3980 RETURN -4000 IF D(3)<0 THEN PRINT"LONG RANGE SENSORS ARE INOPERABLE.":GOTO 1990 -4030 PRINT"LONG RANGE SCAN FOR QUADRANT";Q1;CHR$(8);",";Q2:PRINT -4040 O1$="-------------------":PRINT O1$ -4060 FOR I=Q1-1 TO Q1+1:N(1)=-1:N(2)=-2:N(3)=-3:FOR J=Q2-1 TO Q2+1 -4120 IF I>0 AND I<9 AND J>0 AND J<9 THEN N(J-Q2+2)=G(I,J):Z(I,J)=G(I,J) -4180 NEXT J:FOR L=1 TO 3:PRINT"| "; -4181 IF N(L)<0 THEN PRINT"*** ";:GOTO 4230 -4210 PRINT RIGHT$(STR$(N(L)+1000),3);" "; -4230 NEXT L:PRINT"|":PRINT O1$:NEXT I:GOTO 1990 -4260 IF D(4)<0 THEN PRINT"PHASERS INOPERATIVE.":GOTO 1990 -4265 IF K3>0 THEN 4330 -4270 PRINT"SCIENCE OFFICER SPOCK: 'SENSORS SHOW NO ENEMY SHIPS" -4280 PRINT" IN THIS QUADRANT'":GOTO 1990 -4330 IF D(8)<0 THEN PRINT"COMPUTER FAILURE HAMPERS ACCURACY." -4350 PRINT"PHASERS LOCKED ON TARGET; "; -4360 PRINT"ENERGY AVAILABLE =";E;"UNITS" -4370 INPUT"NUMBER OF UNITS TO FIRE";X:IF X<=0 THEN 1990 -4400 IF E-X<0 THEN 4360 -4410 E=E-X:IF D(7)<0 THEN X=X*RND(1) -4450 H1=INT(X/K3):FOR I=1 TO 3:IF K(I,3)<=0 THEN 4670 -4480 H=INT((H1/FND(0))*(RND(1)+2)):IF H>.15*K(I,3)THEN 4530 -4500 PRINT"SENSORS SHOW NO DAMAGE TO ENEMY AT";K(I,1);CHR$(8); -4501 PRINT",";K(I,2);CHR$(8);".":GOTO 4670 -4530 K(I,3)=K(I,3)-H:PRINT H;"UNIT HIT ON KLINGON AT SECTOR"; -4531 PRINT K(I,1);CHR$(8);","; -4550 PRINT K(I,2);CHR$(8);".":IF K(I,3)<=0 THEN PRINT:PRINT CHR$(22); -4551 PRINT"*** KLINGON DESTROYED ***";CHR$(22):PRINT:GOTO 4580 -4560 PRINT" (SENSORS SHOW";K(I,3);"UNITS REMAINING)":GOTO 4670 -4580 K3=K3-1:K9=K9-1:Z1=K(I,1):Z2=K(I,2):A$=" ":GOSUB 8670 -4650 K(I,3)=0:G(Q1,Q2)=G(Q1,Q2)-100:Z(Q1,Q2)=G(Q1,Q2):IF K9<=0 THEN 6370 -4670 NEXT I:GOSUB 6000:GOTO 1990 -4700 IF P<=0 THEN PRINT"ALL PHOTON TORPEDOES EXPENDED.":GOTO 1990 -4730 IF D(5)<0 THEN PRINT"PHOTON TUBES ARE NOT OPERATIONAL.":GOTO 1990 -4760 INPUT"PHOTON TORPEDO COURSE (1-9)";C1:IF C1=9 THEN C1=1 -4780 IF C1>=1 AND C1<9 THEN 4850 -4790 PRINT"ENSIGN CHEKOV: 'INCORRECT COURSE DATA, SIR!'" -4800 GOTO 1990 -4850 X1=C(C1,1)+(C(C1+1,1)-C(C1,1))*(C1-INT(C1)):E=E-2:P=P-1 -4860 X2=C(C1,2)+(C(C1+1,2)-C(C1,2))*(C1-INT(C1)):X=S1:Y=S2 -4910 PRINT"TORPEDO TRACK:" -4920 X=X+X1:Y=Y+X2:X3=INT(X+.5):Y3=INT(Y+.5) -4960 IF X3<1 OR X3>8 OR Y3<1 OR Y3>8 THEN 5490 -5000 PRINT" ";X3;CHR$(8);",";Y3:A$=" ":Z1=X:Z2=Y -5001 GOSUB 8830 -5050 IF Z3<>0 THEN 4920 -5060 A$="+K+":Z1=X:Z2=Y:GOSUB 8830:IF Z3=0 THEN 5210 -5110 PRINT:PRINT CHR$(22);"*** KLINGON DESTROYED ***";CHR$(22) -5111 PRINT:K3=K3-1:K9=K9-1:IF K9<=0 THEN 6370 -5150 FOR I=1 TO 3:IF X3=K(I,1)AND Y3=K(I,2)THEN 5190 -5180 NEXT I:I=3 -5190 K(I,3)=0:GOTO 5430 -5210 A$=" * ":Z1=X:Z2=Y:GOSUB 8830:IF Z3=0 THEN 5280 -5260 PRINT"STAR AT";X3;",";Y3;"ABSORBED TORPEDO ENERGY.":GOSUB 6000 -5261 GOTO 1990 -5280 A$=">!<":Z1=X:Z2=Y:GOSUB 8830:IF Z3=0 THEN 4760 -5330 PRINT CHR$(22);"*** STARBASE DESTROYED ***";CHR$(22) -5331 B3=B3-1:B9=B9-1 -5360 IF B9>0 OR K9>T-T0-T9 THEN 5400 -5370 PRINT"THAT DOES IT, CAPTAIN!! YOU ARE HEREBY RELIEVED OF COMMAND" -5380 PRINT"AND SENTENCED TO 99 STARDATES AT HARD LABOR ON CYGNUS 12!!" -5390 GOTO 6270 -5400 PRINT"STARFLEET COMMAND REVIEWING YOUR RECORD TO CONSIDER" -5410 PRINT"COURT MARTIAL!":D0=0 -5430 Z1=X:Z2=Y:A$=" ":GOSUB 8670 -5470 G(Q1,Q2)=K3*100+B3*10+S3:Z(Q1,Q2)=G(Q1,Q2):GOSUB 6000:GOTO 1990 -5490 PRINT"TORPEDO MISSED.":PRINT:GOSUB 6000:GOTO 1990 -5530 IF D(7)<0 THEN PRINT"SHIELD CONTROL INOPERABLE.":GOTO 1990 -5560 PRINT"ENERGY AVAILABLE =";E+S;:INPUT"NUMBER OF UNITS TO SHIELDS";X -5580 IF X<0 OR S=X THEN PRINT"":GOTO 1990 -5590 IF X<=E+S THEN 5630 -5600 PRINT"SHIELD CONTROL: 'THIS IS NOT THE FEDERATION TREASURY.'" -5610 PRINT"":GOTO 1990 -5630 E=E+S-X:S=X:PRINT"DEFLECTOR CONTROL ROOM:" -5660 PRINT" 'SHIELDS NOW AT";INT(S);"UNITS PER YOUR COMMAND.'" -5661 GOTO 1990 -5690 IF D(6)>=0 THEN 5910 -5700 PRINT"DAMAGE CONTROL REPORT NOT AVAILABLE.":IF D0=0 THEN 1990 -5720 D3=0:FOR I=1 TO 8:IF D(I)<0 THEN D3=D3+.1 -5760 NEXT I:IF D3=0 THEN 1990 -5780 PRINT:D3=D3+D4:IF D3>=1 THEN D3=.9 -5810 PRINT"TECHNICIANS STANDING BY TO EFFECT REPAIRS TO YOUR SHIP;" -5820 PRINT"ESTIMATED TIME TO REPAIR:";.01*INT(100*D3);"STARDATES." -5840 INPUT"WILL YOU AUTHORIZE THE REPAIR ORDER (Y/N)";A$ -5860 IF A$<>"Y"THEN 1990 -5870 FOR I=1 TO 8:IF D(I)<0 THEN D(I)=0 -5890 NEXT I:T=T+D3+.1 -5910 PRINT:PRINT"DEVICE STATE OF REPAIR" -5911 PRINT"------ ---------------":FOR R1=1 TO 8 -5920 GOSUB 8790:PRINT G2$;LEFT$(Z$,25-LEN(G2$));INT(D(R1)*100)*.01 -5950 NEXT R1:PRINT:IF D0<>0 THEN 5720 -5980 GOTO 1990 -6000 IF K3<=0 THEN RETURN -6010 IF D0<>0 THEN PRINT"STARBASE SHIELDS PROTECT THE ENTERPRISE." -6011 RETURN -6040 FOR I=1 TO 3:IF K(I,3)<=0 THEN 6200 -6060 H=INT((K(I,3)/FND(1))*(2+RND(1))) -6061 S=S-H:K(I,3)=K(I,3)/(3+RND(0)) -6080 PRINT:PRINT H;"UNIT HIT ON ENTERPRISE FROM SECTOR"; -6081 PRINT K(I,1);CHR$(8);",";K(I,2);CHR$(8);"." -6090 IF S<=0 THEN 6240 -6100 PRINT" ":IF H<20 THEN 6200 -6120 IF RND(1)>.6 OR H/S<=.02 THEN 6200 -6140 R1=FNR(1):D(R1)=D(R1)-H/S-.5*RND(1):GOSUB 8790 -6170 PRINT"DAMAGE CONTROL: '";G2$;" DAMAGED BY THE HIT'" -6200 NEXT I:RETURN -6220 PRINT:PRINT"IT IS STARDATE";T;CHR$(8);".":PRINT:GOTO 6270 -6240 PRINT:PRINT"THE ENTERPRISE HAS BEEN DESTROYED. THE FEDERATION "; -6250 PRINT"WILL BE CONQUERED.":GOTO 6220 -6270 PRINT"THERE WERE";K9;"KLINGON BATTLE CRUISERS LEFT AT" -6280 PRINT"THE END OF YOUR MISSION." -6290 PRINT:PRINT:IF B9=0 THEN 6360 -6310 PRINT"THE FEDERATION IS IN NEED OF A NEW STARSHIP COMMANDER" -6320 PRINT"FOR A SIMILAR MISSION -- IF THERE IS A VOLUNTEER," -6330 INPUT"LET HIM STEP FORWARD AND ENTER 'AYE'";A$:IF A$="AYE"THEN 10 -6360 PRINT:PRINT "BACK TO SYSTEM.":END -6370 PRINT"CONGRATULATIONS, CAPTAIN! THE LAST KLINGON BATTLE CRUISER" -6380 PRINT"MENACING THE FEDERATION HAS BEEN DESTROYED.":PRINT -6400 PRINT"YOUR EFFICIENCY RATING IS";1000*(K7/(T-T0))^2:GOTO 6290 -6430 FOR I=S1-1 TO S1+1:FOR J=S2-1 TO S2+1 -6450 IF INT(I+.5)<1 OR INT(I+.5)>8 THEN 6540 -6451 IF INT(J+.5)<1 OR INT(J+.5)>8 THEN 6540 -6490 A$=">B<":Z1=I:Z2=J:GOSUB 8830:IF Z3=1 THEN 6580 -6540 NEXT J:NEXT I:D0=0:GOTO 6650 -6580 D0=1:C$="DOCKED":E=E0:P=P0 -6620 PRINT"SHIELDS DROPPED FOR DOCKING PURPOSES.":S=0:GOTO 6720 -6650 IF K3>0 THEN C$="*RED*":GOTO 6720 -6660 C$="GREEN":IF E=0 THEN 6770 -6730 PRINT:PRINT"*** SHORT RANGE SENSORS ARE OUT ***":PRINT:RETURN -6770 O1$=" +--1---2---3---4---5---6---7---8-+":PRINT O1$ -6771 FOR I=1 TO 8:PRINT I;"|"; -6820 FOR J=(I-1)*24+1 TO(I-1)*24+22 STEP 3:PRINT" ";MID$(Q$,J,3); -6821 NEXT J:PRINT"|";I; -6830 ON I GOTO 6850,6900,6960,7020,7070,7120,7180,7240 -6850 PRINT" STARDATE ";:PRINT INT(T*10)*.1 -6851 GOTO 7260 -6900 PRINT" CONDITION "; -6901 IF C$="*RED*" THEN PRINT CHR$(22);"*RED*";CHR$(22):GOTO 7260 -6902 IF C$="DOCKED" THEN PRINT CHR$(22);"DOCKED";CHR$(22):GOTO 7260 -6903 PRINT C$: GOTO 7260 -6960 PRINT" QUADRANT ";Q1;CHR$(8);",";Q2;CHR$(8) -6961 GOTO 7260 -7020 PRINT" SECTOR ";S1;CHR$(8);",";S2;CHR$(8) -7021 GOTO 7260 -7070 PRINT" PHOTON TORPEDOES ";:PRINT INT(P) -7071 GOTO 7260 -7120 PRINT" TOTAL ENERGY ";:PRINT INT(E+S) -7121 GOTO 7260 -7180 PRINT" SHIELDS ";:PRINT INT(S) -7181 GOTO 7260 -7240 PRINT" KLINGONS REMAINING";:PRINT INT(K9) -7260 NEXT I:PRINT O1$:RETURN -7290 IF D(8)<0 THEN PRINT"COMPUTER DISABLED.":GOTO 1990 -7320 INPUT"COMPUTER ACTIVE AND AWAITING COMMAND";A:IF A<0 THEN 1990 -7350 PRINT:H8=1:ON A+1 GOTO 7540,7900,8070,8500,8150,7400 -7360 PRINT"FUNCTIONS AVAILABLE FROM LIBRARY-COMPUTER:" -7365 PRINT "-----------------------------------------":PRINT -7370 PRINT" 0 = CUMULATIVE GALTIC RECORD" -7372 PRINT" 1 = STATUS REPORT" -7374 PRINT" 2 = PHOTON TORPEDO DATA" -7376 PRINT" 3 = STARBASE NAV DATA" -7378 PRINT" 4 = DIRECTION/DISTANCE CALCULATOR" -7380 PRINT" 5 = GALAXY 'REGION NAME' MAP":PRINT:GOTO 7320 -7400 H8=0:G5=1:PRINT" THE GALAXY":GOTO 7550 -7540 REM -7542 REM -7543 PRINT:PRINT" "; -7544 PRINT"COMPUTER RECORD OF GALAXY FOR QUADRANT";Q1;CHR$(8);",";Q2 -7546 PRINT -7550 PRINT" 1 2 3 4 5 6 7 8" -7560 O1$=" +-----+-----+-----+-----+-----+-----+-----+-----+" -7570 PRINT O1$:FOR I=1 TO 8:PRINT I;" ";:IF H8=0 THEN 7740 -7630 FOR J=1 TO 8:PRINT"| ";:IF Z(I,J)=0 THEN PRINT"*** ";:GOTO 7720 -7700 PRINT RIGHT$(STR$(Z(I,J)+1000),3);" "; -7720 IF J=8 THEN PRINT "|" -7721 NEXT J:GOTO 7850 -7740 Z4=I:Z5=1:GOSUB 9030:J0=INT(15-.5*LEN(G2$)):PRINT TAB(J0);G2$; -7800 Z5=5:GOSUB 9030:J0=INT(39-.5*LEN(G2$)):PRINT TAB(J0);G2$ -7850 PRINT O1$:NEXT I:PRINT:GOTO 1990 -7900 PRINT " STATUS REPORT:":PRINT " -------------":X$="" -7901 IF K9>1 THEN X$="S" -7940 PRINT K9;"KLINGON";X$;" LEFT." -7960 PRINT" MISSION MUST BE COMPLETED IN";.1*INT((T0+T9-T)*10); -7961 PRINT"STARDATES." -7970 X$="S":IF B9<2 THEN X$="":IF B9<1 THEN 8010 -7980 PRINT" THE FEDERATION IS MAINTAINING";B9; -7981 PRINT"STARBASE";X$;" IN THE GALAXY." -7990 GOTO 5690 -8010 PRINT"YOUR STUPIDITY HAS LEFT YOU ON YOUR OWN IN" -8020 PRINT" THE GALAXY -- YOU HAVE NO STARBASES LEFT!":GOTO 5690 -8070 IF K3<=0 THEN 4270 -8080 X$="":IF K3>1 THEN X$="S" -8090 PRINT"FROM ENTERPRISE TO KLINGON BATTLE CRUSER";X$ -8100 H8=0:FOR I=1 TO 3:IF K(I,3)<=0 THEN 8480 -8110 W1=K(I,1):X=K(I,2) -8120 C1=S1:A=S2:GOTO 8220 -8150 PRINT"DIRECTION/DISTANCE CALCULATOR:" -8160 PRINT"YOU ARE AT QUADRANT ";Q1;CHR$(8);",";Q2;" SECTOR "; -8161 PRINT S1;CHR$(8);",";S2;CHR$(8);"." -8170 INPUT"PLEASE ENTER INITIAL COORDINATES (X,Y)";C1,A -8200 INPUT"FINAL COORDINATES (X,Y)";W1,X -8220 X=X-A:A=C1-W1:IF X<0 THEN 8350 -8250 IF A<0 THEN 8410 -8260 IF X>0 THEN 8280 -8270 IF A=0 THEN C1=5:GOTO 8290 -8280 C1=1 -8290 IF ABS(A)<=ABS(X)THEN 8330 -8310 PRINT"DIRECTION =";C1+(((ABS(A)-ABS(X))+ABS(A))/ABS(A)):GOTO 8460 -8330 PRINT"DIRECTION =";C1+(ABS(A)/ABS(X)):GOTO 8460 -8350 IF A>0 THEN C1=3:GOTO 8420 -8360 IF X<>0 THEN C1=5:GOTO 8290 -8410 C1=7 -8420 IF ABS(A)>=ABS(X)THEN 8450 -8430 PRINT"DIRECTION =";C1+(((ABS(X)-ABS(A))+ABS(X))/ABS(X)):GOTO 8460 -8450 PRINT"DIRECTION =";C1+(ABS(X)/ABS(A)) -8460 PRINT"DISTANCE =";SQR(X^2+A^2):IF H8=1 THEN 1990 -8480 NEXT I:GOTO 1990 -8500 IF B3<>0 THEN PRINT"FROM ENTERPRISE TO STARBASE:" -8501 W1=B4:X=B5:GOTO 8120 -8510 PRINT"MR. SPOCK: 'SENSORS SHOW NO STARBASES IN THIS QUADRANT.'""; -8520 GOTO 1990 -8590 R1=FNR(1):R2=FNR(1):A$=" ":Z1=R1:Z2=R2:GOSUB 8830 -8591 IF Z3=0 THEN 8590 -8600 RETURN -8670 S8=INT(Z2-.5)*3+INT(Z1-.5)*24+1 -8675 IF LEN(A$)<>3 THEN PRINT"ERROR":STOP -8680 IF S8=1 THEN Q$=A$+RIGHT$(Q$,189):RETURN -8690 IF S8=190 THEN Q$=LEFT$(Q$,189)+A$:RETURN -8700 Q$=LEFT$(Q$,S8-1)+A$+RIGHT$(Q$,190-S8):RETURN -8790 ON R1 GOTO 8792,8794,8796,8798,8800,8802,8804,8806 -8792 G2$="WARP ENGINES":RETURN -8794 G2$="SHORT RANGE SENSORS":RETURN -8796 G2$="LONG RANGE SENSORS":RETURN -8798 G2$="PHASER CONTROL":RETURN -8800 G2$="PHOTON TUBES":RETURN -8802 G2$="DAMAGE CONTROL":RETURN -8804 G2$="SHIELD CONTROL":RETURN -8806 G2$="LIBRARY-COMPUTER":RETURN -8830 Z1=INT(Z1+.5):Z2=INT(Z2+.5):S8=(Z2-1)*3+(Z1-1)*24+1:Z3=0 -8890 IF MID$(Q$,S8,3)<>A$THEN RETURN -8900 Z3=1:RETURN -9030 IF Z5<=4 THEN ON Z4 GOTO 9040,9050,9060,9070,9080,9090,9100,9110 -9035 GOTO 9120 -9040 G2$="ANTARES":GOTO 9210 -9050 G2$="RIGEL":GOTO 9210 -9060 G2$="PROCYON":GOTO 9210 -9070 G2$="VEGA":GOTO 9210 -9080 G2$="CANOPUS":GOTO 9210 -9090 G2$="ALTAIR":GOTO 9210 -9100 G2$="SAGITTARIUS":GOTO 9210 -9110 G2$="POLLUX":GOTO 9210 -9120 ON Z4 GOTO 9130,9140,9150,9160,9170,9180,9190,9200 -9130 G2$="SIRIUS":GOTO 9210 -9140 G2$="DENEB":GOTO 9210 -9150 G2$="CAPELLA":GOTO 9210 -9160 G2$="BETELGEUSE":GOTO 9210 -9170 G2$="ALDEBARAN":GOTO 9210 -9180 G2$="REGULUS":GOTO 9210 -9190 G2$="ARCTURUS":GOTO 9210 -9200 G2$="SPICA" -9210 IF G5<>1 THEN ON Z5 GOTO 9230,9240,9250,9260,9230,9240,9250,9260 -9220 RETURN -9230 G2$=G2$+" I":RETURN -9240 G2$=G2$+" II":RETURN -9250 G2$=G2$+" III":RETURN -9260 G2$=G2$+" IV":RETURN -9999 END diff --git a/software/CPM/CPM00_SYSTEM/stat.com b/software/CPM/CPM00_SYSTEM/stat.com deleted file mode 100644 index 0e49253..0000000 Binary files a/software/CPM/CPM00_SYSTEM/stat.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/submit.com b/software/CPM/CPM00_SYSTEM/submit.com deleted file mode 100644 index f651bfe..0000000 Binary files a/software/CPM/CPM00_SYSTEM/submit.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/trekinst.bas b/software/CPM/CPM00_SYSTEM/trekinst.bas deleted file mode 100644 index 2e4f038..0000000 --- a/software/CPM/CPM00_SYSTEM/trekinst.bas +++ /dev/null @@ -1,133 +0,0 @@ -10 REM INSTRUCTIONS FOR "SUPER STARTREK" MAR 5, 1978 -20 FOR I=1 TO 12:PRINT:NEXT I -25 PRINT CHR$(26) -30 PRINT TAB(10);"*************************************" -40 PRINT TAB(10);"* *" -50 PRINT TAB(10);"* *" -60 PRINT TAB(10);"* * * SUPER STAR TREK * * *" -70 PRINT TAB(10);"* *" -80 PRINT TAB(10);"* *" -90 PRINT TAB(10);"*************************************" -100 FOR I=1 TO 8:PRINT:NEXT I -110 INPUT "DO YOU NEED INSTRUCTIONS (Y/N)";K$:IF K$="N" THEN 1210 -120 PRINT CHR$(26) -130 PRINT "NOTE: YOU MUST BE RUNNING 40K CP/M TO RUN STARTREK." -140 PRINT " THIS MEANS THAT BASIC MUST HAVE ABOUT 18K OF FREE MEMORY." -150 PRINT -160 PRINT" INSTRUCTIONS FOR 'SUPER STAR TREK'" -170 PRINT -180 PRINT"1. WHEN YOU SEE \COMMAND ?\ PRINTED, ENTER ONE OF THE LEGAL" -190 PRINT" COMMANDS (NAV,SRS,LRS,PHA,TOR,SHE,DAM,COM, OR XXX)." -200 PRINT"2. IF YOU SHOULD TYPE IN AN ILLEGAL COMMAND, YOU'LL GET A SHORT" -210 PRINT" LIST OF THE LEGAL COMMANDS PRINTED OUT." -220 PRINT"3. SOME COMMANDS REQUIRE YOU TO ENTER DATA (FOR EXAMPLE, THE" -230 PRINT" 'NAV' COMMAND COMES BACK WITH 'COURSE (1-9) ?'.) IF YOU" -240 PRINT" TYPE IN ILLEGAL DATA (LIKE NEGATIVE NUMBERS), THAT COMMAND" -250 PRINT" WILL BE ABORTED" -260 PRINT -270 PRINT" THE GALAXY IS DIVIDED INTO AN 8 X 8 QUADRANT GRID," -280 PRINT"AND EACH QUADRANT IS FURTHER DIVIDED INTO AN 8 X 8 SECTOR GRID." -290 PRINT -300 PRINT" YOU WILL BE ASSIGNED A STARTING POINT SOMEWHERE IN THE" -310 PRINT"GALAXY TO BEGIN A TOUR OF DUTY AS COMMANDER OF THE STARSHIP" -320 PRINT"\ENTERPRISE\; YOUR MISSION: TO SEEK AND DESTROY THE FLEET OF" -330 PRINT"KLINGON WARWHIPS WHICH ARE MENACING THE UNITED FEDERATION OF" -340 PRINT"PLANETS." -350 PRINT -352 LINE INPUT "ENTER [CR] TO CONTINUE";A$:IF A$="" THEN PRINT CHR$(26) -360 PRINT" YOU HAVE THE FOLLOWING COMMANDS AVAILABLE TO YOU AS CAPTAIN" -370 PRINT"OF THE STARSHIP ENTERPRISE:" -380 PRINT -390 PRINT"\NAV\ COMMAND = WARP ENGINE CONTROL --" -400 PRINT" COURSE IS IN A CIRCULAR NUMERICAL 4 3 2" -410 PRINT" VECTOR ARRANGEMENT AS SHOWN . . ." -420 PRINT" INTEGER AND REAL VALUES MAY BE ..." -430 PRINT" USED. (THUS COURSE 1.5 IS HALF- 5 ---*--- 1" -440 PRINT" WAY BETWEEN 1 AND 2 ..." -450 PRINT" . . ." -460 PRINT" VALUES MAY APPROACH 9.0, WHICH 6 7 8" -470 PRINT" ITSELF IS EQUIVALENT TO 1.0" -480 PRINT" COURSE" -490 PRINT" ONE WARP FACTOR IS THE SIZE OF " -500 PRINT" ONE QUADTANT. THEREFORE, TO GET" -510 PRINT" FROM QUADRANT 6,5 TO 5,5, YOU WOULD" -520 PRINT" USE COURSE 3, WARP FACTOR 1." -530 PRINT:PRINT -531 LINE INPUT "ENTER [CR] TO CONTINUE";A$:IF A$="" THEN PRINT CHR$(26) -540 PRINT"\SRS\ COMMAND = SHORT RANGE SENSOR SCAN" -550 PRINT" SHOWS YOU A SCAN OF YOUR PRESENT QUADRANT." -560 PRINT -570 PRINT" SYMBOLOGY ON YOUR SENSOR SCREEN IS AS FOLLOWS:" -580 PRINT" <*> = YOUR STARSHIP'S POSITION" -590 PRINT" +K+ = KLINGON BATTLE CRUISER" -600 PRINT" >!< = FEDERATION STARBASE (REFUEL/REPAIR/RE-ARM HERE!)" -610 PRINT" * = STAR" -620 PRINT -630 PRINT" A CONDENSED 'STATUS REPORT' WILL ALSO BE PRESENTED." -640 PRINT -650 PRINT"\LRS\ COMMAND = LONG RANGE SENSOR SCAN" -660 PRINT" SHOWS CONDITIONS IN SPACE FOR ONE QUADRANT ON EACH SIDE" -670 PRINT" OF THE ENTERPRISE (WHICH IS IN THE MIDDLE OF THE SCAN)" -680 PRINT" THE SCAN IS CODED IN THE FORM \###\, WHERE TH UNITS DIGIT" -690 PRINT" IS THE NUMBER OF STARS, THE TENS DIGIT IS THE NUMBER OF" -700 PRINT" STARBASES, AND THE HUNDRESDS DIGIT IS THE NUMBER OF" -710 PRINT" KLINGONS." -720 PRINT -730 PRINT" EXAMPLE - 207 = 2 KLINGONS, NO STARBASES, & 7 STARS." -740 PRINT:PRINT -741 LINE INPUT "ENTER [CR] TO CONTINUE";A$:IF A$="" THEN PRINT CHR$(26) -750 PRINT"\PHA\ COMMAND = PHASER CONTROL." -760 PRINT" ALLOWS YOU TO DESTROY THE KLINGON BATTLE CRUISERS BY " -770 PRINT" ZAPPING THEM WITH SUITABLY LARGE UNITS OF ENERGY TO" -780 PRINT" DEPLETE THEIR SHIELD POWER. (REMEMBER, KLINGONS HAVE" -790 PRINT" PHASERS TOO!)" -800 PRINT -810 PRINT"\TOR\ COMMAND = PHOTON TORPEDO CONTROL" -820 PRINT" TORPEDO COURSE IS THE SAME AS USED IN WARP ENGINE CONTROL" -830 PRINT" IF YOU HIT THE KLINGON VESSEL, HE IS DESTROYED AND" -840 PRINT" CANNOT FIRE BACK AT YOU. IF YOU MISS, YOU ARE SUBJECT TO" -850 PRINT" HIS PHASER FIRE. IN EITHER CASE, YOU ARE ALSO SUBJECT TO " -860 PRINT" THE PHASER FIRE OF ALL OTHER KLINGONS IN THE QUADRANT." -870 PRINT -880 PRINT" THE LIBRARY-COMPUTER (\COM\ COMMAND) HAS AN OPTION TO " -890 PRINT" COMPUTE TORPEDO TRAJECTORY FOR YOU (OPTION 2)" -900 PRINT -910 PRINT"\SHE\ COMMAND = SHIELD CONTROL" -920 PRINT" DEFINES THE NUMBER OF ENERGY UNITS TO BE ASSIGNED TO THE" -930 PRINT" SHIELDS. ENERGY IS TAKEN FROM TOTAL SHIP'S ENERGY. NOTE" -940 PRINT" THAT THE STATUS DISPLAY TOTAL ENERGY INCLUDES SHIELD ENERGY" -950 PRINT -951 LINE INPUT "ENTER [CR] TO CONTINUE";A$:IF A$="" THEN PRINT CHR$(26) -960 PRINT"\DAM\ COMMAND = DAMMAGE CONTROL REPORT" -970 PRINT" GIVES THE STATE OF REPAIR OF ALL DEVICES. WHERE A NEGATIVE" -980 PRINT" 'STATE OF REPAIR' SHOWS THAT THE DEVICE IS TEMPORARILY" -990 PRINT" DAMAGED." -1000 PRINT -1010 PRINT"\COM\ COMMAND = LIBRARY-COMPUTER" -1020 PRINT" THE LIBRARY-COMPUTER CONTAINS SIX OPTIONS:" -1030 PRINT" OPTION 0 = CUMULATIVE GALACTIC RECORD" -1040 PRINT" THIS OPTION SHOWES COMPUTER MEMORY OF THE RESULTS OF ALL" -1050 PRINT" PREVIOUS SHORT AND LONG RANGE SENSOR SCANS" -1060 PRINT" OPTION 1 = STATUS REPORT" -1070 PRINT" THIS OPTION SHOWS THE NUMBER OF KLINGONS, STARDATES," -1080 PRINT" AND STARBASES REMAINING IN THE GAME." -1090 PRINT" OPTION 2 = PHOTON TORPEDO DATA" -1100 PRINT" WHICH GIVES DIRECTIONS AND DISTANCE FROM THE ENTERPRISE" -1110 PRINT" TO ALL KLINGONS IN YOUR QUADRANT" -1115 PRINT:PRINT -1116 LINE INPUT "ENTER [CR] TO CONTINUE";A$:IF A$="" THEN PRINT CHR$(26) -1117 PRINT"\COM\ COMMAND = LIBRARY-COMPUTER" -1118 PRINT -1120 PRINT" OPTION 3 = STARBASE NAV DATA" -1130 PRINT" THIS OPTION GIVES DIRECTION AND DISTANCE TO ANY " -1140 PRINT" STARBASE WITHIN YOUR QUADRANT" -1150 PRINT" OPTION 4 = DIRECTION/DISTANCE CALCULATOR" -1160 PRINT" THIS OPTION ALLOWS YOU TO ENTER COORDINATES FOR" -1170 PRINT" DIRECTION/DISTANCE CALCULATIONS" -1180 PRINT" OPTION 5 = CALACTIC /REGION NAME/ MAP" -1190 PRINT" THIS OPTION PRINTS THE NAMES OF THE SIXTEEN MAJOR " -1200 PRINT" GALACTIC REGIONS REFERRED TO IN THE GAME." -1210 PRINT:PRINT:PRINT -1220 PRINT "...CHAINING TO STARTREK..." -1230 LOAD "STARTREK.BAS",R -1240 END diff --git a/software/CPM/CPM00_SYSTEM/userled.bas b/software/CPM/CPM00_SYSTEM/userled.bas deleted file mode 100644 index 38a6786..0000000 --- a/software/CPM/CPM00_SYSTEM/userled.bas +++ /dev/null @@ -1,33 +0,0 @@ -01 REM **************************************** -02 REM -03 REM Z80-MBC2 USER led blink demo: -04 REM -05 REM Blink USER led until USER key is pressed -06 REM -07 REM **************************************** -08 REM -13 PRINT "Press USER key to exit" -14 LEDUSER = 0 : REM USER LED write Opcode (0x00) -15 KEYUSER = 128 : REM USER KEY read Opcode (0x80) -16 PRINT "Now blinking..." -18 OUT 1,LEDUSER : REM Write the USER LED write Opcode -20 OUT 0,1 : REM Turn USER LED on -30 GOSUB 505 : REM Delay sub -40 OUT 1,LEDUSER : REM Write the USER LED write Opcode -45 OUT 0,0 : REM Turn USER LED off -50 GOSUB 505 : REM Delay -60 GOTO 18 -490 REM -500 REM * * * * * DELAY SUB -501 REM -505 FOR J=0 TO 150 -506 OUT 1,KEYUSER : REM Write the USER KEY read Opcode -507 IF INP(0)=1 THEN GOTO 700 : REM Exit if USER key is pressed -510 NEXT J -520 RETURN -690 REM -691 REM * * * * * PROGRAM END -692 REM -700 OUT 1,LEDUSER : REM Write the USER LED write Opcode -710 OUT 0,0 : REM Turn USER LED off -720 PRINT "Terminated by USER Key" diff --git a/software/CPM/CPM00_SYSTEM/xmodem.cfg b/software/CPM/CPM00_SYSTEM/xmodem.cfg deleted file mode 100644 index e07dfe9..0000000 --- a/software/CPM/CPM00_SYSTEM/xmodem.cfg +++ /dev/null @@ -1,210 +0,0 @@ -;Configuration file for XMODEM 2.X by M. Eberhard -;Must be named XMODEM.CFG and be on CP/M's default disk. -;This file is extremely verbose, for demonstration. -;Obviously, you can trim it WAY down. - -;How this CFG file works: - -;(These commands may also be on the command line. Command -;line options override .CFG file options.) Type XMODEM with -;no options for more help. - -; Anything after a semicolon on a line is a comment. Tabs, -; spaces, carriage returns, and line feeds are generally -; ignored (though not directly following a slash and not -; between 2 digits of a hex value). - -;/C specifies reception with checksums, rather than with -; CRC error checking. (Transmit error checking is set by -; the other end.) - -;/E specifies a RDR: port that returns with Z set when no -; character is waiting (for the /X1 option) - -;The following /I commands install 8080 code that gets used -;with the /X3 option. /I options are available ib XMODEM -;version 2.4 and later only. - -;/I0 hh hh... specifies up to 8 bytes of 8080 code that -; runs once during initialization, once the .CFG file -; and command line have both been parsed. (USeful for -; setting baud rates, etc.) - -;/I1 hh hh... specifies up to 8 bytes of 8080 code for -; the Tx byte routine. The chr to send is in register c. - -;/I2 hh hh... specifies up to 8 bytes of 8080 code for -; the Rx status routine. The routine should return with -; Z cleared if a chr is waiting. - -;/I3 hh hh... specifies up to 8 bytes of 8080 code for the Rx -; data routine. The chr should be returned in register a. - -;/M causes the following message to be printed on the console - -;/O option specifies a port initialization sequence - -; The first byte is a port address, and all subsequent -; bytes are sent to that port. - -; Note that more than one /O option may be specified, so -; that you can set up the UART and also e.g. the baud rate. - -;/P option specifies a custom serial port, for the X2 option - -; Byte 1 = status port address -; Byte 2 = data port address -; Byte 3 = 00 if port ready bits are active low -; = 01 if port ready bits are active high -; Byte 4 = bit bask for receiver ready bit -; Byte 5 = bit mask for transmitter ready bit - -;/Q suppresses pacifiers during data transfer, useful -; when the transfer port is also the console - -;/X0 uses the CON: port for data transfers -;/X1 uses the RDR:/PUN: port for data transfers (default) -;/X2 uses custom serial port (defined by /P) for data transfers -;/X3 uses patched ports (defined by /I) for data transfers -;(/X3 available in vers. 2.4 and later) - -; RC2014: /Z5 seems to be the best setting -/Z5 ;specify a 2 MHz CPU (any integer from 1 to 9) - -; RC2014: Standard full monty likes /X0 -/X0 ;uses the CON: port for data transfers - -;-------------------------------------------------------------- -;Example port configurations (Un-comment the one you will use.) - -;-------------------------------------------------------------- -;MITS 88-SIO (No initialization required) -; -;/MDirect I/O is configured for 88-SIO -;/P 00 01 00 01 80 ;88-SIO (no init needed) - -;-------------------------------------------------------------- -;MITS 88-2SIO (Typical Motorola 6850 ports) -; -;/MDirect I/O is configured for 88-2SIO Port A -;/X2 ;use custom port defined here -;/P 10 11 01 01 02 ;Port A -;/O 10 03 15 ;8 data, 1 stop, no parity - - -;-------------------------------------------------------------- -;Compupro Interfacer/Interfacer II -;Control bits are set by jumpers. The board will -;XOR whatever you write to the control port with the -;DIP switch setting. This assumes all these jumpers -;are set to their '0' position -; -;/MDirect I/O is configured for Interfacer port A -;/X2 ;use custom port defined here -;/P 01 00 01 02 01 ;Port A -;/O 01 AC ;8 data, no parity, controls high, no ints -; -;/MDirect I/O is configured for Interfacer port B -;/X2 ;use custom port defined here -;/P 03 02 01 02 01 ;Port B -;/O 03 AC ;8 data, no parity, controls high, no ints - -;-------------------------------------------------------------- -;Vector Graphic Bitstreamer/Bitstreamer II, Imsai SIO-2 -;(typical Intel 8251 ports) -; -;/MDirect I/O is configured for Bitstreamer port A -;/X2 ;use custom port defined here -;/P 03 02 01 02 01 ;Port A -;/O 03 AA 40 4E 27 ;8 bits, no parity, ports enabled, etc. -; -;/MDirect I/O is configured for Bitstreamer port B -;/X2 ;use custom port defined here -;/P 05 04 01 02 01 ;Port B -;/O 05 AA 40 4E 27 ;8 bits, no parity, ports enabled, etc. -; -;-------------------------------------------------------------- -;Cromemco TU-ART -; -;/MDirect I/O is configured for TU-ART port A -;/X2 ;use custom port defined here -;/P 20 21 01 40 80 ;Port A -;/O 22 01 ;reset UART -;/O 23 00 ;disable interrupts -;/O 20 C0 ;9600 baud low byte -;/O 22 00 ;9600 baud high bit -; -;/MDirect I/O is configured for TU-ART port B -;/X2 ;use custom port defined here -;/P 50 51 01 40 80 ;Port B -;/O 52 01 ;reset UART -;/O 53 00 ;disable interrupts -;/O 50 a0 ;38.4 Kbaud low byte -;/O 52 10 ;38.4 Kbaud high bit - -;-------------------------------------------------------------- -;CCS 2719 serial ports (Typical Zilog DART ports) -; -;/MDirect I/O is configured for CCS 2719 Port A -;/X2 ;use custom port defined here -;(typical Z80 DART & Z80 CTC configuration) -;/P 55 54 01 01 04 ;Port A -;/O 55 48 01 00 03 C1 04 44 05 EA ;DART: 8 bits, 1 stop, no parity -;/O 50 47 03 ;CTC: 38.4K baud -;**/O 50 47 0C ; CTC: 9600 baud -;**/O 50 47 60 ; CTC: 1200 baud -; -;/MDirect I/O is configured for CCS 2719 Port B -;/X2 ;use custom port defined here -;/P 57 56 01 01 04 ;Port B -;/O 57 48 01 00 03 C1 04 44 05 EA ;DART: 8 bits, 1 stop, no parity -;/O 51 47 03 ;CTC: 38.4K baud -;**/O 51 47 0C ; CTC: 9600 baud -;**/O 51 47 60 ; CTC: 1200 baud - -;-------------------------------------------------------------- -;CCS 2810 serial port (which is also the console) -; -;/MDirect I/O is configured for the 2810's serial port, which is also -;/Mthe console. No progress messages will be printed during transfer. -;/X2 ;use custom port defined here -;/Q ;Quiet mode, because this is also CON: -;/P 25 20 01 01 10 ;2810 serial port -;/O 24 0F ;modem control -;/O 23 83 ;Baud rate divisor access -;/O 21 00 ;High baud rate -;/O 20 0C ;Low baud rate, 9600 baud -;**/O 20 03 ; 38.4K Baud -;**/O 20 60 ; 1200 baud -;/O 23 03 ;Line control -;/O 21 00 ;Ints disabled -;/O 25 00 ;handshake lines active - -;-------------------------------------------------------------- -;Processor Technology 3P+S's serial port -;(No initialization required) -; -;/Direct I/O via the 3P+S serial port -;/X2 ;use custom port defined here -;/P 00 01 01 40 80 - -;-------------------------------------------------------------- -;Processor Technology Sol-20 (with SOLOS ROM) or -;Subsystem B (with CUTER ROM) -; -;/MUSing Solos/Cuter serial I/O -;/X3 ;Use the (following) patched I/O -;/I1 48 3E 01 CD 1C C0 ;Tx: call AOUT with a=1 for serial port -;/I2 3E 01 CD 22 C0 ;Rx status: call AINP with a=1 for serial port -;/I3 ;Rx data: no Rx data routine, since AOUT got -; ;the data. (this line is not actually required) - -;-------------------------------------------------------------- -;Poly-88 with POLEX ROM -; -;/MUsing POLEX for serial I/O -;/X3 ;Use the (following) patched I/O -;/I0 3E 1F CD 18 F4 ;Set baud rate to 9600 -;/I1 CD 12 F4 ;Call PXSOUT to transit -;/I2 CD 0C F4 ;Call PXSTA for status -;/I3 CD 0F F4 ;call PXSIN for data diff --git a/software/CPM/CPM00_SYSTEM/xmodem.com b/software/CPM/CPM00_SYSTEM/xmodem.com deleted file mode 100644 index 8f6d994..0000000 Binary files a/software/CPM/CPM00_SYSTEM/xmodem.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/xsub.com b/software/CPM/CPM00_SYSTEM/xsub.com deleted file mode 100644 index 15e86ab..0000000 Binary files a/software/CPM/CPM00_SYSTEM/xsub.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/zde16.com b/software/CPM/CPM00_SYSTEM/zde16.com deleted file mode 100644 index 38ad326..0000000 Binary files a/software/CPM/CPM00_SYSTEM/zde16.com and /dev/null differ diff --git a/software/CPM/CPM00_SYSTEM/zdenst16.com b/software/CPM/CPM00_SYSTEM/zdenst16.com deleted file mode 100644 index 8ccc976..0000000 Binary files a/software/CPM/CPM00_SYSTEM/zdenst16.com and /dev/null differ diff --git a/software/CPM/CPM01_TURBOP/art.txt b/software/CPM/CPM01_TURBOP/art.txt deleted file mode 100644 index fc95dc8..0000000 --- a/software/CPM/CPM01_TURBOP/art.txt +++ /dev/null @@ -1,263 +0,0 @@ - - _________________________________________________________ - |\=========================================================\ - || | - || _ __ ___ __ _ | - || ; `-.__.-'. `-.__.-'. .`-.__.-' .`-.__.-' : | - || _.'. . . . . . . . .,,,,,,,. . . . . . . . .`._ | - || .'. . . . . . . . ,a@@@@@@@@@@@a, . . . . . . . .`. | - || `. . . . ,a@@@@@a@@@a@@@@@@@@@a@@@a@@@@@a, . . . ,' | - || ) . . a@@@@@@a@@@@@a@@@@@@@a@@@@@a@@@@@@a . . ( | - || ,' . . .@@@%%%a@@@@@@@@@@@@@@@@@@@@@a%%%@@@ . . `. | - || `.. . . @@@%%a@@@@@@""@@@@@@@""@@@@@@a%%@@@ . . .,' | - || ). . . "@@a@@@@@@@@@SSSSSSS@@@@@@@@@a@@" . . .( | - || ,'. . . . . `@@@@@@@@SSS, ,SSS@@@@@@@@' . . . . .`. | - || `. . . . . . `@@@@@@@`SSS:SSS'@@@@@@@' . . . . . ,' | - || ) . . . . . `@@@@@@@sssssss@@@@@@@' . . . . . ( | - || ,' . . . . . ,a@@a@@@@@@@@@@@@@@@a@@a, . . . . . `. | - || `.. . . . .a@@@a@@@@@a@@@a@@@a@@@@@a@@@a. . . . .,' | - || ). . . .a@@@@@a@@@@@@@@@@@@@@@@@a@@@@@a. . . .( | - || ,'. . . . @@@@@@a@@@@' " `@@@@a@@@@@@ . . . .`. | - || `. . . . .@@@@@@@aaaa, ,aaaa@@@@@@@ . . . ,' | - || ) . . . `@@@@@@@@@@@@a, ,a@@@@@@@@@@@@' . . . ( | - || ,' . . . . .`@@@@@@@@@@a@a@a@@@@@@@@@@'. . . . . `. | - || `;;;;;;;;;;;;aaaaaaaaaa@@@@@aaaaaaaaaa;;;;;;;;;;;;' | - || );;;;;;;,mMMMMMMMm@@@@@@@@@@@mMMMMMMMm,;;;;;;;( | - || ,;;;;;;;;a@%#%%#%%#%Mm@@@@@@@mM%#%%#%%#%@a;;;;;;;;, | - || `;;;;;;;;@@%%%%%%%%%%M@@";"@@M%%%%%%%%%%@@;;;;;;;;' | - || );;;;;;`@a%%%%%%%%mM";;;;;"Mm%%%%%%%%a@';;;;;;( | - || ,;;;;;;;;;;"@@@@@@@@";;;;;;;;;"@@@@@@@@";;;;;;;;;;, | - || `;;;;;;;;;;;;"""""";;;;;;;;;;;;;"""""";;;;;;;;;;;;' | - || );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-Catalyst( | - || `:;;;:-~~~-:;;:-~~~-:;;;;;:-~~~-:;;:,-~~~-:;;;:' | - || ~~~ ~~ ~~~ ~~ ~~~ | - || .=============. | - || | Mr. Bear : | - || `-------------' | - \|_________________________________________________________| - - - - - - - - .,%%%%%,. ..,,,,.. - .%%%;%;%;%;%, .,%%%%%%%,%%%%%%,. .,,,,. - %%%;a@@@@@a;;,%%%%%%%%%%%%%%%%%%%%%%,;%%;%;%;%%, - %%%;@@@@@@a;,%%%%%%%%%%%%%%,%%%%%%%%%%;a@@@@a;%%% - `%%%;@@@a;,%%%%%%%%%%%%%%%%%%%%%%%%%%%%;a@@@@;%%% - `%%%;;,%%%%%%%%%%%%%% .%%%,%% .%%%%%%%;a@@;%%%' - ```%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%;%%%%' - %%%%%%%%%%%%%%%%%%%' #`%%%%%%%%%%' - %%%%%%%%%%%%%%%%%%%,. .,%%%%%%%%%% - %%%%%%%%%%%%%%%;a@@@@a;a@@@a;%%%%%% - `%%%%%%%%%%%;a@@@a@@@@a;a@@a@a;%%%' - `%%%%%%%%%;@@@a@@@a@@@;a@a@a@;%%' ..,,. - ,sSSSSSs`%%%%%%%;@@@@@@@@@;a@@@@@;%' .,%%%,;;;;, - .S@S;;;;;SSs %%%%%%%%%%%%%%%%%%%%%%' .,%%%%%%,;;;;;;, - S@@SSss;;;;sSs,s@SSSS@,sSSSSSSSSs,.%%%%%%%%%%%,;;;;;;, - `S@@SSSSSSs;;Ss@@SSSS@@sSs;;;;;;S@s,%%%%%%%%%%%,;;;;;; - .S@@SSSSSSSSSSs@@SSSS@@sSSSSSs;;;@@S,%%%%%%%%%%%%,;;;' - S@@SSSSSSSSSSS'`@SSSS@s`SSSSSSSSs@S',%%%%%%%%%%%%%%' - %`S@SSSSSSSSS'.SSSssssSSS`SSSSSSS@S'%%,%%%%%%%%%%' - .%%%%,""""""%%.sSSSSS^SSSSSs%`SSSSSS'%%%%,%%%%%' - .%%%%%%%%%%%%.sSSSSSSS'.sSSSSS,%%"""",%%%%%%,%' - .%%%%%%%%%%%.sSSSSSSSS'.SSSSSSSS,%%%%%%%%%%%%%. - .%.%.%.%.%.%.SSSSSSSSS',SSSS^SSSSS,%,%%%%%%%%%%% - %;;;;;;;;;%,SSSSS^SSSS,,SSS',SSSS'%%%%%%%%%%%%%%, - ;;;;;;;;;;;,SSSS'%`SS';%`S'%,SS'%%%%%,%%%%%%%%%%% - `;;;;;;;;'%`SS'%%,S'%%%%,%,S'%%%%%%%%%%%%%%%%%%% - %%%`S,%%%%%%%%%%%%%%%%%%%%,%%%%%%%%%%%' - ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - .%`%%%%%%%%%%%%%%%%%%%%%%,%%%%%%%%%%%'% - %%%`%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%'%%%. - ;%%%%%`%%%%%%%%%%%%%%%%,%%%%%%%%%'%%%%%%%. - %%%%%%%;%:%:%:%:%%%'`%%:%:%:%:%:%%%%%%%%%%, - %%%%%%%%%%%%%%%%%%%. `%%%%%%%%%%%%%%%%%%%%%%, - %%%%%%%%%%%%%%%%%%%% `%%%%%%%%%%%%%%%%%%%%%%, - %%%%%%%%%%%%%%%%%%%%. `%%%%%%%%%%%%%%%%%%%%%%, - %%%%%%%%%%%%%%%%%%%%% `%%%%%%%%%%,%%%,%%%,%%%, - %%%%%%%%,%%%,%%%,%%,%. `%%%%%,;;;;;;;;;;;;;,%, - `%%%%,;;;;;;;;;;;;;;,% `%%,;;;;;;;;;;;;;;;;;; - `%,;;;;;;;;;;;;;;;;;; `;;;;;;;;;;;;;;;;;;;' - `%;;;;;;;;;;;;;;;;;' `;;;;;;;;;;;;;;;' - `;;;;;;;;;;;;;;' ''''''''''' - - - - - - .... - W$$$$$u - $$$$F**+ .oW$$$eu - ..ueeeWeeo.. e$$$$$$$$$ - .eW$$$$$$$$$$$$$$$b- d$$$$$$$$$$W - ,,,,,,,uee$$$$$$$$$$$$$$$$$$$$$ H$$$$$$$$$$$~ - :eoC$$$$$$$$$$$C""?$$$$$$$$$$$$$$$ T$$$$$$$$$$" - $$$*$$$$$$$$$$$$$e "$$$$$$$$$$$$$$i$$$$$$$$F" - ?f"!?$$$$$$$$$$$$$$ud$$$$$$$$$$$$$$$$$$$$*Co - $ o$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ - !!!!m.*eeeW$$$$$$$$$$$f?$$$$$$$$$$$$$$$$$$$$$$$$$$$$$U - !!!!!! !$$$$$$$$$$$$$$ T$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ - *!!*.o$$$$$$$$$$$$$$$e,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$: - "eee$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$C - b ?$$$$$$$$$$$$$$**$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$! - Tb "$$$$$$$$$$$$$$*uL"$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$' - $$o."?$$$$$$$$F" u$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ - $$$$en ``` .e$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$' - $$$B* =*"?.e$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$F - $$$W"$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$" - "$$$o#$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$" - R: ?$$$W$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$" :!i. - !!n.?$???""``.......,``````"""""""""""`` ...+!!! - !* ,+::!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*` - "!?!!!!!!!!!!!!!!!!!!~ !!!!!!!!!!!!!!!!!!!~` - +!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!?!` - .!!!!!!!!!!!!!!!!!!!!!' !!!!!!!!!!!!!!!, !!!! - :!!!!!!!!!!!!!!!!!!!!!!' !!!!!!!!!!!!!!!!! `!!: - .+!!!!!!!!!!!!!!!!!!!!!~~!! !!!!!!!!!!!!!!!!!! !!!. - :!!!!!!!!!!!!!!!!!!!!!!!!!.`:!!!!!!!!!!!!!!!!!:: `!!+ - "~!!!!!!!!!!!!!!!!!!!!!!!!!!.~!!!!!!!!!!!!!!!!!!!!.`!!: - ~~!!!!!!!!!!!!!!!!!!!!!!! ;!!!!~` ..eeeeeeo.`+!.!!!!. - :.. `+~!!!!!!!!!!!!!!!!! :!;`.e$$$$$$$$$$$$$u . - $$$$$$beeeu.. `````~+~~~~~" ` !$$$$$$$$$$$$$$$$ $b - $$$$$$$$$$$$$$$$$$$$$UU$U$$$$$ ~$$$$$$$$$$$$$$$$ $$o - !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$. $$$$$$$$$$$$$$$~ $$$u - !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$! $$$$$$$$$$$$$$$ 8$$$$. - !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$X $$$$$$$$$$$$$$`u$$$$$W - !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$! $$$$$$$$$$$$$".$$$$$$$: - $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ $$$$$$$$$$$$F.$$$$$$$$$ - ?$$$$$$$$$$$$$$$$$$$$$$$$$$$$f $$$$$$$$$$$$' $$$$$$$$$$. - $$$$$$$$$$$$$$$$$$$$$$$$$$$$ $$$$$$$$$$$$$ $$$$$$$$$$! - "$$$$$$$$$$$$$$$$$$$$$$$$$$$ ?$$$$$$$$$$$$ $$$$$$$$$$! - "$$$$$$$$$$$$$$$$$$$$$$$$Fib ?$$$$$$$$$$$b ?$$$$$$$$$ - "$$$$$$$$$$$$$$$$$$$$"o$$$b."$$$$$$$$$$$ $$$$$$$$' - e. ?$$$$$$$$$$$$$$$$$ d$$$$$$o."?$$$$$$$$H $$$$$$$' - $$$W.`?$$$$$$$$$$$$$$$ $$$$$$$$$e. "??$$$f .$$$$$$' - d$$$$$$o "?$$$$$$$$$$$$ $$$$$$$$$$$$$eeeeee$$$$$$$" - $$$$$$$$$bu "?$$$$$$$$$ 3$$$$$$$$$$$$$$$$$$$$*$$" - d$$$$$$$$$$$$$e. "?$$$$$:`$$$$$$$$$$$$$$$$$$$$8 - e$$e. $$$$$$$$$$$$$$$$$$+ "??f "$$$$$$$$$$$$$$$$$$$$c - $$$$$$$o $$$$$$$$$$$$$$$F" `$$$$$$$$$$$$$$$$$$$$b. - M$$$$$$$$U$$$$$$$$$$$$$F" ?$$$$$$$$$$$$$$$$$$$$$u - ?$$$$$$$$$$$$$$$$$$$$F "?$$$$$$$$$$$$$$$$$$$$u - "$$$$$$$$$$$$$$$$$$" ?$$$$$$$$$$$$$$$$$$$$o - "?$$$$$$$$$$$$$F "?$$$$$$$$$$$$$$$$$$ - "??$$$$$$$F ""?3$$$$$$$$$$$$F - .e$$$$$$$$$$$$$$$$' - u$$$$$$$$$$$$$$$$$ - `$$$$$$$$$$$$$$$$" - "$$$$$$$$$$$$F" - ""?????"" - - - - ..::''''::.. - .:::. .;'' ``;. - .... ::::: :: :: :: :: - ,;' .;: () ..: `:::' :: :: :: :: - ::. ..:,:;.,:;. . :: .::::. `:' :: .:' :: :: `:. :: - '''::, :: :: :: `:: :: ;: .:: : :: : : :: - ,:'; ::; :: :: :: :: :: ::,::''. . :: `:. .:' :: - `:,,,,;;' ,;; ,;;, ;;, ,;;, ,;;, `:,,,,:' :;: `;..``::::''..;' - ``::,,,,::'' - - - - _________________________________________________________ - |\=========================================================\ - || | - || _ __ ___ __ _ | - || ; `-.__.-'. `-.__.-'. .`-.__.-' .`-.__.-' : | - || _.'. . . . . . . . .,,,,,,,. . . . . . . . .`._ | - || .'. . . . . . . . ,a@@@@@@@@@@@a, . . . . . . . .`. | - || `. . . . ,a@@@@@a@@@a@@@@@@@@@a@@@a@@@@@a, . . . ,' | - || ) . . a@@@@@@a@@@@@a@@@@@@@a@@@@@a@@@@@@a . . ( | - || ,' . . .@@@%%%a@@@@@@@@@@@@@@@@@@@@@a%%%@@@ . . `. | - || `.. . . @@@%%a@@@@@@""@@@@@@@""@@@@@@a%%@@@ . . .,' | - || ). . . "@@a@@@@@@@@@SSSSSSS@@@@@@@@@a@@" . . .( | - || ,'. . . . . `@@@@@@@@SSS, ,SSS@@@@@@@@' . . . . .`. | - || `. . . . . . `@@@@@@@`SSS:SSS'@@@@@@@' . . . . . ,' | - || ) . . . . . `@@@@@@@sssssss@@@@@@@' . . . . . ( | - || ,' . . . . . ,a@@a@@@@@@@@@@@@@@@a@@a, . . . . . `. | - || `.. . . . .a@@@a@@@@@a@@@a@@@a@@@@@a@@@a. . . . .,' | - || ). . . .a@@@@@a@@@@@@@@@@@@@@@@@a@@@@@a. . . .( | - || ,'. . . . @@@@@@a@@@@' " `@@@@a@@@@@@ . . . .`. | - || `. . . . .@@@@@@@aaaa, ,aaaa@@@@@@@ . . . ,' | - || ) . . . `@@@@@@@@@@@@a, ,a@@@@@@@@@@@@' . . . ( | - || ,' . . . . .`@@@@@@@@@@a@a@a@@@@@@@@@@'. . . . . `. | - || `;;;;;;;;;;;;aaaaaaaaaa@@@@@aaaaaaaaaa;;;;;;;;;;;;' | - || );;;;;;;,mMMMMMMMm@@@@@@@@@@@mMMMMMMMm,;;;;;;;( | - || ,;;;;;;;;a@%#%%#%%#%Mm@@@@@@@mM%#%%#%%#%@a;;;;;;;;, | - || `;;;;;;;;@@%%%%%%%%%%M@@";"@@M%%%%%%%%%%@@;;;;;;;;' | - || );;;;;;`@a%%%%%%%%mM";;;;;"Mm%%%%%%%%a@';;;;;;( | - || ,;;;;;;;;;;"@@@@@@@@";;;;;;;;;"@@@@@@@@";;;;;;;;;;, | - || `;;;;;;;;;;;;"""""";;;;;;;;;;;;;"""""";;;;;;;;;;;;' | - || );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;( | - || `:;;;:-~~~-:;;:-~~~-:;;;;;:-~~~-:;;:,-~~~-:;;;:' | - || ~~~ ~~ ~~~ ~~ ~~~ | - || .=============. | - || | KINA : | - || `-------------' | - \|_________________________________________________________| - - - - -c, ,c -3$$c ,$$P -$$"$$c ,cc, ,zc, ,cc J$$ c, ,cc, c, hcc$$$$$$",zcc, ,$$" -$$ ?$c ,$$?$c ,d$$$F ,$$P$b J$$ $$ z$$P$b, $$$cJ$$ $$ ,$$?$$ $$b,. -$$ ,$$,$$" ?$b $$P'?" d$P $$. J$$ ,$$ J$$" `$$ $$`"$$$ $$ d$P $$F "?$$b -$$,c$$'$$F $$<$$ $$F,3$L J$$$$$$ $$F $$,$$ ?$$ $$ $$L,$$$ 4$$ -$$$$P':$$, ,$$ $$c ,$$$$$$$ 3$$"'$$ $$c ,$$ $$ :$$ $$ ;$$$$P$$ ,$$" -$$" "?$$d$$" "$$c,3$$"' $$ ?$$ $$ `?$$$$$" $$ :$$ $$ 3$$" $$ ,$$F -$$ `"?"' """`"" "" `"" "" """ "" "" "" "" ""J$$" -$$ "?" - - .:::. - .::::::-'``'::::. - .:::'',,cd$$$$$$$bc,`. - ::::,$$$$$$$$$$$$$$$$$,`. - :::'z$$$$$$$$$$$$$$$$$$$$c, - .:::'z$$$$$$$$$$$$$$$$$P"" _`. - ::::'z$$$$$$$$$$$$$$$$$",d$$$$$c,. - ::::: P".,,. "$$$$$$$$$$$$P" ,c,`$,` - .::::::,c$$$$$$$$$$$$$$$$$$P J$",c$$.`. - :::::::,$P" ,`?$$$$$$$$$$$$,,,c$$$$$$L<. - ::::::: d$. ,$$$b,"$$$$$$$$$$$$$$$$$$$$$.$ - :::::::: $$$cccccccd$$$$$$$$$$$$$$$$$$$$$$$`: - :::::::: $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$,:: - ::::::::'J`$$$$$$$$$$$$$$$$"$$,$$$$$$?$$$$$$F::. - .:::::::::'$,"$$$$$$$$$$$$$$$$$P??"""",,$$$$$$F::: - ::::::::::: ?$$`$$$$$$$$$$$PF"" ,,<'J$$$$$P':::: - .:::::::::::::."$h"$$$$$$$$$hc.-?????'' ,d$$$$$$':::::: - ::::::::::::::::::"?$$$$$$:$,! .:::::'' -:::::::::::::,$$$$$$$$$$$$$$$$$$$$$$$$$$b,`!!`"$$$$:$$`!'c,`` -:::::::::::::J$$$$$$$$$$$$$$$$$$$$$$$$$$$$b, -:::::::::::'J$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$F,?b,`. -::::::::'J$$$$$$$$$$$$$$$$$$P4F,cCCCCCCCCCCCCCCCCCCCCCCCc`",, -:::::::,$$$$$$$$$$$$$$$$$$',CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC><> -::::::'J$$$$$$$$$$$$$$$$$F,CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC>,CC \ No newline at end of file diff --git a/software/CPM/CPM01_TURBOP/readme.txt b/software/CPM/CPM01_TURBOP/readme.txt deleted file mode 100644 index 1746a4d..0000000 --- a/software/CPM/CPM01_TURBOP/readme.txt +++ /dev/null @@ -1 +0,0 @@ -In this disk is stored the Turbo Pascal Compiler v3.01A \ No newline at end of file diff --git a/software/CPM/CPM01_TURBOP/sa.pas b/software/CPM/CPM01_TURBOP/sa.pas deleted file mode 100644 index 240238c..0000000 --- a/software/CPM/CPM01_TURBOP/sa.pas +++ /dev/null @@ -1,65 +0,0 @@ -program SA; - -const - MaxX = 100; - MaxY = 50; - -var - FileName: string[15]; - -procedure ClearScreen; - -begin - Write(con, #27,'[2J') -end; - - -procedure Indent; - -begin - Write(con, #27,'[10G') -end; - - -procedure ShowArt; - -var - F: Text; - Line:string[255]; - -begin - assign(F, FileName); - reset(F); - while ((not Eof(F)) and (not KeyPressed)) do begin - readln(F, Line); - {Indent; } - writeln(CON, Line); - delay(12) - end; - close(f) -end; - - -var - Running: boolean; - Ch: char; - -begin - if paramcount > 0 then begin - FileName:= Paramstr(1) - end - else begin - FileName:= 'ART.TXT' - end; - ClearScreen; - writeln('Press Q key to exit'); - writeln; - Running:= true; - while Running do begin - ShowArt; - if KeyPressed then begin - read(kbd, ch); - Running:= (ch <> 'q') - end - end -end. \ No newline at end of file diff --git a/software/CPM/CPM01_TURBOP/tinst.com b/software/CPM/CPM01_TURBOP/tinst.com deleted file mode 100644 index f730496..0000000 Binary files a/software/CPM/CPM01_TURBOP/tinst.com and /dev/null differ diff --git a/software/CPM/CPM01_TURBOP/tinst.dta b/software/CPM/CPM01_TURBOP/tinst.dta deleted file mode 100644 index 9d0a0d7..0000000 Binary files a/software/CPM/CPM01_TURBOP/tinst.dta and /dev/null differ diff --git a/software/CPM/CPM01_TURBOP/tinst.msg b/software/CPM/CPM01_TURBOP/tinst.msg deleted file mode 100644 index a592804..0000000 Binary files a/software/CPM/CPM01_TURBOP/tinst.msg and /dev/null differ diff --git a/software/CPM/CPM01_TURBOP/turbo.com b/software/CPM/CPM01_TURBOP/turbo.com deleted file mode 100644 index 48f8da0..0000000 Binary files a/software/CPM/CPM01_TURBOP/turbo.com and /dev/null differ diff --git a/software/CPM/CPM01_TURBOP/turbo.msg b/software/CPM/CPM01_TURBOP/turbo.msg deleted file mode 100644 index 701b32b..0000000 --- a/software/CPM/CPM01_TURBOP/turbo.msg +++ /dev/null @@ -1,101 +0,0 @@ - are not allowed - can not be - constant - does not - expression - identifier - file - here - Integer - File -Illegal - or -Undefined - match - real -String -Textfile - out of range - variable - overflow - expected - type -Invalid - pointer -01';' -02':' -03',' -04'(' -05')' -06'=' -07':=' -08'[' -09']' -10'.' -11'..' -12BEGIN -13DO -14END -15OF -17THEN -18TO DOWNTO -20Boolean -21  -22  -23  -24  -25  -26  -27  -28Pointer -29Record -30Simple -31Simple -32 -33 -34 -35 -36Type -37Untyped -40 label -41Unknown syntax error -42 in preceding definitions -43Duplicate label -44Type mismatch -45 -46 and CASE selector -47Operand(s) operator -48 result -49  length -50 length -51 subrange base -52Lower bound > upper bound -53Reserved word -54 assignment -55 exceeds line -56Error in integer -57Error in -58 character in -60s -61 s ands -62Structureds -63s -64s and untypeds -65Untypeds -66I/O -67 s must be parameters -68 componentss -69dering of fields -70Set base -71 GOTO -72Label not within current block -73 FORWARD procedure(s) -74INLINE error -75 use of ABSOLUTE -90 not found -91Unexpected end of source -97Too many nested WITH's -98Memory -99Compilerd WITH's -98Memory -99Compiler \ No newline at end of file diff --git a/software/CPM/CPM01_TURBOP/turbo.ovr b/software/CPM/CPM01_TURBOP/turbo.ovr deleted file mode 100644 index bd9292e..0000000 Binary files a/software/CPM/CPM01_TURBOP/turbo.ovr and /dev/null differ diff --git a/software/CPM/CPM01_TURBOP/turbomsg.ovr b/software/CPM/CPM01_TURBOP/turbomsg.ovr deleted file mode 100644 index 36872a5..0000000 Binary files a/software/CPM/CPM01_TURBOP/turbomsg.ovr and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/$exec.com b/software/CPM/CPM02_HI_C/$exec.com deleted file mode 100644 index a6ae8f5..0000000 Binary files a/software/CPM/CPM02_HI_C/$exec.com and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/assert.h b/software/CPM/CPM02_HI_C/assert.h deleted file mode 100644 index 8e0c970..0000000 Binary files a/software/CPM/CPM02_HI_C/assert.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/c.com b/software/CPM/CPM02_HI_C/c.com deleted file mode 100644 index 11d94a4..0000000 Binary files a/software/CPM/CPM02_HI_C/c.com and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/cgen.com b/software/CPM/CPM02_HI_C/cgen.com deleted file mode 100644 index fb2e377..0000000 Binary files a/software/CPM/CPM02_HI_C/cgen.com and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/conio.h b/software/CPM/CPM02_HI_C/conio.h deleted file mode 100644 index 1002a01..0000000 Binary files a/software/CPM/CPM02_HI_C/conio.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/cpm.h b/software/CPM/CPM02_HI_C/cpm.h deleted file mode 100644 index 4d24847..0000000 Binary files a/software/CPM/CPM02_HI_C/cpm.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/cpp.com b/software/CPM/CPM02_HI_C/cpp.com deleted file mode 100644 index dbe5127..0000000 Binary files a/software/CPM/CPM02_HI_C/cpp.com and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/cref.com b/software/CPM/CPM02_HI_C/cref.com deleted file mode 100644 index d20a44d..0000000 Binary files a/software/CPM/CPM02_HI_C/cref.com and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/crtcpm.obj b/software/CPM/CPM02_HI_C/crtcpm.obj deleted file mode 100644 index b272328..0000000 Binary files a/software/CPM/CPM02_HI_C/crtcpm.obj and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/ctype.h b/software/CPM/CPM02_HI_C/ctype.h deleted file mode 100644 index 35ae88f..0000000 Binary files a/software/CPM/CPM02_HI_C/ctype.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/debug.com b/software/CPM/CPM02_HI_C/debug.com deleted file mode 100644 index 299a60d..0000000 Binary files a/software/CPM/CPM02_HI_C/debug.com and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/dehuff.com b/software/CPM/CPM02_HI_C/dehuff.com deleted file mode 100644 index 711976b..0000000 Binary files a/software/CPM/CPM02_HI_C/dehuff.com and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/exec.h b/software/CPM/CPM02_HI_C/exec.h deleted file mode 100644 index e59e5dc..0000000 Binary files a/software/CPM/CPM02_HI_C/exec.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/float.h b/software/CPM/CPM02_HI_C/float.h deleted file mode 100644 index 72f1438..0000000 Binary files a/software/CPM/CPM02_HI_C/float.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/hitech.h b/software/CPM/CPM02_HI_C/hitech.h deleted file mode 100644 index 1fd0933..0000000 Binary files a/software/CPM/CPM02_HI_C/hitech.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/libc.lib b/software/CPM/CPM02_HI_C/libc.lib deleted file mode 100644 index 58cff5d..0000000 Binary files a/software/CPM/CPM02_HI_C/libc.lib and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/libf.lib b/software/CPM/CPM02_HI_C/libf.lib deleted file mode 100644 index 00380be..0000000 Binary files a/software/CPM/CPM02_HI_C/libf.lib and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/libr.com b/software/CPM/CPM02_HI_C/libr.com deleted file mode 100644 index 7b76491..0000000 Binary files a/software/CPM/CPM02_HI_C/libr.com and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/limits.h b/software/CPM/CPM02_HI_C/limits.h deleted file mode 100644 index 9aa4193..0000000 Binary files a/software/CPM/CPM02_HI_C/limits.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/link.com b/software/CPM/CPM02_HI_C/link.com deleted file mode 100644 index 6208ba5..0000000 Binary files a/software/CPM/CPM02_HI_C/link.com and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/math.h b/software/CPM/CPM02_HI_C/math.h deleted file mode 100644 index 616e4ea..0000000 Binary files a/software/CPM/CPM02_HI_C/math.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/objtohex.com b/software/CPM/CPM02_HI_C/objtohex.com deleted file mode 100644 index 65ed230..0000000 Binary files a/software/CPM/CPM02_HI_C/objtohex.com and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/optim.com b/software/CPM/CPM02_HI_C/optim.com deleted file mode 100644 index fcfcf04..0000000 Binary files a/software/CPM/CPM02_HI_C/optim.com and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/p1.com b/software/CPM/CPM02_HI_C/p1.com deleted file mode 100644 index 5caf0c6..0000000 Binary files a/software/CPM/CPM02_HI_C/p1.com and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/readme.txt b/software/CPM/CPM02_HI_C/readme.txt deleted file mode 100644 index a04a4b8..0000000 --- a/software/CPM/CPM02_HI_C/readme.txt +++ /dev/null @@ -1,18 +0,0 @@ -The HI-TECH Z80 CP/M C compiler V3.09 is provided free of charge for any -use, private or commercial, strictly as-is. No warranty or product -support is offered or implied. - -You may use this software for whatever you like, providing you acknowledge -that the copyright to this software remains with HI-TECH Software. - -The software is distributed in two archive files: - -Z80V309.EXE is a self-extracting lharc'ed archive containing the -entire compiler except for the library source code. - -LIBSRC.EXE is a self-extracting lharc'ed archive containg the library -source code. - -To de-archive these files you will need to either run them on a DOS -system, in which case they will self-extract, or use the LHARC program -to extract. LHARC is available for unix as well as DOS. diff --git a/software/CPM/CPM02_HI_C/rrtcpm.obj b/software/CPM/CPM02_HI_C/rrtcpm.obj deleted file mode 100644 index f7816e1..0000000 Binary files a/software/CPM/CPM02_HI_C/rrtcpm.obj and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/setjmp.h b/software/CPM/CPM02_HI_C/setjmp.h deleted file mode 100644 index 1560875..0000000 Binary files a/software/CPM/CPM02_HI_C/setjmp.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/signal.h b/software/CPM/CPM02_HI_C/signal.h deleted file mode 100644 index 9c2cf8c..0000000 Binary files a/software/CPM/CPM02_HI_C/signal.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/stat.h b/software/CPM/CPM02_HI_C/stat.h deleted file mode 100644 index ec6e3b6..0000000 Binary files a/software/CPM/CPM02_HI_C/stat.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/stdarg.h b/software/CPM/CPM02_HI_C/stdarg.h deleted file mode 100644 index 607bf98..0000000 Binary files a/software/CPM/CPM02_HI_C/stdarg.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/stddef.h b/software/CPM/CPM02_HI_C/stddef.h deleted file mode 100644 index 75367f2..0000000 Binary files a/software/CPM/CPM02_HI_C/stddef.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/stdio.h b/software/CPM/CPM02_HI_C/stdio.h deleted file mode 100644 index b7d19ff..0000000 Binary files a/software/CPM/CPM02_HI_C/stdio.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/stdlib.h b/software/CPM/CPM02_HI_C/stdlib.h deleted file mode 100644 index 40dabbe..0000000 Binary files a/software/CPM/CPM02_HI_C/stdlib.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/string.h b/software/CPM/CPM02_HI_C/string.h deleted file mode 100644 index 472334d..0000000 Binary files a/software/CPM/CPM02_HI_C/string.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/sys.h b/software/CPM/CPM02_HI_C/sys.h deleted file mode 100644 index fdc4e34..0000000 Binary files a/software/CPM/CPM02_HI_C/sys.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/time.h b/software/CPM/CPM02_HI_C/time.h deleted file mode 100644 index c1cbc08..0000000 Binary files a/software/CPM/CPM02_HI_C/time.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/unixio.h b/software/CPM/CPM02_HI_C/unixio.h deleted file mode 100644 index c74e692..0000000 Binary files a/software/CPM/CPM02_HI_C/unixio.h and /dev/null differ diff --git a/software/CPM/CPM02_HI_C/zas.com b/software/CPM/CPM02_HI_C/zas.com deleted file mode 100644 index 7746c14..0000000 Binary files a/software/CPM/CPM02_HI_C/zas.com and /dev/null differ diff --git a/software/CPM/CPM03_FORTRAN80/cpmio.mac b/software/CPM/CPM03_FORTRAN80/cpmio.mac deleted file mode 100644 index a9151c3..0000000 --- a/software/CPM/CPM03_FORTRAN80/cpmio.mac +++ /dev/null @@ -1,87 +0,0 @@ -TITLE CPMIO CONSOLE I/O ROUTINES FOR CP/M - ENTRY $TTYIN,$TTYOT,$LNPTR,$CPMBF,$LINBF -TANDY EQU 0 -CPMSBC EQU 0 -; -IF2 -.PRINTX /CPMIO/ -IFT TANDY -.PRINTX/TANDY VERSION/ -ENDIF -IFT CPMSBC -.PRINTX/CPM SBC VERSION/ -ENDIF -IFF TANDY OR CPMSBC -.PRINTX/NORMAL CPM VERSION/ -ENDIF -ENDIF -; -IFT TANDY -CPMENT SET 4205H -ENDIF -IFF TANDY -CPMENT SET 5 -ENDIF -IFT CPMSBC -CPMENT SET 4005H -ENDIF -;CP/M CONSOLE OUTPUT ROUTINE -$TTYOT: PUSH B - PUSH D - PUSH H - PUSH PSW ;SAVE ALL REG'S - MVI C,2 ;CONSOLE OUTPUT - MOV E,A ;EXPECTS CHAR IN [E] - CALL CPMENT ;OUTPUT THE CHAR - POP PSW - POP H - POP D - POP B ;RESTORE STATE - RET -; -;CP/M CONSOLE INPUT ROUTINE -;NOTE: DON'T STOP PROGRAM IN INPUT WITH SWITCHES, COULD LEAVE -; GARB IN LINE IF THEN SAVED AND STARTED OVER. -$TTYIN: PUSH H ;SAVE [H,L] - LHLD $LNPTR ;POINT TO LAST CHAR - MOV A,M ;GET LAST CHAR - CPI 12Q ;FINISHED OFF LINE(LF)? - CZ GETLIN ;YES, GET ANOTHER - INX H ;POINT TO NEXT CHAR - MOV A,M ;GET IT - SHLD $LNPTR ;SAVE PTR - POP H ;RESTORE - RET -; -GETLIN: PUSH B - PUSH D ;SAVE OTHER REG'S - MVI C,12Q ;READ CONSOLE LINE - LXI D,$CPMBF ;PTR TO BUFFER - CALL CPMENT ;READ LINE FROM CONSOLE - LXI H,$CPMBF+1 ;POINT TO LENGTH OF LINE - MOV E,M ;GET LENGTH - MVI D,0 ;[D,E] = LENGTH - XCHG ;SAVE [H,L] IN [D,E] - DAD D ;GET PTR TO LAST CHAR - INX H - MVI M,15Q ;ADD - INX H - MVI A,12Q ;LINE FEED - CALL $TTYOT ;CPM DOESN'T GIVE ONE - MOV M,A ;AND - XCHG ;[H,L]=1ST CHAR -1 - POP D - POP B - RET -; -DSEG -$CPMBF: DB 80 ;LENGTH OF BUFFER - DB 0 ;LENGTH OF LINE -$LINBF: DB 12Q ;SO WORKS AT FIRST - DS 135 ;REST OF BUFFER FOR LINE -; -$LNPTR: DW $LINBF ;AT FIRST POINT TO IN FRONT -; ;TO FORCE READ OF LINE -; - END - \ No newline at end of file diff --git a/software/CPM/CPM03_FORTRAN80/crcklist.crc b/software/CPM/CPM03_FORTRAN80/crcklist.crc deleted file mode 100644 index f39d9ef..0000000 --- a/software/CPM/CPM03_FORTRAN80/crcklist.crc +++ /dev/null @@ -1,16 +0,0 @@ - ---> FILE: CPMIO .MAC CRC = 71 D9 ---> FILE: CREF80 .COM CRC = BB F2 ---> FILE: DSKDRV .MAC CRC = 7A 3B ---> FILE: DTBF .MAC CRC = 26 3C ---> FILE: F80 .COM CRC = EF E2 ---> FILE: FCHAIN .MAC CRC = DA 61 ---> FILE: FORLIB .REL CRC = DA 31 ---> FILE: INIT .MAC CRC = 81 21 ---> FILE: IOINIT .MAC CRC = 51 55 ---> FILE: L80 .COM CRC = 15 DF ---> FILE: LIB .COM CRC = 24 15 ---> FILE: LPTDRV .MAC CRC = 0B 56 ---> FILE: LUNTB .MAC CRC = 71 25 ---> FILE: M80 .COM CRC = 69 DB ---> FILE: TTYDRV .MAC CRC = C2 85 \ No newline at end of file diff --git a/software/CPM/CPM03_FORTRAN80/cref80.com b/software/CPM/CPM03_FORTRAN80/cref80.com deleted file mode 100644 index e125339..0000000 Binary files a/software/CPM/CPM03_FORTRAN80/cref80.com and /dev/null differ diff --git a/software/CPM/CPM03_FORTRAN80/dskdrv.mac b/software/CPM/CPM03_FORTRAN80/dskdrv.mac deleted file mode 100644 index c34d437..0000000 --- a/software/CPM/CPM03_FORTRAN80/dskdrv.mac +++ /dev/null @@ -1,860 +0,0 @@ - TITLE DSKDRV - FORTRAN-80 DISK DRIVER - - .8080 - -MAXLUN EQU 10 ;MAX # OF LUN'S ALLOWED - -;BDOS FUNCTION CALLS, FCB OFFSETS - -BDOS EQU 5 ;CP/M BDOS ENTRY POINT - -.RSET EQU 13 ;DISK RESET -.SELCT EQU 14 ;SELECT DISK -.OPEN EQU 15 ;OPEN FILE -.CLOSE EQU 16 ;CLOSE FILE -.DELET EQU 19 ;DELETE FILE -.MAKE EQU 22 ;CREATE FILE -.STDMA EQU 26 ;SET DMA ADDRESS - -FCB.FT EQU 9 ;FILE TYPE -FCB.EX EQU 12 ;EXTENT BYTE -FCB.RC EQU 15 ;RECORD COUNT BYTE -FCB.NR EQU 32 ;NEXT RECORD BYTE -FCB.RR EQU 33 ;RANDOM RECORD NUMBER (2.X) -FCBLEN EQU 36 ;FCB SIZE - -SECSIZ EQU 128 ;SECTOR SIZE (RECORD LENGTH) - -; GLOBAL DEFINITIONS - - EXTRN $CPMVN,$CPMRF,$CPMWF,$BL,$BF,$ERR - EXTRN $IOERR,$REC,$UN,$LUNTB,$CLSFL - - ENTRY $DSKER,$FLFLG,$MEMRY,DSKDRV - - DSEG ;DATA AREA - -; I/O ERROR CODE DEFNS - -OBOVF EQU 016Q ;OUTPUT BUFFER LIMIT EXCEEDED -IRECER EQU 022Q ;INPUT RECORD TOO LONG -NOFILE EQU 236Q ;FILE NOT FOUND -FULERR EQU 237Q ;DISK FULL -LUNERR EQU 240Q ;LUN TOO LARGE -NOMEM EQU 241Q ;OUT-OF-MEMORY - -; I/O MODE DEFN BYTE - -MD.ALC EQU 80H ;80H ALLOCATED BUFFER AND FCB -MD.OPN EQU 40H ;40H FILE IS OPEN -MD.OUT EQU 20H ;20H IF OUTPUT -MD.BIN EQU 10H ;10H IF UNFORMATTED I/O - -MD.WRT EQU 08H ;08H WRITE-DATA-IN-BUFFER -MD.RND EQU 04H ;04H IF RANDOM I/O - -$FLFLG: DS MAXLUN ;I/O MODE BYTE FOR EACH LUN -$FLCNT: DS MAXLUN ;I/O BUFFER INDEX FOR EACH LUN -$FLBUF: DS MAXLUN*2 ;BUFFER LOCATION FOR EACH LUN -$FLFCB: DS MAXLUN*2 ;FCB LOCATION FOR EACH LUN - -$DSKER: DS 1 ;STATUS OF LAST I/O -CLSADR: DS 2 - -$MEMRY: DS 2 ;FOR LOADER TO STORE TOP OF MEM INTO - - CSEG ;CODE AREA - -FILTXT: DB "FORT",0 ;DEFAULT FILENAME TEXT -FILEXT: DB "DAT",0 - - PAGE - -; I/O DISPATCH TABLE - -; LUN'S 6 THRU MAXLUN POINT TO THIS TABLE VIA $LUNTB. -; AN EXPLICIT OPEN VIA CALL OPEN () ALLOW -; OTHER UNITS TO USE THE DISK ALSO... - -DSKDRV: DW DSKFRD ;FORMATTED READ - DW DSKFWR ;FORMATTED WRITE - DW DSKURD ;UNFORMATTED READ - DW DSKUWR ;UNFORMATTED WRITE - DW DSKREW ;REWIND - DW $IOERR ;BACKSPACE (NOT SUPPORTED). - DW DSKCLS ;ENDFILE - -FNFERR: CALL $ERR - DB NOFILE ;FILE NOT FOUND - -DSKFUL: CALL $ERR - DB FULERR ;DISK FULL - -LUNOVF: CALL $ERR - DB LUNERR ;LUN TOO LARGE - -MEMERR: CALL $ERR - DB NOMEM ;OUT-OF-MEMORY - -;------------------------------------------------------ -; -; GET MODE BYTE(LUN) FROM $FLFLG -; -GTMODE: LXI H,$FLFLG-1 - LDA $UN ;GET UNIT # - MVI D,0 - MOV E,A - DAD D ;[HL] POINTS TO FLAG - MOV A,M ;GET FLAG - RET -;------------------------------------------------------ -; -; SET DMA TO DATA BUFFER(LUN) -; -SETBUF: PUSH B - PUSH D - CALL GETBUF ;GET BUFFER ADR - MVI C,.STDMA - CALL BDOS - POP D - POP B - RET -;------------------------------------------------------ -GETBUF: LDA $UN - ADD A - MOV E,A - MVI D,0 - LXI H,$FLBUF-2 - DAD D - MOV E,M - INX H - MOV D,M - RET - -;------------------------------------------------------ -; -; GET DATA.BUFFER.OFFSET(LUN) -; -GTBOFF: - LXI H,$FLCNT-1 - LDA $UN - MVI D,0 - MOV E,A - DAD D - MOV A,M ;GET OFFSET - RET - -;------------------------------------------------------ -; -; GET ADR OF FCB(LUN) IN [DE] -; -GTFCB: LXI H,$FLFCB-2 - LDA $UN - ADD A - MOV E,A - MVI D,0 - DAD D ;POINT TO ADR OF FCB - MOV E,M - INX H - MOV D,M - RET - -;------------------------------------------------------ -; -; GET READ/WRITE RECORD NUMBER FOR LUN -; ON RETURN: -; [HL] = FCB.RR(LUN) ADR OF RND REC NUM. -; [DE] = $REC 00 OR RND REC NUM. -; -GTREC: - CALL GTFCB - LXI H,FCB.RR - DAD D - XCHG - LHLD $REC - XCHG - RET -;------------------------------------------------------ -; ZERO FCB FROM EXTENT BYTE TO END. -; -CLRFCB: - CALL GTFCB - LXI H,FCB.EX - DAD D - LXI B,FCBLEN-FCB.EX -CLRFCL: - MOV M,B - INX H - DCR C - JNZ CLRFCL - RET -;------------------------------------------------------ -; COPY BYTES FROM [DE] TO [HL] UNTIL NULL (00). -; -CPYTXT: - MOV M,A ;COPY FROM [DE] TO [HL] - INX H ;UNTIL NULL. - INX D - LDAX D - ORA A - JNZ CPYTXT - RET - - PAGE -;------------------------------------------------------ -; -; OPNCHK - ASSURE THAT FILE IS OPEN AND BUFFERS ALLOCATED. -; IF NOT THEN: -; 1. ALLOCATE DATA BUFFER AND FCB FROM $MEMRY. -; 2. OPEN FILE WITH NAME OF FORT##.DAT WHERE: -; ## IS LOGICAL-UNIT-NUMBER (LUN) OF FILE. - -OPNCHK: - LDA $UN - CPI MAXLUN+1 ; - JNC LUNOVF ;LUN IS TOO LARGE -; ---------------- - PUSH B ;SAVE OPEN MODE REQUEST. - CALL GTMODE ;GET FLAG - ORA A ;ALLOCATED BUFFER,FCB? - CP ALCBUF ;NO, GET SPACE AND SET PTRS -; ---------------- - POP B ;GET I/O MODE IN [C] - ANI MD.OPN ;WAS OPEN? - CZ OPNFIL ;NO, OPEN FILE. - -;------------------------------------------------------ -; -; SETREC - SET UP RECORD NUMBER -; -SETREC: - CALL GTREC ;GET CURRENT & LAST RECORD NUMBERS - MOV A,D ;[DE] = $REC - ORA E ;IF RANDOM I/O - JNZ SETRND ;USE VALUE IN $REC -; ---------------- - MOV E,M ;..ELSE - INX H ;USE CURRENT RECORD - MOV D,M ;SET BY SEQ READ/WRITE. - PUSH D ;SAVE REC NO. - CALL GTMODE - ANI NOT MD.RND ;SET SEQUENTIAL MODE - MOV M,A - POP D ;RESTORE REC NO. - JMP SETSEQ -; ---------------- -SETRND: - CALL GTMODE - ANI MD.WRT ;WRITE-DATA-IN-BUFFER? - CNZ FRCOUT ;YES, FLUSH IT FIRST. - CALL GTMODE - ORI MD.RND ;SET RANDOM MODE - MOV M,A - CALL GTREC ;RESTORE REC NO'S. - DCX D ;ADJUST RANDOM REC NO. - MOV M,E - INX H ;STORE AT FCB.RR FOR NEXT I/O - MOV M,D - INX H - MVI M,0 -; ---------------- -SETSEQ: - LDA $CPMVN ;CP/M VERSION FLAG - ORA A ;VERSION 1.X ? - RZ ;NO, VERSION 2.X NOTHING ELSE NEEDED. -;------------------------------------------------------ -; -; SPLIT RANDOM RECORD INTO EXTENT AND RELATIVE RECORD -; FOR VERSION 1.X -; -SETV1: - MOV A,E - RAL - MOV A,D - RAL - MOV B,A - MOV A,E - ANI X'7F' - MOV C,A -; ---------------- - CALL GTFCB ;[DE] = ADR OF FCB(LUN) - LXI H,FCB.EX - DAD D - MOV A,M ;FETCH CURRENT EXTENT - CMP B - JZ SAMEXT ;IF SAME AS REQUESTED EXTENT -; -; CLOSE CURRENT EXTENT, OPEN REQUESTED ONE -; - PUSH B ;EXT/REC - PUSH D ;FCB ADR - LXI H,FCB.NR - DAD D - MVI M,0 ;ZERO THE RECORD NUMBER - LHLD $MEMRY ;GET SCRATCH BUFFER - XCHG ;FROM TOP OF HEAP FOR OPEN/CLOSE - MVI C,.STDMA - CALL BDOS - CALL GTMODE - ANI MD.OUT ;OPEN FOR OUTPUT? - JZ OPNXT ;NO, SKIP THIS CLOSE - POP D - PUSH D ;FCB - MVI C,.CLOSE - CALL BDOS -OPNXT: - POP D ;FCB - POP B ;EXT/REC - PUSH B - PUSH D - LXI H,FCB.EX - DAD D - MOV M,B ;SET NEW EXTENT NUMBER - MVI C,.OPEN - CALL BDOS - INR A - JNZ SKEXT ;IF IT EXISTS - POP D - PUSH D ;FCB - CALL MAKEXT ;CREATE NEW EXTENT -SKEXT: - POP D ;FCB - POP B ;EXT/REC -SAMEXT: - LXI H,FCB.NR - DAD D - MOV M,C ;SET RECORD NUMBER - RET - - PAGE -;------------------------------------------------------ -; ALLOCATE FCB AND BUFFER FOR UNIT . ALLOCATES UP FROM -; $MEMRY AND STORES PTRS IN TABLE. - -ALCBUF: PUSH H - LHLD $MEMRY ;GET CURRENT TOP - XCHG ;IN [DE] -; ---------------- - LXI H,-256 - DAD SP - MOV A,L - SUB E ;IF MEMTOP-256 < $MEMRY, - MOV A,H ;THEN GIVE OUT-OF-MEMORY - SBB D ;ERROR AND EXIT... - JC MEMERR -; ---------------- - LXI H,$FLBUF-2 - LDA $UN - ADD A - MVI B,0 - MOV C,A ;[BC]= 2*UNIT# - DAD B ;GET ADR OF PTR TO BUFFER - MOV M,E - INX H - MOV M,D ;STORE $MEMRY AS ADR - LXI H,SECSIZ - DAD D ;GET NEW TOP - PUSH H ;SAVE FCB ADR - CALL GTFCB ;GET [HL]=ENTRY+1 - POP D - PUSH D ;SAVE FCB ADR - MOV M,D - DCX H - MOV M,E ;STORE ADR OF FCB - LXI H,FCBLEN - DAD D ;GET NEW TOP OF ALLOC - SHLD $MEMRY ;STORE AWAY -; ---------------- - POP H ;FCB ADR. - MVI M,0 ;DEFAULT TO CURRENT DISK - INX H - LXI D,FILTXT ;DEFAULT NAME INITIALLY FORT##.DAT - LDAX D - CALL CPYTXT ;MOVE "FORT" TO FCB - LDA $UN - MOV B,A ;SAVE UNIT # - SUI 10 ;CARRY SET IF NOT UNIT 10 - SBB A - ADI "1" ;"1" IF 10 ELSE "0" - MOV M,A ;STORE DIGIT 1 OF # - MOV A,B - CPI 10 ;WAS IT 10? - JC SKPSTZ ;NO, DON'T SET ZERO - XRA A -SKPSTZ: ADI "0" ;GET 2ND DIGIT - INX H - MOV M,A - MVI A," " - INX H - MOV M,A - INX H - LXI D,FILEXT-1 ;EXTENSION - CALL CPYTXT ;MOVE "DAT" TO FCB -; ---------------- - POP H ;GET PTR TO FLAG - MVI A,MD.ALC ;NOW ALLOCATED. - MOV M,A ;SET FLAG - RET - - PAGE -;------------------------------------------------------ -; -; OPEN FILE GIVEN BY LUN AND CLEAR BUFFER INDEX. -; ENTRY: [DE] = ADR OF FCB -; EXIT: [HL] = ADR OF MODE BYTE -; [A] = MODE BYTE - ALLOCATED & OPEN. -; -OPNFIL: - PUSH B ;SAVE I/O MODE - CALL GTBOFF ;GET BUFFER.OFFSET(LUN) - MOV M,D ;CLEAR BUFFER INDEX -; ---------------- - LHLD $CLSFL - LXI D,CLSALL - MOV A,H - SUB D - JNZ STRADR ;NOT US, STORE ROUTINE ADR - MOV A,L - SUB E - JZ STRCLS ;US, DON'T STORE AGAIN -STRADR: SHLD CLSADR -STRCLS: XCHG - SHLD $CLSFL ;ON EXIT, CLOSE ALL FILES - CALL CLRFCB ;ZERO FCB & RECORD NUMBER. - CALL SETBUF ;SET DMA TO FILE BUFFER. -; ---------------- - POP B ;I/O MODE - PUSH B - MOV A,C - ANI MD.OUT - JZ OPNINP ;BRIF OPEN INPUT -;------------------------------------------------------ -; -; OPEN NEW FILE FOR OUTPUT OR RANDOM. -; - PUSH D ;SAVE FCB ADR - MVI C,.DELET ;DELETE OLD FILE - CALL BDOS - POP D - PUSH D - CALL MAKEXT ;CREATE NEW FILE. - POP D ;RESTORE FCB ADR -;------------------------------------------------------ -; -; OPEN EXISTING FILE FOR INPUT OR RANDOM. -; -OPNINP: - MVI C,.OPEN ;OPEN FILE - CALL BDOS - INR A - JZ FNFERR ;BRIF FILE NOT FOUND (FATAL). - -OPNDON: - CALL GTMODE - POP B ;GET I/O MODE. - MOV A,C - ORI MD.ALC+MD.OPN - MOV M,A ;MODE ALLOCATED/OPEN + I/O - RET - -;------------------------------------------------------ -; -; MAKE NEW FILE OR EXTENT. -; -MAKEXT: - MVI C,.MAKE ;CREATE NEW FILE - CALL BDOS - INR A - JZ DSKFUL ;BRIF DISK FULL ERROR. - RET - - PAGE -;------------------------------------------------------ -; -; REWIND UNIT # -; -DSKREW: CALL GTMODE - ANI MD.OPN ;FILE OPEN? - CNZ DSKCLS ;YES, CLOSE IT -NOCLOS: XRA A ;GOOD RETURN - RET - -;------------------------------------------------------ -; -; ENDFILE UNIT # -; -DSKCLS: CALL GTMODE - ADD A ;OPEN? - JP NOCLOS ;NO, DON'T CLOSE - MVI M,MD.ALC ;FLAG CLOSED NOW - ADD A ;OUTPUT FILE? - CM FRCBUF ;YES, DUMP LAST IF NEEDED - CALL GTFCB ;GET ADDR OF FCB - CALL SETBUF ;SET DMA ADR - MVI C,.CLOSE ;CLOSE FILE - CALL BDOS - XRA A ;NEVER AN ERROR - RET - -;------------------------------------------------------ -; -; CLOSE ALL FILES. CALLED FROM EXIT -; -CLSALL: LXI D,1 -CLSAL1: LXI H,$FLFLG-1 - DAD D - MOV A,M - ADD A ;SET MINUS IF OPEN - PUSH D ;SAVE UNIT # - MOV A,E - STA $UN ;SET UP FOR OTHERS - CM DSKCLS ;CLOSE FILE IF OPEN - POP D ;GET # BACK - INX D ;BUMP IT - LDA $LUNTB ;GET MAX LUN - CMP E ;DONE ALL? - JNZ CLSAL1 ;NO, DO NEXT - RET ;RETURN - - PAGE -;------------------------------------------------------ -; -; UNFORMATTED WRITE -; -DSKUWR: - MVI C,MD.OUT+MD.BIN - CALL OPNCHK ;OPEN IF NOT OPEN - LHLD $BF ;GET BUFFER ADR - PUSH H - XCHG - LHLD $BL ;GET LENGTH OF DATA - MVI H,0 ;# OF BYTES - XCHG - DAD D ;PTR TO 1ST TO CLEAR - XRA A - DCR E -DSKWCL: - INR E ;CLEARED REST OF BUFFER? - JM DSKUW1 ;YES, DONE - MOV M,A - INX H - JMP DSKWCL ;CLEAR END OF BUFFER -DSKUW1: - POP D ;GET BUFFER ADR - MVI C,.STDMA ;SET DMA TO BUFFER - CALL BDOS - CALL WRITE ;WRITE RECORD - ORA A ;ERROR? - RZ ;NO, GOOD RETURN - STC - RET - - PAGE -;------------------------------------------------------ -; -; UNFORMATTED READ -; -DSKURD: - MVI C,MD.BIN - CALL OPNCHK ;OPEN IF NEEDED - LHLD $BF - XCHG - MVI C,.STDMA ;SET DMA TO $BF - CALL BDOS - MVI A,128 - STA $BL ;ALWAYS 1 SECTOR - CALL READ ;READ RECORD INTO $BF - ORA A ;EOF OR GOOD - RZ - CPI 2 - CMC - RET -; - PAGE -;------------------------------------------------------ -; -; FORMATTED WRITE -; -DSKFWR: - MVI C,MD.OUT - CALL OPNCHK ;OPEN FILE IF NEEDED - XRA A - STA $DSKER ;CLEAR COUNT - LDA $BL ;GET # TO WRITE - ORA A - RZ ;IGNORE NULL BUFFERS - LDA $BL - ORA A - JP DSKFW0 - CALL $ERR ;WARN USER OF.. - DB OBOVF ;OUTPUT BUFFER LIMIT EXCEEDED - MVI A,127 ;AND TRUNCATE TO 127 BYTES. -DSKFW0: - CALL RNDCHK ;IF RND MODE, SET OFFSET TO 0. - LHLD $BF ;GET BUFFER PTR -DSKFW2: - PUSH PSW ;SAVE COUNT - MOV A,M - CALL DSKOUT ;SEND OUT BYTE - INX H ;INCREMENT BUFFER PTR - POP PSW ;RETRIEVE COUNT - DCR A ;DECREMENT COUNT - JNZ DSKFW2 ;ONE MORE TIME -; -DSKWDN: MVI A,15Q - CALL DSKOUT ;PUT OUT - CALL GTMODE ;MARK MODE BYTE WITH - ORI MD.WRT ;WRITE-DATA-IN-BUFFER. - MOV M,A - LDA $DSKER ;GET $DSKEROR STATUS - ORA A ;ERROR? - RZ ;NO - STC ;YES - RET -; - PAGE -;------------------------------------------------------ -; -; FORMATTED READ -; -DSKFRD: - MVI C,0 - CALL OPNCHK ;OPEN IF NEEDED - XRA A - STA $BL ;CLEAR LENGTH OF RECORD - STA $DSKER ;CLEAR $DSKEROR - CALL RNDCHK ;IF RND MODE, SET OFFSET TO 0. -DSKFR1: - CALL DSKIN ;GET CHAR - JC DSKRDN ;JUMP IF EOF - CPI 32Q ;CP/M EOF? - JZ DSKEOF ;YES - LHLD $BL - MVI H,0 - XCHG - LHLD $BF ;BASE - DAD D ;GET WHERE TO PUT BYTE - MOV M,A ;STORE CHAR - INX D ;BUMP OFFSET - XCHG - SHLD $BL ;UPDATE OFFSET - CPI 15Q ;? - JZ DSKRDN ;YES, HAVE RECORD - MOV A,L ;GET OFFSET - CPI 128 ;BUFFER FULL? - JC DSKFR1 ;NO, GET NEXT - CALL $ERR ;WARN USER OF.. - DB IRECER ;INPUT RECORD TOO LONG. - XRA A - RET -; -DSKRDN: LDA $DSKER ;GET STATUS - ORA A - RZ ;NO ERROR - CPI 2 - CMC - RET -DSKEOF: ORA A ;SET CC'S - RET -; - PAGE -;------------------------------------------------------ -; -; RESET BUFFER OFFSET IF RANDOM READ OR WRITE -; -RNDCHK: - PUSH PSW - CALL GTMODE - ANI MD.RND - JZ RNDCHX ;DO NOTHING IF SEQUENTIAL MODE. - CALL GTBOFF ;ELSE ZERO BUFFER OFFSET SO.. - MVI M,0 ;NEXT READ/WRITE STARTS AT BEGINNING. -RNDCHX: - POP PSW - RET -;------------------------------------------------------ -; -; DISK INPUT ROUTINE -; -DSKIN: - CALL GTBOFF ;BUFFER.OFFSET(LUN) - ORA A ;BUFFER EMPTY? - CZ REDBUF ;YES, REFIL - RC ;EOF - DCR M ;DECR. # LEFT - LXI H,$FLBUF-2 - DAD D - DAD D ;GET $FLBUF PTR - CMA - ADI 129 ;128-#LEFT=OFFSET - ADD M - MOV E,A - INX H - MVI A,0 - ADC M - MOV D,A - LDAX D ;GET CHAR - ORA A - RET -;------------------------------------------------------ -; -; READ BUFFER FROM DISK -; -REDBUF: PUSH H - PUSH D - CALL SETBUF - CALL READ ;READ RECORD - STA $DSKER ;STORE STATUS - ORA A - POP D - POP H - MVI A,128 ;FULL BUFFER - MOV M,A ;STORE COUNT - RZ ;IF NO ERROR - STC - RET - -;------------------------------------------------------ -; -; DISK OUTPUT ROUTINE -; -DSKOUT: PUSH H - PUSH PSW - CALL GTBOFF ;GET BUFFER OFFSET - ORA A ;BUFFER FULL? - CM DMPBUF ;YES, DUMP - INR M - LXI H,$FLBUF-2 - DAD D - DAD D ;POINT TO ADR OF BUFFER - ADD M - MOV E,A - INX H - MVI A,0 - ADC M - MOV D,A ;POINTS TO FREE - POP PSW ;GET CHAR BACK - STAX D ;STORE CHAR - POP H - RET - -;------------------------------------------------------ -; -; FORCE FORMATTED BUFFER OUT ON CLOSE -; -FRCBUF: ADD A ;UNFORMATTED I/O? - JM FRCOUT ;YES, FORCE OUT LAST IF NEEDED - MVI A,32Q - CALL DSKOUT ;SET END OF FILE - -FRCOUT: CALL GTBOFF ;BUFFER.OFFSET(LUN) - ORA A ;EMPTY? - MVI M,0 ;CLEAR OFFSET - RZ ;YES, DO NOTHING - PUSH PSW ;SAVE OFFSET - CALL GETBUF ;GET BUFFER ADR - POP PSW - MOV L,A - MVI H,0 - DAD D ;POINT TO 1ST UNUSED -CHKFIL: ORA A ;SET MINUS IF FULL - JM DMPBF1 ;NOTHING TO FILL - MVI M,0 ;CLEAR BYTE - INX H - INR A ;BUMP OFFSET - JMP CHKFIL -;------------------------------------------------------ -; -; DUMP BUFFER TO DISK -; -DMPBF1: - DCX H ;SO THAT DRIVE # ISN'T CLEARED -DMPBUF: - PUSH H - PUSH D - CALL SETBUF - CALL WRITE ;WRITE RECORD - STA $DSKER ;STORE STATUS - CALL GTMODE - ANI NOT MD.WRT ;CLEAR WRITE-DATA BIT - MOV M,A - POP D - POP H - XRA A - MOV M,A ;CLEAR BUFFER OFFSET - RET - -;------------------------------------------------------ -; -; READ RECORD/WRITE RECORD PRIMITIVES -; -READ: CALL GTFCB ;GET ADDR OF FCB - LDA $CPMRF ;CP/M 1.X OR 2.X - MOV C,A ;RANDOM READ FUNCTION - JMP IOCALL - -WRITE: CALL GTFCB ;GET ADDR OF FCB - LDA $CPMWF ;CP/M 1.X OR 2.X - MOV C,A ;RANDOM WRITE FUNCTION - -IOCALL: CALL BDOS ;DO APPROPRIATE FUNCTION - PUSH PSW ;SAVE ERROR RESULT - CALL GTREC ;POINT TO RECORD NUMBER - INR M ;UPDATE SEQUENTIAL - JNZ POPART ; RECORD NUMBER - INX H - INR M - -POPART: POP PSW ;RESTORE ERROR - RET - - PAGE -;------------------------------------------------------ -; -; CALL OPEN(UNIT #,FILENAME,DRIVE #) -; - ENTRY OPEN - EXT $IOINIT - -OPEN: LDA $LUNTB ;GET MAX LUN - DCR A - CMP M ;OUT OF RANGE? - JC LUNOVF ;YES, LUN TOO LARGE. - - MOV A,M ;FETCH LUN - STA $UN ;SET IT UP - PUSH D ;SAVE REGISTERS - PUSH B ;SAVE FILPTR - CALL $IOINIT ;INITIALIZE IF NOT ALREADY DONE - CALL GTMODE - ORA A ;ALLOCATED? - CP ALCBUF ;NO, ALLOCATE - POP B - CALL GTFCB - XCHG - POP D ;[DE]=NAME PTR - LDAX B ;GET DRIVE # - MOV M,A ;STORE DRIVE # - MVI B,11 ;COPY FILE NAME TO FCB -FILLOP: LDAX D - ORA A ;ZERO BYTE? - JZ FILLEN ;YES, LEAVE REST AS BEFORE - INX D - INX H - MOV M,A - DCR B ;FINISHED MOVING NAME? - JNZ FILLOP ;NO, DO REST -FILLEN: LDA $UN ;GET UNIT # - ADD A ;*2 FOR TABLE INDEX - MVI D,0 - MOV E,A - LXI H,$LUNTB ;INDEX INTO LUN TABLE - DAD D - LXI B,DSKDRV ;REPLACE CURRENT LUNTB ENTRY - MOV M,B ; WITH ADDRESS OF DISK DRIVER - DCX H ; DISPATCH ADDRESS - MOV M,C - RET - - END - \ No newline at end of file diff --git a/software/CPM/CPM03_FORTRAN80/dtbf.mac b/software/CPM/CPM03_FORTRAN80/dtbf.mac deleted file mode 100644 index d78a6ba..0000000 --- a/software/CPM/CPM03_FORTRAN80/dtbf.mac +++ /dev/null @@ -1,56 +0,0 @@ -TITLE DTBF Runtime data buffer -; -TRSDOS EQU 0 -OASIS EQU 0 -; -IF2 -IFT TRSDOS -.PRINTX/TRSDOS VERSION/ -ENDIF -IFT OASIS -.PRINTX/OASIS VERSION/ -ENDIF -ENDIF -; -ENTRY $DTBF,$DTBF1,$DTBF3,$DTBF5,$DTBF7,$DTBF8,$DTBFA -; -DSEG -; -$DTBF: DS 1 ;DATA BUFFER -$DTBF1: DS 2 -$DTBF3: DS 2 -$DTBF5: DS 2 -$DTBF7: DS 1 -$DTBF8: DS 8 -$DTBFA: DS 145-16 -IFT TRSDOS - DS 115 ;TRSDOS USES UP TO 256 BYTE BUFFERS -ENDIF -IFT OASIS - DS 375 ;OASIS USES UP TO 512 BYTE BUFFERS -ENDIF -; -CSEG -ENTRY $FORLN,$UFMLN -; -$FORLN: -IFT TRSDOS - DW 256 -ENDIF -IFT OASIS - DW 512 -ENDIF -IFF TRSDOS OR OASIS - DW 132 -ENDIF -; -$UFMLN: -IFT TRSDOS - DW 256 -ENDIF -IFF TRSDOS - DW 128 -ENDIF -; - END - \ No newline at end of file diff --git a/software/CPM/CPM03_FORTRAN80/f80.com b/software/CPM/CPM03_FORTRAN80/f80.com deleted file mode 100644 index bd533f2..0000000 Binary files a/software/CPM/CPM03_FORTRAN80/f80.com and /dev/null differ diff --git a/software/CPM/CPM03_FORTRAN80/fchain.mac b/software/CPM/CPM03_FORTRAN80/fchain.mac deleted file mode 100644 index 42fdc74..0000000 --- a/software/CPM/CPM03_FORTRAN80/fchain.mac +++ /dev/null @@ -1,460 +0,0 @@ - SUBTTL Global Equates,Temps,Defs - TITLE FCHAIN - Fortran CALL FCHAIN Statement - - ENTRY FCHAIN - EXTRN $CLSFL,$INIT,$IOERR - -CPM SET 0 ; True for CP/M -CPM42 SET 1 ; True for CP/M's at X'4200' -ISIS SET 0 ; True for ISIS-II -MOD1 SET 0 ; True for TRS-80 Mod-1 -MOD2 SET 0 ; True for TRS-80 Mod-2 -TEK SET 0 ; True for Tektronics - -CR SET 13 -LF SET 10 - -NAMLEN SET 11 ; Default Filename Length **3.36 - -IF MOD1 -NAMLEN SET 23 - ENDIF -IF MOD2 -NAMLEN SET 30 - ENDIF - - -IF CPM42 -CPM SET 1 - ENDIF -IF CPM -CPMWRM SET 0 ; CP/M Base ( & Warm Boot Addr) - ENDIF -IF CPM42 -CPMWRM SET 4200H - ENDIF -; ---- -IF CPM -C.EMSG SET 9 -C.OPEN SET 15 -C.READ SET 20 -C.BUFF SET 26 -CPMENT SET CPMWRM+5 ; CP/M Entry (BDOS Funct call addr) -TFCB SET CPMWRM+5CH -TBUFF SET CPMWRM+80H -TPA SET CPMWRM+100H - -;**3.36 DFTEXT: DB 'COM' - - ENDIF -; ================ -IF ISIS -CISIS SET 40H ;ISIS Entry Point -I.LOAD SET 6 ;Load Pgrm Function - ENDIF -; ================ -IF MOD1 -M.ABRT SET 4430H ;Error return to system -M.GET SET 13H ;Input a byte from an I/O device -M.OPEN SET 4424H ;Open an existing file -M.EXIT SET 402DH ;Normal return to system - ENDIF -; ================ -IF TEK -SRB SET 3 -T.CHAN SET SRB+1 ; Channel No. -T.LEN SET SRB+5 ; Filename Len -T.BPTR SET SRB+6 ; Address of Buffer -T.FNAM SET SRB+8 ; Filename Buffer - ENDIF -; ================ -IF2 - .PRINTX/Fortran CHAIN/ - IF CPM - .PRINTX/ For CPM/ - ENDIF - IF CPM42 - .PRINTX/ ..at 4200H/ - ENDIF - IF ISIS - .PRINTX/ For ISIS-II/ - ENDIF - IF MOD1 - .PRINTX/ For TRS80 Mod-1/ - ENDIF - IF MOD2 - .PRINTX/ For TRS80 Mod-2/ - ENDIF - IF TEK - .PRINTX/ For Tektronics/ - ENDIF -ENDIF - - PAGE - SUBTTL FCHAIN - Process a CALL FCHAIN statement - -; FCHAIN processes a CALL FCHAIN statement by the following steps: -; -; 1. Parse filename to see if valid -; -; 2. Open file in default OS File Control Block -; -; 3. Move a short program loader to top of memory -; and load new program -; -; SYNTAX: CALL FCHAIN (' ') - -; ENTRY [HL] = FWA SDESC for Filename -; EXIT Start executing new program -; USES ALL - -FCHAIN: -IF CPM - LDAX D ;Get Drive no. - STA TFCB ;Put in TFCB - ENDIF - SHLD .NFWA ; Save FWA of Name - LXI H,CHN01 - PUSH H - LHLD $CLSFL - PCHL ; Close all Files -CHN01: - LXI B,CHN02 ; Addr to RET to.. - JMP $INIT ; Reset SP to top of ram -CHN02: -IF CPM - CALL .SNAM ; Go scan filename - LXI D,TBUFF ;Set DMA buffer - MVI C,C.BUFF - CALL CPMENT - LXI D,TFCB ;Open file - MVI C,C.OPEN - CALL CPMENT - INR A - JZ $IOERR ; **IO** Error - File not found - LXI H,0 - DAD SP - DCR H - MVI L,0 ;Get 1 page below user stack - LXI D,LOADER ;Move program loader to high memory - MVI B,ENDIPL-IPL - CALL $$MOV - MOV L,B ;[HL] = addr of loader - PUSH H ;For 'RET' to loader - LXI D,LOCTAB ;[DE] = addr of ADDRESS MODIFY TABLE -CHN03: LDAX D ;Get low byte address - ORA A ;Are we done? - JZ CHN04 ; Yes - MOV L,A ;[HL] = address to modify - MOV M,H ;Modify it with [H] - INX D - JMP CHN03 ;Keep looping -CHN04: LXI H,TPA ;[HL] = TPA address - RET ;'RET' to loader -ENDIF -; ================ -IF ISIS - LHLD .NFWA - XCHG ;[DE] = Strt of Name - LXI H,I.FNAM - MVI B,15 - CALL $$MOV ;Move Filename to FCB - MVI C,I.LOAD ;Load Function - LXI D,I.FCB - CALL CISIS ;Load next Pgm & Go - JMP $IOERR ; (Just in case) - ENDIF -; ================ -IF MOD1 - LXI H,0 ;Get stack address - DAD SP - MVI L,0 ;Get below user stack - DCR H - DCR H ;Blocking buffer address - DCR H ;Loader start address - PUSH H ;Save loader start address - MVI B,32 ;Blank fill 32 byte DCB -SPLOOP: DCX H - MVI M,' ' - DCR B - JNZ SPLOOP - POP B ;Loader start address - PUSH H ;Save DCB addr - LHLD .NFWA - XCHG ;[DE] = Strt of Filename - POP H - PUSH H ;[HL] = DCB addr - PUSH B ;Save loader start address - CALL .SNAM ;Scan Filename into DCB - MVI B,0 ;LRL = 256 - POP H ;Loader start address - POP D ;DCB (Filespec) address - PUSH D ;Save DCB address - PUSH H ;Save loader start address - INR H ;Blocking buffer address - CALL M.OPEN ;Open an existing file - JNZ $IOERR ;**IO** Err - Fnf. - - DCR H ;Top loader start address - LXI D,LOADER ;Loader start address - MVI B,ENDIPL-IPL ;Size of loader program - CALL $$MOV ;Move to top of memory - - POP H ;Loader start address - POP D ;DCB address - PCHL ;Run loader -ENDIF -; ================ -IF MOD2 - LHLD .NFWA ;[HL] points to name - PUSH H ;Save SOS - LXI B,NAMLEN ;[B]=0, [C]=Max Name Len -CHN03: - MOV A,M - CPI ' '+1 - JC CHN04 ;Brif EOS - INX H - INR B ;String Len+1 - DCR C ;Max len-1 - JNZ CHN03 - JMP $IOERR ;**IO** Error, Name too long -CHN04: - MVI M,CR ;Proper TRSDOS Terminator - POP H ;Get SOS - MVI A,37 ;Exeq TRSDOS cmnd, no ret - RST 1 ;Do it, [HL]=string, [B]=string len - JMP $IOERR ; (Who trusts Trash-DOS) -ENDIF -; ================ -IF TEK - LHLD .NFWA - XCHG ; [DE]=Filename STR - LXI H,T.FNAM ; [HL]=Filename Buffer - LXI B,NAMLEN ; [B]=0, [C]=Max Name Len -CHN03: - LDAX D - CPI ' '+1 - JC CHN04 ; Brif End-of-Name - MOV M,A - INX D - INX H - INR B ; Len+1 - DCR C ; Max-1 - JZ $IOERR ; **IO** Error if name too long.. - JMP CHN03 -CHN04: - MVI M,CR ; Store Terminator - MOV A,B - INR A ; Include CR in Len Cnt - STA T.LEN ; Store Filename Len in SRB - MVI A,18H ; Load Overlay & Execute - STA SRB - MVI A,4 - STA T.CHAN ; Store Chan 4 (Doc is unclear) - LXI D,T.FNAM - LXI H,T.BPTR - MOV M,D - INX H ; Store Fname Pntr in SRB - MOV M,E - MVI A,0FFH - OUT 0F7H ; Load Overlay & Execute - JMP $IOERR ; Should never happen -ENDIF -; ================ - - PAGE - SUBTTL Scan for valid Filename - -.SNAM: -IF CPM - LHLD .NFWA ; FWA of Filename - XCHG ; [DE] = name FWA - LXI H,TFCB+1 ; [HL] = FILE CTRL BLOCK - MVI B,NAMLEN -.COMMENT & **3.36 -.SNAM1: - LDAX D ; GET NAME CHAR - INX D - STA .NFWA ; Set '.' if user supplied Ext. - CPI '.' - JZ .SNAM3 ; Brif saw Ext - CPI ' '+1 - JC .SNAM3 ; Brif End-of-Name - MOV M,A ; PUT IN FCB - INX H - DCR B ; UNTIL STRING EXHAUSTED - JNZ .SNAM1 -.SNAM2: - LDAX D - INX D - STA .NFWA - CPI '.' ; Looking for Ext.. - JZ .SNAM4 - CPI ' '+1 ; or end of name - JNC .SNAM2 - JMP .SNAM4 ; Go copy user or default ext -.SNAM3: - MVI M,' ' - INX H - DCR B - JNZ .SNAM3 -.SNAM4: - MVI B,3 ; Scan Extention - LDA .NFWA - CPI '.' - JZ .SNAM5 ; Brif user supplied ext - LXI D,DFTEXT ; ..Else use default -**3.36 & -.SNAM5: - LDAX D - INX D - MOV M,A - INX H - DCR B - JNZ .SNAM5 -; ---------------- - MOV M,B ; Clear File EX - MOV A,B - STA TFCB+32 ; NR = 0 - RET -ENDIF -; ================ -IF MOD1 - MVI B,NAMLEN -.SNAM0: - LDAX D - CPI ' '+1 - JC .SNAM1 ;Brif EOS - MOV M,A - INX D - INX H - DCR B - JNZ .SNAM0 - JMP $IOERR ;**IO** Error if name too long -.SNAM1: - MVI M,CR ;Terminate with CR - RET -ENDIF - - PAGE - SUBTTL Relocated loader for CP/M & MOD1 - -IF CPM -LOCTAB: - DB (X0+2) AND 0FFH - DB (X1+1) AND 0FFH - DB (X2+2) AND 0FFH - DB (X3+2) AND 0FFH - DB 0 - -; ================ -LOADER: - .PHASE 0 -IPL: LXI D,TPA ;Program start address - PUSH D ;Save as return address -IPL1: XCHG ;[DE] = Next load address - PUSH D ;Save load address - MVI C,C.BUFF ;Set DMA address - CALL CPMENT - LXI D,TFCB ;Read record - MVI C,C.READ - CALL CPMENT - POP D ;Restore base address of record - ORA A -X0: JNZ IPLDON ;EOF - LXI H,128 ;[HL] = Record size - DAD D ;[HL] = Start of next record -X1: MVI A,IPL/256 ;Get hi byte of IPL address - CMP H ;Are we there? -X2: JNZ IPL1 ;No - continue loading program -X3: LXI D,OVFMSG ;Print '* OUT OF MEMORY*' - MVI C,C.EMSG - CALL CPMENT - JMP CPMWRM ;Reset and die -IPLDON: - XRA A - STA TBUFF ; 0 = No cmnd line passed - MVI A,' ' - STA TFCB+1 ; Clear TFCB for Utilities - LXI B,CPMWRM ; Push Warm Boot addr for - PUSH B ; Utilities that just return... - JMP TPA ;CLOSE FILE AND START PROG -OVFMSG: - DB CR,LF,'* Out of Memory *',CR,LF,'$' -ENDIPL: - .DEPHASE -ENDIF -; ================ -IF MOD1 -LOADER: -IPL: CALL M.GET ;Read character - JNZ M.ABRT ;In case of error - CPI 2 ;Is it EOF ? - .Z80 - JR Z,(IPL1) ;Get start address - .8080 - CPI 1 ;Is it data ? - JNZ M.ABRT ;Not data then error - CALL M.GET ;Length + 2 - DCR A - DCR A - MOV B,A ;Length - CALL M.GET ;Load address - JNZ M.ABRT ;In case of error - MOV L,A - CALL M.GET - JNZ M.ABRT ;In case of error - MOV H,A - -IPL0: CALL M.GET ;Get data - MOV M,A ;Put data in load address - INX H ;Increment load address - DCR B ;# of bytes left to load - .Z80 - JR NZ,(IPL0) - JR Z,(IPL) - .8080 - -IPL1: CALL M.GET ;Get second 2 (EOF) - CPI 2 - JNZ M.ABRT ;In case of error - CALL M.GET ;Get start address - JNZ M.ABRT ;In case of error - MOV L,A - CALL M.GET - JNZ M.ABRT ;In case of error - MOV H,A - PCHL ;Run program -ENDIPL: - -ENDIF -; ================ -IF CPM OR ISIS OR MOD1 -$$MOV: - LDAX D - MOV M,A - INX D - INX H - DCR B - JNZ $$MOV - RET -ENDIF - - DSEG - -.NFWA: DS 2 ; Temp for FWA of Filename - -IF ISIS -I.FCB: DW I.FNAM ;Pntr to Filename - DW 0 ;Bias field - DW 1 ;RETSW, Xfer control to new pgm - DW I.NTRY ;Pntr to Entry addr store - DW I.STAT ;Status -; -- -I.FNAM: DS 15 ;Filename -I.NTRY: DS 2 ;Entry Point Address -I.STAT: DS 2 ;Ret Status - ENDIF - - END - \ No newline at end of file diff --git a/software/CPM/CPM03_FORTRAN80/forlib.rel b/software/CPM/CPM03_FORTRAN80/forlib.rel deleted file mode 100644 index 1c21374..0000000 Binary files a/software/CPM/CPM03_FORTRAN80/forlib.rel and /dev/null differ diff --git a/software/CPM/CPM03_FORTRAN80/init.mac b/software/CPM/CPM03_FORTRAN80/init.mac deleted file mode 100644 index 603e9a6..0000000 --- a/software/CPM/CPM03_FORTRAN80/init.mac +++ /dev/null @@ -1,51 +0,0 @@ - TITLE INIT - FORTRAN-80 RUNTIME INITIALIZATION - - .8080 - - ENTRY $INIT,$EC,$IOFLG,$CPMVN,$CPMWF,$CPMRF - EXTRN $CLSFL - -GTVRSF EQU 12 ;GET CP/M VERSION FUNCTION -.READS EQU 20 ;READ SEQUENTIAL FUNCTION (1.X) -.WRITS EQU 21 ;WRITE SEQUENTIAL FUNCTION (1.X) -.READR EQU 33 ;READ RANDOM FUNCTION (2.X) -.WRITR EQU 34 ;WRITE RANDOM FUNCTION (2.X) - - DSEG - -$CPMVN: DS 1 ;0FFH if CP/M 1.X, 00 if 2.X -$CPMRF: DS 1 ;CP/M Read function held here -$CPMWF: DS 1 ;CP/M WRITE FUNCTION HELD HERE -$EC: DS 1 ;ERROR COUNT - MAX 20 NON-FATAL ERRS -$IOFLG: DS 1 ;FLAG WHETHER I/O INIT HAS BEEN DONE - - CSEG - -CPMENT SET 5 - -$INIT: XRA A - STA $EC ;INITIALIZE ERROR COUNT TO 0 - STA $IOFLG ;INITIALIZE I/O FLAG - LXI H,RETINS ;INITIALIZE $CLSFL TO POINT TO "RET" - SHLD $CLSFL - - LHLD CPMENT+1 ;INITIALIZE STACK TO TOP OF MEMORY-1 - DCX H - SPHL - - PUSH B ;PUT RETURN ADDRESS ON STACK - MVI C,GTVRSF - CALL CPMENT ;GET CP/M VERSION NUMBER - SUI 20H-1 ;SET $CPMVN SUCH THAT - SBB A ;2.X = 00 AND - STA $CPMVN ;1.X = 0FFH.. - - LXI H,(.WRITS SHL 8)+.READS - JNZ SETVF ;1.X USES SEQUENTIAL I/O CALLS - LXI H,(.WRITR SHL 8)+.READR -SETVF: SHLD $CPMRF ;2.X USES RANDOM I/O CALLS - -RETINS: RET - - END - \ No newline at end of file diff --git a/software/CPM/CPM03_FORTRAN80/ioinit.mac b/software/CPM/CPM03_FORTRAN80/ioinit.mac deleted file mode 100644 index 1be96ff..0000000 --- a/software/CPM/CPM03_FORTRAN80/ioinit.mac +++ /dev/null @@ -1,41 +0,0 @@ - TITLE IOINIT - FORTRAN-80 I/O FLAG & VARIABLE INIT - - .8080 - - ENTRY $IOINI - EXT $IOFLG,$LNPTR,$CPMBF,$LUNTB - EXT $FLFLG,$DSKER,$OPNFL - -$IOINI: LDA $IOFLG ;SEE IF WE'VE ALREADY BEEN CALLED - ORA A - RNZ - INR A ;SET NON-ZERO - STA $IOFLG - - LXI H,$CPMBF - MVI M,132+1 ;MAX CHRS TO READ FOR BDOS CALL - INX H - MVI M,0 ;ZERO NO. OF CHARS READ - INX H - SHLD $LNPTR ;PTR TO BEGINNING OF LINE - - MVI M,10 ;STORE LINE FEED AT BEG. OF LINE - - LDA $LUNTB ;GET NO. OF LUN'S - DCR A - MOV B,A ;SAVE LOOP COUNT - LXI H,$FLFLG ;INITIALIZE FLAGS FOR DSKDRV - XRA A - -FLGLOP: MOV M,A ;ZERO $FLFLG BYTE - INX H ;INCREMENT PTR - DCR B ;DECREMENT COUNT - JNZ FLGLOP ;NEXT - STA $DSKER - - XRA A - STA $OPNFL ;CLEAR $OPNFL FOR LPTDRV - RET - - END - \ No newline at end of file diff --git a/software/CPM/CPM03_FORTRAN80/l80.com b/software/CPM/CPM03_FORTRAN80/l80.com deleted file mode 100644 index 264e3b5..0000000 Binary files a/software/CPM/CPM03_FORTRAN80/l80.com and /dev/null differ diff --git a/software/CPM/CPM03_FORTRAN80/lib.com b/software/CPM/CPM03_FORTRAN80/lib.com deleted file mode 100644 index 81b1d22..0000000 Binary files a/software/CPM/CPM03_FORTRAN80/lib.com and /dev/null differ diff --git a/software/CPM/CPM03_FORTRAN80/lptdrv.mac b/software/CPM/CPM03_FORTRAN80/lptdrv.mac deleted file mode 100644 index fc91bba..0000000 --- a/software/CPM/CPM03_FORTRAN80/lptdrv.mac +++ /dev/null @@ -1,112 +0,0 @@ - TITLE LPTDRV - FORTRAN LINE PRINTER DRIVER - - .8080 - - ENTRY LPTDRV,$OPNFL - EXTRN $IOERR,$BF,$BL,$CLSFL - - DSEG - -$OPNFL: DB 0 -CLSADR: DS 2 - - CSEG - -LPTDRV: DW $IOERR - DW LPTFWR - DW $IOERR - DW LPTBWR - DW $IOERR - DW $IOERR - DW LPTCLS - -LPTCLS: LDA $OPNFL ;MAKE SURE ALREADY 'OPEN' - ORA A - JZ $IOERR - XRA A ;'CLOSE' BY SENDING - STA $OPNFL ; FORM FEED -OUTFF: MVI A,12 - JMP LPTOUT - -CLSLPT: LDA $OPNFL - ORA A - LHLD CLSADR - PUSH H - RZ - CALL OUTCR ;CR -OUTLF: MVI A,10 ;LF - JMP LPTOUT - -MAKOPN: LXI H,$OPNFL - MOV A,M - ORA A - RZ - INR M -SETCLS: LHLD $CLSFL - LXI D,CLSLPT - MOV A,L - SUB E - MOV A,H - SBB D - RZ -STORAD: SHLD CLSADR - XCHG - SHLD $CLSFL - RET - -LPTFWR: CALL MAKOPN - LDA $BL - ORA A - RZ ;NUTHIN HERE - - LHLD $BF - DCR A - MOV E,A ;INTO [E] FOR LPTLOP - MOV A,M - CPI '*' ;DO NOTHING? - JZ LPTNLF - CALL OUTCR ;OUTPUT CR - MOV A,M - CPI "+" - JZ LPTNLF - CPI "1" - JNZ LPTLF - CALL OUTFF ;FORM FEED - JMP LPTNLF - -LPTLF: CALL OUTLF - MOV A,M - CPI "0" - CZ OUTLF - -LPTNLF: INX H - MVI D,0 - -LPTLOP: MOV A,E - ORA D - RZ - MOV A,M - CALL LPTOUT - INX H - DCX D - JMP LPTLOP - -LPTBWR: CALL MAKOPN - LHLD $BL - XCHG - LHLD $BF - JMP LPTLOP - -OUTCR: MVI A,13 - -LPTOUT: PUSH H - PUSH D - MVI C,5 ;CP/M LPT OUT FUNCTION - MOV E,A - CALL 0005 - POP D - POP H - RET - - END - \ No newline at end of file diff --git a/software/CPM/CPM03_FORTRAN80/luntb.mac b/software/CPM/CPM03_FORTRAN80/luntb.mac deleted file mode 100644 index d093e21..0000000 --- a/software/CPM/CPM03_FORTRAN80/luntb.mac +++ /dev/null @@ -1,23 +0,0 @@ - TITLE LUNTB - APPLE CPM LUN TABLE - -; TTY I/O DRIVER - .8080 - - EXTRN TTYDRV,PUNRDR,LPTDRV,DSKDRV - - ENTRY $LUNTB - -$LUNTB: DB 11 ;TEN LUN'S - - DW TTYDRV ;1= TTY - DW LPTDRV ;2= PRINTER - DW TTYDRV ;3= TTY - DW PUNRDR ;4= PUNCH,READER - DW TTYDRV ;5= TTY - DW DSKDRV ;6= FORT06.DAT - DW DSKDRV ;7= FORT07.DAT - DW DSKDRV ;AND SO ON. - DW DSKDRV - DW DSKDRV - END - \ No newline at end of file diff --git a/software/CPM/CPM03_FORTRAN80/m80.com b/software/CPM/CPM03_FORTRAN80/m80.com deleted file mode 100644 index d546065..0000000 Binary files a/software/CPM/CPM03_FORTRAN80/m80.com and /dev/null differ diff --git a/software/CPM/CPM03_FORTRAN80/readme.txt b/software/CPM/CPM03_FORTRAN80/readme.txt deleted file mode 100644 index 0ffc5a1..0000000 --- a/software/CPM/CPM03_FORTRAN80/readme.txt +++ /dev/null @@ -1 +0,0 @@ -Microsoft Fortran-80 Compiler v.3.44 \ No newline at end of file diff --git a/software/CPM/CPM03_FORTRAN80/ttydrv.mac b/software/CPM/CPM03_FORTRAN80/ttydrv.mac deleted file mode 100644 index ee51211..0000000 --- a/software/CPM/CPM03_FORTRAN80/ttydrv.mac +++ /dev/null @@ -1,235 +0,0 @@ - TITLE TTYDRV - FORTRAN-80 TTY I/O DRIVER - - .8080 - - EXTRN $IOERR,$BL,$BF,$ERR,$TTYIN,$TTYOT - -; TTY: & PUN:/RDR: DRIVER ENTRIES: - - ENTRY TTYDRV,PUNRDR - -; FORTRAN-80 UTILITY SUBROUTINES: - - ENTRY PUNCH,READER,GOTOXY,SCREEN - ENTRY HOME,INKEY,CONOUT - - DSEG - -DEVFLG: DB 0 - - CSEG - -PUNRDR: DW PUNFR ;FORMATTED READ - DW PUNFW ;FORMATTED WRITE - DW $IOERR ;UNFORMATTED READ - DW PUNUWR ;UNFORMATTED WRITE - DW NULL ;REWIND - DW NULL ;BACKSPACE - DW NULL ;ENDFILE - -TTYDRV: DW TTYFR ;SAME AS ABOVE - DW TTYFW - DW $IOERR - DW TTYUWR - DW NULL - DW NULL - DW NULL - -TTYFR: XRA A ;TTY = 0 - DB 1 ;SKIP 2 BYTES WITH 'LXI B,' - -PUNFR: MVI A,1 ;READER = 1 - STA DEVFLG ;DEVICE FLAG - - XRA A - MOV E,A ;ZERO LO BYTE OF $BL - STA $BL+1 ;ZERO HI BYTE - - LHLD $BF ;GET BUFFER ADDR - -DRV31: CALL INCHR ;GET A CHARACTER -DRV39: CPI 10 ;INGNORE LINE FEEDS - JZ DRV31 - - MOV M,A - - INX H - INR E - - CPI 13 ;TEST FOR END OF LINE - MOV A,E - STA $BL - RZ - - CPI 132 ;MAX 132 CHARS - JC DRV31 - - CALL $ERR ;GIVE 'INPUT RECORD TOO LONG' WARNING - DB 18 - -NULL: XRA A ;CLEAR CARRY AND ZERO FLAGS - RET - -TTYFW: XRA A ;TTY = 0 - DB 1 ;SKIP 2 WITH 'LXI B,' - -PUNFW: MVI A,1 ;PUNCH = 1 - STA DEVFLG - - LDA $BL ;GET BUFFER LENGTH - ORA A - RZ ;EMPTY BUFFER - JUST RETURN - - LHLD $BF ;BUFFER ADDRESS - DCR A - MOV E,A ;SAVE LENGTH IN [E] - - MOV A,M ;GET CARRIAGE CONTROL CHAR - CPI '*' ;DO NOTHING? - JZ TTYNOT - - CALL OUTCR ;PRINT A CARRIAGE RETURN - MOV A,M ;REGET FIRST CHAR - CPI '+' ;A '+' MEANS CR BUT NO LF - JZ TTYNOT - - CPI '1' ;A '1' MEANS CLEAR SCREEN/FORM FEED - JNZ TTYLFO - CALL HOM1 ;GO CLEAR SCREEN OR SEND FF CHAR - JMP TTYNOT - -TTYLFO: CALL OUTLF ;PRINT A LINE FEED Š MOV A,M ;GET CARR CONTROL CHAR BACK - CPI '0' ;'0' MEANS DOUBLE SPACING - CZ OUTLF ;ANYTHING ELSE IS JUST SINGLE SPACING - -TTYNOT: INX H ;INCREMENT BUFFER POINTER - MVI D,0 ;HI BYTE OF COUNT = 0 - -TTYLOP: MOV A,E ;DONE SENDING CHARACTERS? - ORA D - RZ ;YES, RETURN - MOV C,M ;GET CHARACTER INTO [C] - CALL OUTCH ;SEND THE CHAR - INX H ;INC BUFFER PTR - DCX D ;DEC CHARACTER COUNT - JMP TTYLOP - -TTYUWR: XRA A - - DB 1 ;SKIP 2 WITH 'LXI B,' - -PUNUWR: MVI A,1 - STA DEVFLG - LHLD $BL ;GET NO. OF CHARS TO SEND - XCHG ;INTO [DE] - LHLD $BF ;GET BUFFER POINTER INTO [HL] - JMP TTYLOP ;AND GO SEND THEM - -OUTLF: MVI C,10 ;OUTPUT A LINE FEED - JMP OUTCH - -OUTCR: MVI C,13 ;OUTPUT A CARRIAGE RETURN - -OUTCH: LDA DEVFLG ;PRINT CHARACTER TO EITHER - ORA A ;TTY: OR PUN: DEVICE - MOV A,C - JNZ $PUNOT - JMP $TTYOT - -PUNCH: MOV A,M ;FORTRAN PUNCH SUBROUTINE - -$PUNOT: PUSH B - PUSH D - MVI C,4 ;CP/M PUNCH DEVICE OUTPUT - MOV E,A -GOCPM: PUSH H - CALL 5 - POP H - POP D - POP B - RET - -CONOUT: MOV A,M ;FORTRAN CONOUT SUBROUTINE - JMP $TTYOT - -READER: ;FORTRAN READER FUNCTION - -$RDRIN: PUSH B - PUSH D - MVI C,3 - JMP GOCPM - -INCHR: LDA DEVFLG ;GET CHAR FROM EITHER - ORA A ;TTY OR READER DEVICE - JNZ $RDRIN - JMP $TTYIN - -HOM1: LDA DEVFLG ;CLEAR SCREEN IF TTY, - ORA A ;SEND FF CHAR IF PUNCH - JZ HOME - MVI A,12 ;FF CHAR - JMP $PUNOT - -HOME: MVI A,1 ;CLEAR CONSOLE SCREEN - JMP DOFUN - -SCREEN: MOV A,M ;GET FUNCTION # - -DOFUN: PUSH H - LXI H,0F397H ;SSFTAB - ADD L ;POINT TO DESIRED FUN CHAR - MOV L,A - MOV A,M ;GET IT INTO A - ORA A ;REQUIRE LEAD-IN? - JP NOLDIN - PUSH PSW - LDA 0F397H ;YES, SO SEND IT FIRST - CALL $TTYOT - POP PSW -NOLDIN: CALL $TTYOT - POP H - RET - -GOTOXY: MVI A,7 ;DO CURSOR POSITION FUNCTION - CALL DOFUN - - LDAX D ;GET COORDS - MOV H,M ;H=X, L=Y - MOV L,A - - DCR L ;MAP 1..24,1..80 TO 0..23,0..79 - DCR H - - LDA 0F396H ;XY COORD OFFSET - ORA A - JP NORVS - - MOV E,L ;SWAP - MOV L,H - MOV H,E - -NORVS: MOV E,A ;SAVE IN [E] - ADD H ;ADD OFFSET - PUSH PSW ;SAVE CHAR - MOV A,E - ADD L ;OUTPUT FIRST COORD - CALL $TTYOT - POP PSW - MOV E,A ;OUTPUT SECOND COORD - JMP $TTYOT - -INKEY: MOV A,M ;GET PARAMETER - ORA A ;SEE WHAT IT IS - JZ INK1 ;ZERO - JUST TEST STATUS - -INKLP: CALL INK1 ;READ CONSOLE STATUS - ORA A - JZ INKLP ;WAIT UNTIL KEYPRESS - RET - -INK1: MVI C,6 ;CONSOLE STATUS CALL - MVI E,255 - JMP 5 ;GO TO BDOS - - END - \ No newline at end of file diff --git a/software/CPM/CPM04_MBASIC/bascom.com b/software/CPM/CPM04_MBASIC/bascom.com deleted file mode 100644 index 1dda475..0000000 Binary files a/software/CPM/CPM04_MBASIC/bascom.com and /dev/null differ diff --git a/software/CPM/CPM04_MBASIC/bascom.hlp b/software/CPM/CPM04_MBASIC/bascom.hlp deleted file mode 100644 index 4b17455..0000000 --- a/software/CPM/CPM04_MBASIC/bascom.hlp +++ /dev/null @@ -1,379 +0,0 @@ -Introduction -Format notation -A sample session -Writing a Basic program to be compiled -Compiler-interpreter differences -New programming features -Second menu: Compiling, linking & loading, errors -:INTRODUCTION - -The Microsoft BASIC Compiler is a highly efficient programming tool that -converts BASIC programs from BASIC source code into machine code. This -provides much faster BASIC program execution than has previously been -possible. It can make programs run an average of 3 to 10 times faster than -programs run under BASIC-80. Compiled programs can be up to 30 times -faster than interpreted programs if maximum use of integer variables is -made. -:FORMAT NOTATION - -Wherever the format for a statement or command is given throughout this -HELP file, the following rules apply: - - 1. Items in capital letters must be input as shown. - - 2. Items in lower case letters enclosed in angle brackets ( < > ) - are to be supplied by the user. - - 3. Items in sqare brackets ( [ ] ) are optional. - - 4. All punctuation except angle brackets and square brackets - (i.e., commas, parentheses, semicolons, hyphens, and equal - signs) must be included where shown. - - 5. Items followed by an ellipsis ( ... ) may be repeated any - number of times (up to the length of the line). - - 6. Items separated by a vertical bar ( \ ) are mutually exclusive; - choose one. -:SAMPLE SESSION - -The following instructions will take you step by step through the compila- -tion process, from typing in the program to running the compiled version of -it. - -STEP 1: PRELIMINARIES - -Load BASIC-80 (NOT included in the BASCOM package) from disk. The program -will sign on and the letters - -ok - -will appear on the screen. Now enter: - - AUTO 100, 100 - -This command instructs BASIC-80 to automatically generate line numbers, -beginning with line 100 and incrementing by 100 each time you press ENTER. - -STEP 2: ENTER THE PROGRAM - -You are now ready to begin typing in your BASIC program. Anything that you -know runs in BASIC-80 will do. Alternatively, just read in a BASIC-80 -program you already use. - -STEP 3: SAVE THE PROGRAM - -In order for the compiler to process it, you must save your source program -in ASCII format. To do so, enter: - - SAVE "MYPROG",A - -There is now a BASIC program called MYPROG.BAS on your diskette that is -ready to be compiled. (A program that is not yet compiled is called the -source file.) - -Return to CP/M by typing SYSTEM. - -STEP 4: CHECK FOR ERRORS - -At this point, it is a good idea to check the program for syntax errors. -Removing syntax errors now will reduce the possibility of having to recom- -pile later. To do this, enter: - - BASCOM =MYPROG - -This command loads the BASIC Compiler and compiles the source file without -producing an object or listing file. If you have made any syntax errors, a -two-letter code will appear on the screen. If this happens, return to STEP -1, use the BASIC-80 interpreter again, and correct the errors. - -If no errors were encountered, you are ready to continue. - -STEP 5: COMPILE SOURCE FILE - -These commands instruct the BASIC Compiler to compile MYPROG.BAS, to put -the object in a file named MYPROG.REL, and to put the listing in a file -named MYPROG.LST. (.REL and .LST are default extensions supplied by the -BASIC Compiler.) - -There are now a relocatable object file called MYPROG.REL and a listing -file called MYPROG.LST on the disk. The object file contains the machine- -readable code generated by the compiler. The listing file contains the -BASIC program statements along with the machine language generated by each -statement. - -STEP 6: LOAD AND EXECUTE THE PROGRAM - -The LINK-80 linking loader is used to produce an executable program. To use -it, enter: - - L80 MYPROG,MYPROG/N/E - -This command runs LINK-80, which in turn loads the object file MYPROG.REL -into the correct memory locations, then writes it to disk as a .COM file. -During this process (which can take some time), runtime routines are drawn -from the BASLIB.REL runtime library. - -The compiled program which you stored on your own diskette can be run at -any time, all by itself, without using any part of the BASIC Compiler. It -works just like a standard CP/M command file. To execute, just enter: - - MYPROG - -The program should then work just as it did in the interpreter .. only much -faster. -:WRITING A BASIC PROGRAM TO BE COMPILED - -BASIC programs which are to be compiled are, for most part, written in just -the same way you have always written them to run with the interpreter. -However, there are some differences between the statements and commands -implemented in BASIC-80 and those implemented in the BASIC Compiler that -must be taken into consideration. - -The Compiler interacts with the console only to read compiler commands. -These specify what files are to be compiled. There is no "direct mode", as -with the MBASIC interpreter. Commands that are usually issued in the direct -mode with MBASIC are not implemented on the compiler. The following state- -ments and commands are not implemented and will generate an error message. - - AUTO CLEAR* CLOAD CSAVE CONT - DELETE EDIT LIST LLIST RENUM - SAVE LOAD MERGE NEW COMMON* - SYSTEM -* -(Note: Newer releases of the compiler which include the BRUN runtime module -do support CHAINing with COMMON and CLEAR with certain restrictions.) - -:FEATURES USED DIFFERENTLY BY THE BASIC COMPILER - -DEFINT/SNG/DBL/STR -The compiler does not "execute" DEFxxx statements; it reacts to the static -occurrence of these statements, regardless of the order in which program -lines are executed. A DEFxxx statement takes effect as soon as its line is -encountered. Once the type has been defined for a given letter, it remains -in effect until the end of the program or until a different DEfxxx state -ment with that letter takes effect. - -USRn Functions -USRn functions are significantly different from the interpreter versions. -The argument to the USRn function is ignored and an integer result is -returned in the HL registers. It is recommended that USRn functions be -replaced by the CALL statement. (See New BASIC Programming Features for -definition of CALL.) - -DIM and ERASE -The DIM statement is similar to the DEFxxx statement in that it is scanned -rather than executed. That is, DIM takes effect when its line is encoun- -tered. If the default dimension (10) has already been established for an -array variable and that variable is later encountered in a DIM statement, a -DD (redimensioned array) error results. There is no ERASE statement in the -compiler, so arrays cannot be erased and redimensioned. An ERASE statement -will produce a fatal error. - -Also note that the values of the subscripts in a DIM statement must be -integer constants; they may not be variables, arithmetic expressions, of -floating point values. For example, - - DIM A1(I) - DIM A1(3+4) - -are both illegal statements. - -END -During execution of a compiled program, an END statement closes files and -returns control to the operating system. The compiler assumes an END at the -end of the program, so it is not necessary to insert an END statement in -order to get proper program termination. - -FOR/NEXT -All FOR/NEXT loops must be statically nested with only 1 NEXT statement for -each FOR statement. - -ON ERROR GOTO/RESUME -If a program contains ON ERROR GOTO and RESUME statements, -the /E compilation switch must be used. If the RESUME NEXT, RESUME, or -RESUME 0 form is used, the /X switch must also be included. - -REM -REM statements or remarks starting with a single quotation mark do not make -up time or space during execution, and so may be used as freely as desired. - -STOP -The STOP statement is identical to the END statement. Open files are closed -and control returns to the operating system. - -TRON/TROFF -In order to use TRON/TROFF, the /D compilation switch must be used. Other- -wise, TRON and TROFF are ignored and a warning message is generated. -:NEW BASIC PROGRAMMING FEATURES - -The BASIC Compiler also adds new features that will add power and -efficiency to your programming. Keep in mind when utilizing these new -features that while they will compile with no problems, you cannot run a -program using these features with your interpreter, since BASIC-80 -doesn't recognize them. - -CALL Statement -The CALL Statement allows you to call and transfer flow to an assembly -language or FORTRAN subroutine. - -The format of the CALL Statement is: - - CALL [()] - -where and are supplied by you. - - is the name of the subroutine you wish to call. This name -must be 1 to 6 characters long and must be recognized by LINK-80 as a -global symbol. ( must be the name of the subroutine in a -FORTRAN SUBROUTINE statement or a PUBLIC symbol in an assembly language -routine.) - - is optional and contains the arguments that are passed to -the assembly language or FORTRAN subroutine. - -Example: 120 CALL MYROUT (I,J,K) - -CHAIN (or RUN) -The CHAIN and RUN statements both perform the same function: they allow you -to load a file from diskette into memory and run it. CHAIN (or RUN) closes -all open files and deletes the current contents of memory before loading -the designated program. The format of the CHAIN (or RUN) statement is as -follows: - - CHAIN - OR - RUN - -where is the name used when the file was saved. (With CP/M the -default extension .BAS is supplied.) - -WHILE...WEND -The WHILE...WEND statement is a conditional statement that executes a -series of statements in a loop as long as a given condition is true. - -The format of WHILE...WEND is: - - WHILE - - - - - - - - - - WEND - -where and are supplied by you. - -As long as is true (i.e., not zero), loop statements are -executed until the WEND statement is encountered. BASIC then returns to the -WHILE statement and checks "expression". If it is still true, the process -is repeated. If it is not true, execution resumes with the statement -following the WEND statement. - -WHILE/WEND loops may be nested to any level, as long as they are statically -nested. Each WEND will match the most recent WHILE. An unmatched WHILE -statement causes a "WHILE without WEND" error, and an unmatched WEND state- -ment causes a "WEND without WHILE" error. - -Example: - 090 'BUBBLE SORT ARRAY A$ - 100 FLIPS=1 'FORCE ONE PASS THRU LOOP - 110 WHILE FLIPS - 115 FLIPS=0 - 120 FOR I=1 TO J=1 - 130 IF A$(I)>A$(I+1) THEN - SWAP A$(I),A$(I+1):FLIPS=1 - 140 NEXT I - 150 WEND - -Double Precision Transendental Functions -SIN, COS, TAN, SQR, LOG, and EXP now return double precision results if -given double precision arguments. Exponentiation with double precision -operands will return double precision results. - -Long Variable Names -Variable names may be up to 40 characters long with all 40 characters -significant. Letters, numbers, and the decimal characters are allowed in -variable names, but the name must begin with a letter. Variable names may -also include all BASIC-80 commands, statements, function names, and -operator names. - -Expression Evaluation in the BASIC Compiler -During program compilation, when the BASIC Compiler evaluates expressions, -the operands of each operator are converted to the same type, that of the -most precise operand. For example, - - QR=J%+A!+Q - -causes J% to be converted to single precision and added to A!. This result -is coverted to single precision and added to Q. - -The Compiler is more limited than the interpreter in handling numeric -overflow. For example, when run on the interpreter the following program - - I%=20000 - J%=20000 - K%=-30000 - M%=I%+J%-K% - -yields 10000 for M%. That is, it adds I% to J% and, because the number is -too large, it converts the result into a floating point number. K% is then -converted to floating point nd subtracted. The result of 10000 is found, -and is converted back to integer and saved as M%. - -The Compiler, however, must make type conversion decisions during compila- -tion. It cannot defer until the actual values are known. Thus, the compiler -would generate code to perform the entire operation in integer mode. If the -/D switch were set, the error would be detected. otherwise, an incorrect -answer would be produced. - -In order to produce optimum efficiency in the compiled program, the -compiler may perform any number of valid algebraic transformations before -generating the code. For axample, the program - - I%=20000 - J%=-18000 - K%=20000 - M%=I%+J%+K% - -could produce an incorrect result when run. If the compiler actually per- -forms the arithmetic in the order shown, no overflow occurs. However, if -the compiler performs I%+K% first and then adds J%, an overflow will occur. - -The Compiler follows the rules of operator precedence and parenthetic -modification of such precedence, but no other guarantee of evaluation order -can be made. - -Using Integer Variables To Optimize Speed -In order to produce the fastest and most compact object code possible, make -use of integer variables. For example, this program - - FOR I=1 TO 10 - A(I)=0 - NEXT I - -can execute approximately 30 times faster by simply substituting "I%" for -"I". It is especially advantageous to use integer variables to compute -array subscripts. The generated code is significantly faster and more -compact. - -Maximum Line Length -The Compiler cannot accept a physical line that is more than 253 characters -in length. A logical statement, however, may contain as many physical lines -as desired. Use line feed to start a new physical line within a logical -statement. -::BASCOM2.HQP - - - - - - - - - - - - a random file. -51 Internal error - An internal malfunc \ No newline at end of file diff --git a/software/CPM/CPM04_MBASIC/bascom2.hlp b/software/CPM/CPM04_MBASIC/bascom2.hlp deleted file mode 100644 index eeeceb3..0000000 --- a/software/CPM/CPM04_MBASIC/bascom2.hlp +++ /dev/null @@ -1,691 +0,0 @@ -Compiling a program -Compilation switches -Compile-time error messages -The LINK-80 linking loader -LINK-80 error messages -Storing your program on disk -Running your compiled program -Runtime error messages -Using M80 -:COMPILING A PROGRAM - -Is your BASIC program now saved in ASCII format on your diskette? (To save -your program in ASCII format when using the interpreter, add an "A" switch -to the "SAVE" command, as shown in SAMPLE SESSION, Step 3: - - SAVE "[.]",A - -Return to CP/M command level and enter: - - BASCOM - -BASIC will return the prompt: "*", informing you that the BASIC -Compiler is loaded and ready to accept a command. - -Now enter the command of the form: - - objfile,lstfile=source file - -where objfile is the relocatable object file, lstfile is the listing file, -and source file is the BASIC source program file. - -A command to BASIC conveys the name of the source file to be compiled, and -the names of the file(s) to be created. With CP/M filenames are up to eight -characters long with a three-character extension. The default filename -extensions supplied to CP/M are: - - REL Relocatable object file - LST Listing file - BAS BASIC source file - MAC MACRO-80 source file - FOR FORTRAN-80 source file - COB COBOL-80 source file - COM Executable command file - -If you have a multi-drive system, you can tell the compiler where to obtain -or put the files you are working with by adding a drive number to each -filename. For example: - - A:MYPROG.REL=B:TEST - -finds the program TEST.BAS on the diskette that is in drive B, compiles it, -and puts the object in MYPROG.REL (on the diskette that is in drive A). - -If a drive is NOT specified, the object and listing files are placed on the -diskette that is in the default drive. - -Either the object file or the listing file or both may be omitted. An -object file is created only if the lstfile field is filled. Therefore, if -you wish to omit either, simply leave its filename out of the command. - -Examples: - -TESTOBJ=TEST.BAS Compile the program TEST.BAS - and put object in TESTOBJ.REL - without producing listing file. -TEST,TEST=TEST Compile TEST.BAS, put object in - TEST.REL and listing in - TEST.LST. -,=TEST.BAS Compile TEST.BAS but produce no - object or listing file. Useful - for checking for errors. -RABBIT=TEST Compile the program TEST.BAS - and put object in RABBIT.REL - without producing listing file. -:BASIC COMPILATION SWITCHES - -You can specify special parameters to be used during compilation by adding -a switch to the end of the command string. Switches are always preceded by -a slash, and more than one switch may be used in the same command. An -example of the format would be: - - TEST,TEST=TEST/D/X - -The default switch settings used if you don't specify any switches are: - - /Z/4/T - -The available switches and their actions are as follows: - -SWITCH ACTION - -/E The /E switch tells the compiler that the program contains the ON - ERROR GOTO statement. If a RESUME statement other than RESUME - is used with the ON ERROR GOTO statement, use /X - instead (see below). To handle ON ERROR GOTO properly, in a - compiled environment, BASIC must generate some extra code for the - GOSUB and RETURN statements. Therefore, do not use this switch - unless your program contains the ON ERROR GOTO statement. The /E - switch also causes line numbers to be included in the binary - file, so runtime error messages will include the number of the - line in error. - -SWITCH ACTION -/X The /X switch tells the BASIC Compiler that the program contains - one or more RESUME, RESUME NEXT, or RESUME 0 statements. The /E - switch is assumed when the /X switch is specified. To handle - RESUME statements properly in a compiled environment, the - compiler must relinquish certain optimizations. Therefore, do not - use this switch unless your program contains RESUME statements - other than RESUME . The /X switch also causes line - numbers to be included in the binary file, so runtime error - messages will include the number of the line in error. - -/N The /N switch prevents listing of the generated code in symbolic - notation. If this switch is not set, the source listing produced - by the compiler will contain the object code generated by each - statement. - -SWITCH ACTION - -/D The /D switch causes debug/checking code to be generated at - runtime. This switch must be set if you want to use TRON/TROFF. - The BASIC Compiler generates somewhat larger and slower code in - order to perform the following checks: - 1. Arithmetic overflow. All arithmetic operations, integer and - floating point, are checked for overflow and underflow. - 2. Array bounds. All array references are checked to see if the - subscripts are within the bounds specified in the DIM state- - ment. - 3. Line numbers are included in the generated binary so that - runtime errors can indicate the statement which contains the - error. - 4. RETURN is checked for a prior GOSUB. - -/Z The /Z switch tells the compiler to use Z80 opcodes. - -SWITCH ACTION - -/S The /S switch forces the compiler to write long quoted strings - (i.e. more than 4 characters) to the binary file as they are - encountered. This allows large programs with many quoted strings - to compile in less memory. However, there are two disadvantages: - 1. Memory space is wasted if identical, long quoted strings - appear in the program. - 2. Code generated while the -S switch is set cannot be placed - in ROM. - -SWITCH ACTION - -/4 The /4 switch allows the compiler to use the lexical conventions - of Microsoft 4.51 Disk BASIC interpreter. That is, spaces are - insignificant, variables with imbedded reserved words are - illegal, variable names are restricted to two significant - characters, etc. this feature is useful if you wish to compile a - source program that was coded without spaces, and contains lines - such as - - FORI=ATOBSTEPC - - Without the /4 switch, the compiler would assign the variable - "ATOBSTEPC" to the variable FORI. With the /4 switch, it would - recognize it as a FOR statement. - -SWITCH ACTION -/C The /C switch tells the compiler to relax line numbering con- - straints. Whene /C is specified, line numbers may be in any - order, or they may be eliminated entirely. Lines are compiled - normally, but of course cannot be targets for GOTO's, GOSUB's, - etc. While /C is set, the underline character causes the - remainder of the physical line to be ignored, and the next - physical line is considered to be a continuation of the current - logical line. NOTE: /C and /4 may not be used together. - -/T Use 4.51 execution conventions - -/O (Newer versions only). Tells the compiler to construct a stand- - alone program instead of one requiring presence of the BRUN.COM - runtime module. This generates much bigger programs because all - of the runtime routines must be included. -:BASIC COMPILER ERROR MESSAGES - -The following errors may occur while a program is compiling. The BASIC -Compiler outputs the two-character code for the err, along with an arrow. -The arrow indicates where in the line the error occurred. In those cases -where the compiler has read ahead before it discovered an error, the arrow -points a few characters beyond the error, or at the end of the line. The -error codes are as follows: - -FATAL ERRORS - -CODE ERROR -SN Syntax Error. Caused by one of the following: - Illegal argument name - Illegal assignment target - Illegal constant format - Illegal debug request - Illegal DEFxxx character specification - Illegal expression syntax - Illegal function argument list - Illegal function name - -CODE ERROR -SN Syntax Error. Caused by one of the following: - Illegal function formal parameter - Illegal separator - Illegal format for statement number - Illegal subroutine syntax - Invalid character - Missing AS - Missing equal sign - Missing GOTO or GOSUB - Missing comma - Missing INPUT - Missing line number - Missing left parenthesis - Missing minus sign - Missing operand in expression - Missing right parenthesis - Missing semicolon - Name too long - Expected GOTO or GOSUB - -CODE ERROR -SN Syntax Error. Caused by one of the following: - String assignment required - String expression required - String variable required here - Illegal syntax - Variable required here - Wrong number of arguments - Formal parameters must be unique - Single variable only allowed - Missing TO - Illegal FOR loop index variable - Missin THEN - Missing BASE - Illegal subroutine name -OM Out of memory - Array too big - Data memory overflow - Too many statement numbers - Program memory overflow - -CODE ERROR -SQ Sequence Error - Duplicate statement number - Statement out of sequence -TM Type Mismatch - Data type conflict - Variables must be of same type -BS Bad Subscript - Illegal dimension value - Wrong number of subscripts -LL Line Too Long -UC Unrecognizable Command - Statement unrecognizable - Command not implemented -OV Math Overflow -/0 Division by Zero -DD Array Already Dimensioned -FN FOR/NEXT Error - FOR loop index variable already in use - FOR without NEXT - NEXT without FOR - -CODE ERROR -FD Function Already Defined -UF Function Not Defined -WE WHILE/WEND Error - WHILE without WEND - WEND without WHILE -/E Missing "/E" Switch -/X Missing "/X" Switch - -WARNING ERRORS -ND Array Not Dimensioned -SI Statement Ignored - Statement ignored - Unimplemented command - -If the BASIC Compiler informs you of any of these errors, return to the -source program for debugging and try again. - -If no errors were encountered during compilation, and if you so chose, you -now have an object file containing machine readable code on your diskette. -Also on your diskette is a listing file which contains the BASIC program -statements along with the machine language generated by each statement. - -The next step in the process is loading and executing the program with -LINK-80. - -:LINK-80 LINKING LOADER - -As demonstrated in SAMPLE SESSION, compiled BASIC object files are loaded -into memory and executed using the LINK-80 linking loader. The loader has -many uses. You may wish to simply load one compiled program and run it, or -you may load several programs, subprograms, or assembly language -subroutines at the same time. Programs may be loaded at user-specified -locations, and program areas and data areas may be separated in memory. A -memory image of the executable file produced by LINK-80 can be saved on -disk and run at a later time. - -RUNNING LINK-80 - -At CP/M command level, enter: - - L80 - -This loads LINK-80, which will respond with: * . The loader exits back -to CP/M if a CONTROL-C is typed after the asterisk. (The loader also exits -back to CP/M after an /E switch or /G switch is executed. More on these -switches later.) - -LINK-80 COMMAND FORMAT - -A command to LINK-80 is made up of the filename(s) of the file(s) to be -loaded. For example, to load the compiled program MYPROG.REL, enter: - - MYPROG - -(It is not necessary to type the default extension .REL.) This loads the -program but does not run it. Whenever LINK-80 loads a BASIC Compiler -program, it automatically searches the BASIC library for the necessary -routines and loads these as well. Therefore, BASLIB.REL must be on the -default drive during the loading process. - -To run MYPROG, enter: - - /G - -This is the "go" or execute switch. LINK-80 prints two numbers and a BEGIN -EXECUTION message. LINK-80 always returns to TRSDOS after a /G switch has -been executed. - -As you probably have guessed, it is not necessary to perform these -operations with separate commands. It is possible to type one command line -that runs LINK-80, loads MYPROG.REL and executes it. To do this, enter: - -L80 MYPROG/G - -MORE COMMANDS AND SWITCHES - -LINK-80 provides other capabilities besides loading and executing -programs, such as looking at output without saving the program or -resetting the loader so that you can correct a mistake. Switches are -used to inform LINK-80 that you wish to perform special tasks. - -Here is an example that loads and saves a program called TEST.REL. - - >L80 - *TEST,TEST/N/E - -The first part of the command (TEST) loads the program called TEST.REL. The -next part (TEST/N) saves a copy of the loaded program on disk in a file -called TEST.COM. The last part (/E) causes LINK-80 to exit back to CP/M. - -THE /N SWITCH - -Take note of the /N switch. This switch saves a memory image of the -executable file on disk. The default extension for the saved file is .COM, -and this file is called a "command file". Once saved on disk, you need only -type the filename at CP/M command level to run the program. The /N switch -must immediately follow the filename of each file you wish to save, and it -does not take effect until a /E or /G switch is done. - -The following example links several object files, saves the main program -image and executes the program TAXES.REL. - - >L80 - *SUB1,SUB2,TAXES/N,TAXES/G - -Two subroutines (SUB1) and (SUB2) and an object file (TAXES) are linked and -loaded. The program is executed and the command file TAXES.COM is saved on -disk. - -THE /R SWITCH - -Another handy switch is /R. It returns LINK-80 to it's initial state by -"unloading" whatever you've loaded. Use it to reset the loader if you've -made a typing mistake or loaded the wrong program. The /R switch takes -effect as soon as LINK-80 sees it, so if you enter it at any time while -LINK-80 is running, the loader will reset. For example: - - >L80 - *INVEN1 - */R (oops-- meant to load INVEN2) - *INVEN2 (now only INVEN2 is loaded) - -SPECIAL SWITCHES - -For typical BASIC Compiler operation, only the above switches will be -needed. Some users may find that their applications require more -specialized capabilities. For this reason, the following switches are also -provided with LINK-80. - -In these examples, all programs have been loaded at the default origins -of CP/M. In special cases, the user may wish to specify the origins of -the programs and data that are loaded. LINK-80 provides special switches to -do this. - -/E:Name This is an optional form of the /E switch. Name is a global - symbol previously defined in one of the modules. LINK-80 - uses Name for the start address of the program. - -/G:Name This is an optional form of the /G switch. Name is a global - symbol previously defined in one of the modules. LINK-80 - uses Name for the start address of the program. - -/P and /D /P and /D allow the origin(s) to be set for the next program - loaded. /P and /D take effect when seen (not deferred), and - they have no effect on programs already loaded. The form is - /P:
or /D:
, where
is the desired - origin in the current typeout radix. (Default radix is - hexadecimal. /O sets radix to octal; /H to hex.) LINK-80 - does a default /P: (i.e., 100h). - - If no /D is given, data areas are loaded before program - areas for each module. If a /D is given, All Data and Common - areas are loaded starting at the data origin and the program - area at the program origin. Example: - - */P:200,FOO - DATA 200 300 - */R - */P:200-D:400,FOO - DATA 400 480 - PROGRAM 200 280 - -/U List the origin and end of the program and data area and all - undefined globals as soon as the current command line has - been interpreted. The program information is only printed if - a /D has been done. Otherwise, the program is stored in the - data area. - -/M List the origin and end of the program and data area, all - undefined globals and their values, and all undefined - globals followed by an asterisk. The program information is - only printed if a /D has been done. Otherwise, the program - is stored in the data area. - -/X If a filename/N was specified, /X will cause the file to be - saved in INTEL ascii HEX format with an extension of .HEX. - -/Y If a filename/N was specified, /Y will create a filename.SYM - file when /E is entered. This file contains the names and - addresses of all Globals for use with Digital Research's SID - and ZSID debuggers. - -SYSTEM LIBRARY SEARCHES - -Whenever a BASIC Compiler program is loaded, LINK-80 automatically searches -the BASIC Compiler library for the routines it needs and loads them. If you -gat an "Undefined" error, it means the compiler couldn't find something it -needed to finish compiling the program. Usually this is the name of a -subroutine that you forgot to load. - -If you are using the BASIC Compiler in conjunction with Microsoft's -FORTRAN-80, you may also be referencing some of FORTRAN's library routines. -For this reason, the /S switch is included in LINK-80 to force a search of -particular library modules. For example: - - *FORLIB/S,TEST/G - -Unless you are using FORLIB (supplied with FORTRAN-80), you should not need -the /S switch. - - -:LINK-80 ERROR MESSAGES - -LINK-80 has the following error messages: - -?No Start Address A /G switch was issued, but no main - program had been loaded. - -?Loading Error The last file given for input was - not a properly formatted LINK-80 - object file. - -?Out of Memory Not enough memory to load program. - -?Command Error Unrecognizable LINK-80 command. - -? Not Found , as given in the command string, - did not exist. - -%2nd COMMON larger The first definition of COMMON - block /XXXXXX/ was not the largest - definition. Reorder module loading - sequence or change COMMON block - definitions. - -%Mult. Def. Global YYYYYY - More than one definition for the - global (internal) symbol YYYYYY was - encountered during the loading - process. - -%Overlaying Program Area ,Start = xxxx - Data ,Public = (xxxx) - ,External = (xxxx) - A /D or /P will cause already - loaded data to be destroyed. - -?Intersecting Program Area - Data The program and data area intersect - and an address or external chain - entry is in this intersection. The - final value cannot be converted to - a current value since it is in the - area intersection. -?Start Symbol - - Undefined - After a /E: or /G: is given, the - symbol specified was not defined. - -Origin Above (Below) Loader Memory, Move Anyway (Y or N)? - After a /E or /G was given, either - the data or program area has an - origin or top which lies outside - loader memory (i.e., loader origin - to top of memory). If a Y CR is - given, LINK-80 will move the area - and continue. If anything else is - given, LINK-80 will exit. In either - case, if a /N was given, the image - will already have been saved. - -?Can't save Object File A disk error occurred when the file was being -saved. -:STORING YOUR PROGRAM ON DISKETTE - -Once it has been loaded by LINK-80, the object file is in a form that can -be executed by any CP/M computer. You can save this compiled program on -your own diskette so that it can be executed at a later time without using -the BASIC Compiler at all. - -The /N switch (discussed in the LINK-80 section) is the switch that causes -your object file to be saved. The default extension for the saved file is -.COM and this file is called a "command file". - -:RUNNING YOUR COMPILED PROGRAM - -Your compiled program (previously saved on your own diskette) can now be -executed any time you wish. When you are at CP/M command level the diskette -on which you saved your program is inserted into a drive, simply enter: - - - -At this point, your program should execute and your output should appear on -the screen. However, you may get a runtime error message. If you do, look -it up in the following list, and debug your program as best you can before -trying to store it on diskette again. - - -:RUNTIME ERROR MESSAGES - -The following errors may occur while a compiled program is executing. The -error numbers match those issued by the BASIC-80 interpreter. The compiler -runtime system prints long error messages followed by an address, unless -/D, /E, or /X is specified. In those cases the error message is followed by -the number of the line in which the error occurred. - -NUMBER MESSAGE -2 Syntax error - A line is encountered that contains an incorrect - sequence of characters in a DATA statement. -3 RETURN without GOSUB - A RETURN statement is encountered for which there - is no previous, unmatched GOSUB ststement. -4 Out of Data - A READ statement is executed when there are no - DATA statements with unread data remaining in the - program. - -NUMBER MESSAGE - -5 Illegal function call - A parameter that is out of range is passed to a - math or string function. An FC error may also - occur as the result of: - - 1. a negative or unreasonably large subscript - 2. a negative or zero argument with LOG - 3. a negative argument to SQR - 4. a negative mantissa with a non-integer - exponent - 5. a call to a USR function for which the - starting address has not yet been given - 6. an improper argument to ASC, CHR$, MID$, - LEFT$, RIGHT$, INP, OUT, WAIT, PEEK, POKE, - TAB, SPC, STRING$, SPACE$, INSTR, or - ON...GOTO - 7. a string concatenation that is longer than - 255 characters - -NUMBER MESSAGE -6 Floating overflow or integer overflow - The result of a calculation is too large to be - represented in BASIC-80's number format. If - underflow occurs, the result is zero and execution - continues without an error. -9 Subscript out of range - An array element is referenced with a subscript - that is outside the dimensions of the array. -11 Division by zero - A division by zero is encountered in an - expression, or the operation of involution results - in zero being raised to a negative power. Machine - infinity with the sign of the numerator is - supplied as the result of the division, or - positive machine infinity is supplied as the - result of the involution, and execution continues. -14 Out of string space - String variables exceed the allocated amount of - string space. - -NUMBER MESSAGE -20 RESUME without error - A RESUME statement is encountered before an error - trapping routine is entered. -21 Unprintable error - An error message is not available for the error - condition which exists. This is usually caused by - an ERROR with an undefined error code. -50 Field overflow - A FIELD statement is attempting to allocate more - bytes than were specified for the record length of - a random file. -51 Internal error - An internal malfunction has occurred in Disk - BASIC-80. Report to Microsoft the conditions under - which the message appeared. -52 Bad file number - A statement or command references a file with a - file number that is not OPEN or is out of the - range of file numbers specified at initialization. - -NUMBER MESSAGE -53 File not found - A RUN, CHAIN, KILL, or OPEN statement references a - file that does not exist on the current disk. -54 Bad file mode - An attempt is made to use PUT, GET, or LOF with a - sequential or to execute an OPEN with a file mode - other than I, O, R, D. -55 File already open - A sequential output mode OPEN is issued for a file - that is already open; or a KILL is given for a - file that is open. -57 Disk I/O error - An I/O error occurred on a disk I/O operation. It - is a fatal error, i.e., theoperating system cannot - recover from the error. -58 File already exists - The filename specified is identical to a filename - already in use on the disk. -61 Disk Full - All disk storage space is in use. - -NUMBER MESSAGE -62 Input past end - An INPUT statement is executed after all the data - in the file has been INPUT, or for a null (empty) - file. To avoid this error, use the EOF function to - detect the end of file. -63 Bad record number - In a PUT or GET statement, the record number is - either greater than the maximum allowed (32767) or - equal to zero. -64 Bad file name - An illegal form is used for the filename with RUN, - CHAIN, KILL, or OPEN (e.g., a filename with too - many characters). -67 Too many files - An attempt is made to create a new file (using - OPEN) when the directory is full. -::M80.HQP - - - - - - - - - - - - - -d file is .COM, -and this file is called a "command file". Once saved \ No newline at end of file diff --git a/software/CPM/CPM04_MBASIC/baslib.rel b/software/CPM/CPM04_MBASIC/baslib.rel deleted file mode 100644 index 61c95ab..0000000 Binary files a/software/CPM/CPM04_MBASIC/baslib.rel and /dev/null differ diff --git a/software/CPM/CPM04_MBASIC/brun.com b/software/CPM/CPM04_MBASIC/brun.com deleted file mode 100644 index f9af0a0..0000000 Binary files a/software/CPM/CPM04_MBASIC/brun.com and /dev/null differ diff --git a/software/CPM/CPM04_MBASIC/cref.com b/software/CPM/CPM04_MBASIC/cref.com deleted file mode 100644 index e125339..0000000 Binary files a/software/CPM/CPM04_MBASIC/cref.com and /dev/null differ diff --git a/software/CPM/CPM04_MBASIC/cref80.com b/software/CPM/CPM04_MBASIC/cref80.com deleted file mode 100644 index e125339..0000000 Binary files a/software/CPM/CPM04_MBASIC/cref80.com and /dev/null differ diff --git a/software/CPM/CPM04_MBASIC/l80.com b/software/CPM/CPM04_MBASIC/l80.com deleted file mode 100644 index 264e3b5..0000000 Binary files a/software/CPM/CPM04_MBASIC/l80.com and /dev/null differ diff --git a/software/CPM/CPM04_MBASIC/lib80.com b/software/CPM/CPM04_MBASIC/lib80.com deleted file mode 100644 index 81b1d22..0000000 Binary files a/software/CPM/CPM04_MBASIC/lib80.com and /dev/null differ diff --git a/software/CPM/CPM04_MBASIC/m80.com b/software/CPM/CPM04_MBASIC/m80.com deleted file mode 100644 index 9df2cc1..0000000 Binary files a/software/CPM/CPM04_MBASIC/m80.com and /dev/null differ diff --git a/software/CPM/CPM04_MBASIC/mbasic.com b/software/CPM/CPM04_MBASIC/mbasic.com deleted file mode 100644 index c9ec3cd..0000000 Binary files a/software/CPM/CPM04_MBASIC/mbasic.com and /dev/null differ diff --git a/software/CPM/CPM04_MBASIC/obslib.rel b/software/CPM/CPM04_MBASIC/obslib.rel deleted file mode 100644 index fe7b8e2..0000000 Binary files a/software/CPM/CPM04_MBASIC/obslib.rel and /dev/null differ diff --git a/software/CPM/CPM04_MBASIC/rantest.asc b/software/CPM/CPM04_MBASIC/rantest.asc deleted file mode 100644 index 0dd4dbd..0000000 Binary files a/software/CPM/CPM04_MBASIC/rantest.asc and /dev/null differ diff --git a/software/CPM/CPM04_MBASIC/rantest.bas b/software/CPM/CPM04_MBASIC/rantest.bas deleted file mode 100644 index 0812b94..0000000 --- a/software/CPM/CPM04_MBASIC/rantest.bas +++ /dev/null @@ -1,17 +0,0 @@ -00100 defint i-n -00200 recsiz%=32 -00300 open "R",1,"B:RANTEST.ASC",recsiz% -00400 for i=1 to 20 -00500 print #1, using "$$#,###.## ";1000*i,102.34*i*i -00600 put 1,i -00700 next i -00800 for i=1 to 20 -00900 get 1,i -01000 line input #1, prices$ -01100 print i,prices$ -01200 next i -01300 close 1 -01400 end -r i=1 to 20 -00900 get 1,i -01000 line input #1, prices \ No newline at end of file diff --git a/software/CPM/CPM04_MBASIC/rantest.com b/software/CPM/CPM04_MBASIC/rantest.com deleted file mode 100644 index c1d807f..0000000 Binary files a/software/CPM/CPM04_MBASIC/rantest.com and /dev/null differ diff --git a/software/CPM/CPM04_MBASIC/rantest.rel b/software/CPM/CPM04_MBASIC/rantest.rel deleted file mode 100644 index b0541ca..0000000 Binary files a/software/CPM/CPM04_MBASIC/rantest.rel and /dev/null differ diff --git a/software/CPM/CPM04_MBASIC/readme.txt b/software/CPM/CPM04_MBASIC/readme.txt deleted file mode 100644 index d0f0a53..0000000 --- a/software/CPM/CPM04_MBASIC/readme.txt +++ /dev/null @@ -1,54 +0,0 @@ -Microsoft Basic-80 Compiler v.5.30a - ------------------------------------------------------------ -Example of a session: ------------------------------------------------------------ - ->MBASIC - -BASIC-80 Rev. 5.21 -[CP/M Version] -Copyright 1977-1981 (C) by Microsoft -Created: 28-Jul-81 -31800 Bytes free -Ok -10 PRINT "Hello World" -list -10 PRINT "Hello World" -Ok -RUN -Hello World -Ok -SAVE "HELLO",A -Ok -SYSTEM - -A>TYPE BAS.SUB - -BASCOM =$1 /E -L80 $1,$1/N/E - -A>SUPERSUB BAS HELLO - -SuperSUB V1.1 - -A>BASCOM =HELLO /E - -00000 Fatal Error(s) -24196 Bytes Free - -A>L80 HELLO,HELLO/N/E - -Link-80 3.44 09-Dec-81 Copyright (c) 1981 Microsoft - -Data 4000 4197 < 407> - -40207 Bytes Free -[4011 4197 65] - -A>hello - -Hello World - - -A> diff --git a/software/CPM/CPM04_MBASIC/sample.bas b/software/CPM/CPM04_MBASIC/sample.bas deleted file mode 100644 index df4b4d8..0000000 --- a/software/CPM/CPM04_MBASIC/sample.bas +++ /dev/null @@ -1,2 +0,0 @@ -00010 PRINT "This is an example of BASIC-80" - \ No newline at end of file diff --git a/software/CPM/CPM04_MBASIC/sample.com b/software/CPM/CPM04_MBASIC/sample.com deleted file mode 100644 index 1826e65..0000000 Binary files a/software/CPM/CPM04_MBASIC/sample.com and /dev/null differ diff --git a/software/CPM/CPM04_MBASIC/sample.rel b/software/CPM/CPM04_MBASIC/sample.rel deleted file mode 100644 index 1317e64..0000000 Binary files a/software/CPM/CPM04_MBASIC/sample.rel and /dev/null differ diff --git a/software/CPM/CPM05_COBOL80_v13/CB80.COM b/software/CPM/CPM05_COBOL80_v13/CB80.COM deleted file mode 100644 index 5692e87..0000000 Binary files a/software/CPM/CPM05_COBOL80_v13/CB80.COM and /dev/null differ diff --git a/software/CPM/CPM05_COBOL80_v13/CB80.IRL b/software/CPM/CPM05_COBOL80_v13/CB80.IRL deleted file mode 100644 index bbd71ce..0000000 Binary files a/software/CPM/CPM05_COBOL80_v13/CB80.IRL and /dev/null differ diff --git a/software/CPM/CPM05_COBOL80_v13/CB80.OV1 b/software/CPM/CPM05_COBOL80_v13/CB80.OV1 deleted file mode 100644 index 1426839..0000000 Binary files a/software/CPM/CPM05_COBOL80_v13/CB80.OV1 and /dev/null differ diff --git a/software/CPM/CPM05_COBOL80_v13/CB80.OV2 b/software/CPM/CPM05_COBOL80_v13/CB80.OV2 deleted file mode 100644 index d26fd79..0000000 Binary files a/software/CPM/CPM05_COBOL80_v13/CB80.OV2 and /dev/null differ diff --git a/software/CPM/CPM05_COBOL80_v13/CB80.OV3 b/software/CPM/CPM05_COBOL80_v13/CB80.OV3 deleted file mode 100644 index f27cf08..0000000 Binary files a/software/CPM/CPM05_COBOL80_v13/CB80.OV3 and /dev/null differ diff --git a/software/CPM/CPM05_COBOL80_v13/LK80.COM b/software/CPM/CPM05_COBOL80_v13/LK80.COM deleted file mode 100644 index 5f6b805..0000000 Binary files a/software/CPM/CPM05_COBOL80_v13/LK80.COM and /dev/null differ diff --git a/software/CPM/CPM06_COBOL80_v20/CB80.COM b/software/CPM/CPM06_COBOL80_v20/CB80.COM deleted file mode 100644 index d67c53f..0000000 Binary files a/software/CPM/CPM06_COBOL80_v20/CB80.COM and /dev/null differ diff --git a/software/CPM/CPM06_COBOL80_v20/CB80.IRL b/software/CPM/CPM06_COBOL80_v20/CB80.IRL deleted file mode 100644 index d09e15b..0000000 Binary files a/software/CPM/CPM06_COBOL80_v20/CB80.IRL and /dev/null differ diff --git a/software/CPM/CPM06_COBOL80_v20/CB80.OV1 b/software/CPM/CPM06_COBOL80_v20/CB80.OV1 deleted file mode 100644 index a3689a8..0000000 Binary files a/software/CPM/CPM06_COBOL80_v20/CB80.OV1 and /dev/null differ diff --git a/software/CPM/CPM06_COBOL80_v20/CB80.OV2 b/software/CPM/CPM06_COBOL80_v20/CB80.OV2 deleted file mode 100644 index 84aaf2f..0000000 Binary files a/software/CPM/CPM06_COBOL80_v20/CB80.OV2 and /dev/null differ diff --git a/software/CPM/CPM06_COBOL80_v20/CB80.OV3 b/software/CPM/CPM06_COBOL80_v20/CB80.OV3 deleted file mode 100644 index 35c6141..0000000 Binary files a/software/CPM/CPM06_COBOL80_v20/CB80.OV3 and /dev/null differ diff --git a/software/CPM/CPM06_COBOL80_v20/CBASE2.COM b/software/CPM/CPM06_COBOL80_v20/CBASE2.COM deleted file mode 100644 index 252825f..0000000 Binary files a/software/CPM/CPM06_COBOL80_v20/CBASE2.COM and /dev/null differ diff --git a/software/CPM/CPM06_COBOL80_v20/CIRCOM.BAS b/software/CPM/CPM06_COBOL80_v20/CIRCOM.BAS deleted file mode 100644 index 954d81a..0000000 Binary files a/software/CPM/CPM06_COBOL80_v20/CIRCOM.BAS and /dev/null differ diff --git a/software/CPM/CPM06_COBOL80_v20/CRUN2.COM b/software/CPM/CPM06_COBOL80_v20/CRUN2.COM deleted file mode 100644 index 1399e69..0000000 Binary files a/software/CPM/CPM06_COBOL80_v20/CRUN2.COM and /dev/null differ diff --git a/software/CPM/CPM06_COBOL80_v20/DEMOGRAF.BAS b/software/CPM/CPM06_COBOL80_v20/DEMOGRAF.BAS deleted file mode 100644 index ebfbba6..0000000 --- a/software/CPM/CPM06_COBOL80_v20/DEMOGRAF.BAS +++ /dev/null @@ -1,412 +0,0 @@ - REM THIS IS A DEMONSTRATION PROGRAM FOR - REM CBASIC GRAPHICS EXTENSIONS - REM - REM PROGRAM NAME: DEMOGRAF - REM - %INCLUDE GRAPHCOM.BAS - - DEF PAUSE - REM UTILITY TO SUSPEND PROGRAM EXECUTION UNTIL CHARACTER IS - REM ENTERED AT CONSOLE, STOPPING PROGRAM IF CTRL-C IS ENTERED, - REM OTHERWISE RETURNING INTEGER VALUE OF CHARACTER ENTERED. - REM CHARACTER IS NOT DISPLAYED. - - INTEGER PAUSE,CHOICE - - CHOICE = INKEY - IF CHOICE = 3 THEN STOP - PAUSE = CHOICE - FEND - - GRAPHIC OPEN 1 - CLEAR - - BEEM: GRAPHIC PRINT AT (0,.9): "BEAM STATEMENT" - SET BEAM "OFF" - PLOT (0,1),(1,1),(1,0),(0,0) - KEY% = PAUSE REM WAIT FOR CONSOLE INPUT - CLEAR - SET BEAM "ON" - PLOT (0,1),(1,1),(1,0),(0,0) - KEY% = PAUSE - - REM ILLUSTRATE TECHNIQUE OF SQUARING A DISPLAY - - BOWNDS: CLEAR - GRAPHIC PRINT AT (0,.9): "BOUNDS STATEMENT" - ASK DEVICE X.AXIS,Y.AXIS - PRINT "THE ASPECT RATIO IS = ";Y.AXIS;"/";X.AXIS - KEY% = PAUSE - PLOT (0,0),(0,1),(1,1),(1,0),(0,0) - KEY% = PAUSE - CLEAR - SET BOUNDS Y.AXIS,X.AXIS - PLOT (0,0),(0,1),(1,1),(1,0),(0,0) - SET BOUNDS 1,1 - KEY% = PAUSE - - REM DEMONSTRATE CONTROL OF GRAPHIC CHARACTER HEIGHT - REM AND MINIMUM HEIGHT FOR GRAPHIC CHARACTERS - - HIGH: CLEAR - SET CHARACTER HEIGHT 0 - GRAPHIC PRINT AT (0,.9): "CHARACTER HEIGHT STATEMENT" - SET CHARACTER HEIGHT .1 - GRAPHIC PRINT AT (0,.7): "10 PERCENT" - KEY% = PAUSE - SET WINDOW 0,100,0,100 - SET CHARACTER HEIGHT 15 - GRAPHIC PRINT AT (0,40): "15 PERCENT" - KEY% = PAUSE - SET CHARACTER HEIGHT 0 - ASK CHARACTER HEIGHT CH - PRINT "MINIMUM CHARACTER HEIGHT IS = "; CH - GRAPHIC PRINT AT (0,20): "MINIMUM HEIGHT" - - REM DISPLAY SEVERAL RANDOM LINES ON SCREEN, THEN MAKE - REM THEM DISAPPEAR VIA "CLEAR" STATEMENT - - INPUT ""; LINE SEED$ - RANDOMIZE - CLR: CLEAR - GRAPHIC PRINT AT (0,90): "CLEAR STATEMENT" - SET WINDOW 0,1,0,1 - FOR I.INT% = 1 TO 10 - PLOT (RND,RND),(RND,RND) - NEXT I.INT% - KEY% = PAUSE - CLEAR - - REM ILLUSTRATE EFFECT OF AUTOMATIC CLIPPING WHEN FIGURE - REM EXCEEDS ALLOWABLE BOUNDARIES - - CLP: SET WINDOW 0,100,0,100 - GRAPHIC PRINT AT (0,90): "CLIP STATEMENT" - PLOT (25,10),(50,150),(75,10),(25,10) - KEY% = PAUSE - - REM DRAW BORDER IN EACH AVAILABLE COLOR (NUMBER OF - REM COLORS VARIES WITH RESOLUTION) - - COLR: CLEAR - GRAPHIC PRINT AT (0,90): \ - "COLOR AND COLOR COUNT STATEMENTS" - SET WINDOW 0,1,0,1 - ASK COLOR COUNT CT% - FOR I.INT% = 1 TO CT% - SET COLOR I.INT% - PLOT (0,0),(0,1),(1,1),(1,0),(0,0) - KEY% = PAUSE - NEXT I.INT% - - REM RETRIEVE AND DISPLAY SPECIFICATIONS FOR CURRENT DEVICE - - DEVC: CLEAR - SET CHARACTER HEIGHT 0 - SET COLOR 1 - GRAPHIC PRINT AT (0,.8): "DEVICE STATEMENT" - ASK DEVICE X.AXIS,Y.AXIS - PRINT "THE VERTICAL AXIS IS "; \ - Y.AXIS*100.0/X.AXIS;"PERCENT OF THE"; - PRINT " HORIZONTAL AXIS" - PRINT "X= ";X.AXIS;" Y= ";Y.AXIS - KEY% = PAUSE - - REM MENTION "GRAPHIC CLOSE" STATEMENT - - GCLOSE: CLEAR - GRAPHIC PRINT AT (0,.9): "GRAPHIC CLOSE STATEMENT" - GRAPHIC PRINT AT (0,.5): "GRAPHIC CLOSE HAS NO DEMO" - KEY% = PAUSE - - REM ILLUSTRATE GRAPHIC INPUT VIA CURSOR POSITIONING - - GIN: CLEAR - SET WINDOW 0,100,0,100 - SET CHARACTER HEIGHT 0 - GRAPHIC PRINT AT (0,80): "GRAPHIC INPUT STATEMENT" - GRAPHIC PRINT AT (0,25): "OPTION 1 ." - SET COLOR 2 - GRAPHIC PRINT AT (0,50): "OPTION 2 ." - SET COLOR 3 - GRAPHIC PRINT AT (0,75): "OPTION 3 ." - GRAPHIC INPUT X.AXIS,Y.AXIS,A$ - N = INT((Y.AXIS+5)/25) - IF N = 0 THEN N = 1 REM NO OPTION ZERO - IF N > 3 THEN N = 3 REM ONLY THREE OPTIONS - PRINT "THE CURSOR WAS POSITIONED AT: "; X.AXIS,Y.AXIS - PRINT "YOU SELECTED OPTION: "; N - PRINT "THE TERMINATING KEY WAS: "; A$ - KEY% = PAUSE - - REM MENTION "GRAPHIC OPEN" STATEMENT - - GOPEN: CLEAR - SET COLOR 1 - SET CHARACTER HEIGHT 0 - GRAPHIC PRINT AT (0,90): "GRAPHIC OPEN STATEMENT" - GRAPHIC PRINT AT (0,50): \ - "THE GRAPHIC OPEN HAS NO DEMONSTRATION" - KEY% = PAUSE - - REM DEMONSTRATE CENTERING AND JUSTIFICATION - - GPRT: CLEAR - SET WINDOW 0,1,0,1 - SET CHARACTER HEIGHT 0 - GRAPHIC PRINT AT (0,.9): "GRAPHIC PRINT STATEMENT" - SET JUSTIFY 0,0 - GRAPHIC PRINT AT (.5,.5): "BEGINS AT CENTER" - KEY% = PAUSE - SET JUSTIFY .5,0 - GRAPHIC PRINT AT (.5,.3): "THIS IS CENTERED" - KEY% = PAUSE - SET JUSTIFY .5,.5 - GRAPHIC PRINT AT (.5,.3): "THIS IS CENTERED" - KEY% = PAUSE - SET JUSTIFY 1.0,1.0 - GRAPHIC PRINT AT (.5,.5): "ENDS AT CENTER" - KEY% = PAUSE - JUST: CLEAR - SET JUSTIFY 0,0 - SET WINDOW 0,100,0,100 - SET CHARACTER HEIGHT 0 - GRAPHIC PRINT AT (0,90): "JUSTIFY STATEMENT" - PLOT (20,80),(20,20),(80,20) - PLOT (15,40),(20,40) - PLOT (15,60),(20,60) - PLOT (15,80),(20,80) - PLOT (40,15),(40,20) - PLOT (60,15),(60,20) - PLOT (80,15),(80,20) - SET JUSTIFY 1,.5 - GRAPHIC PRINT AT (14,20): "20" - GRAPHIC PRINT AT (14,40): "40" - GRAPHIC PRINT AT (14,60): "60" - GRAPHIC PRINT AT (14,80): "80" - SET JUSTIFY .5,1 - GRAPHIC PRINT AT (20,14): "20" - GRAPHIC PRINT AT (40,14): "40" - GRAPHIC PRINT AT (60,14): "60" - GRAPHIC PRINT AT (80,14): "80" - KEY% = PAUSE - - REM EXHIBIT VARIATION OF LINE STYLE - - STYL: CLEAR - SET JUSTIFY 0,0 - SET WINDOW 0,1,0,1 - GRAPHIC PRINT AT (0,.9): "LINE STYLE STATEMENT" - SET LINE STYLE 3 - SET JUSTIFY 1,0 - GRAPHIC PRINT AT (.5,.5): "Sign here" - PLOT (0.5,0.5),(0.8,0.5) - KEY% = PAUSE - - REM ILLUSTRATE VARIATION IN SIZE OF MARKERS - - MHIGH: CLEAR - SET WINDOW 0,1,0,1 - SET CHARACTER HEIGHT 0 - SET LINE STYLE 1 - SET JUSTIFY 0,0 - GRAPHIC PRINT AT (0,.9): "MARKER HEIGHT STATEMENT" - DIM MX(5) - DIM MY(5) - MX(0) = .3 : MY(0) = .7 - MX(1) = .7 : MY(1) = .7 - SET MARKER HEIGHT .1 - MAT MARKER 1: MX,MY - SET WINDOW 0,100,0,100 - MX(0) = 30 : MY(0) = 50 - MX(1) = 70 : MY(1) = 50 - SET MARKER HEIGHT 15 - MAT MARKER 1: MX,MY - SET MARKER HEIGHT 0 - ASK MARKER HEIGHT MK - PRINT "MINIMUM MARKER HEIGHT IS = "; MK - KEY% = PAUSE - - REM DEMONSTRATE ALL MARKER SHAPES - - MTYPE: CLEAR - SET WINDOW 0,1,0,1 - SET MARKER HEIGHT 0 - GRAPHIC PRINT AT (0,.9): "MARKER TYPE STATEMENT" - MX(0) = .5 : MY(0) = .7 - FOR I.INT% = 1 TO 5 - SET MARKER TYPE I.INT% - MAT MARKER 0: MX,MY - MY(0) = MY(0) - .1 - NEXT I.INT% - KEY% = PAUSE - - REM DEMONSTRATE FILLED POLYGON - - MFILL: CLEAR - SET LINE STYLE 1 - SET JUSTIFY 0,0 - GRAPHIC PRINT AT (0,.9): "MAT FILL STATEMENT" - SET WINDOW 0,100,0,100 - SET CHARACTER HEIGHT 0 - SET COLOR 1 - DIM X.ARRAY(10) - DIM Y.ARRAY(10) - X.ARRAY(0) = 40 : Y.ARRAY(0) = 10 - X.ARRAY(1) = 35 : Y.ARRAY(1) = 25 - X.ARRAY(2) = 50 : Y.ARRAY(2) = 40 - X.ARRAY(3) = 65 : Y.ARRAY(3) = 25 - X.ARRAY(4) = 60 : Y.ARRAY(4) = 10 - MAT FILL 4: X.ARRAY,Y.ARRAY - KEY% = PAUSE - - REM ILLUSTRATE POSITIONING OF MARKERS VIA AN ARRAY - - MMARK: CLEAR - SET WINDOW 0,100,0,100 - GRAPHIC PRINT AT (0,90): "MAT MARKER STATEMENT" - SET MARKER HEIGHT 0 - SET MARKER TYPE 1 - SET COLOR 1 - MAT MARKER 4: X.ARRAY,Y.ARRAY - KEY% = PAUSE - - REM DEMONSTRATE DRAWING POLYGON OUTLINE VIA AN ARRAY - - MPLOT: CLEAR - GRAPHIC PRINT AT (0,90): "MAT PLOT STATEMENT" - SET COLOR 1 - SET WINDOW 0,1,0,1 - SET CHARACTER HEIGHT 0 - FOR I.INT% = 0 TO 4 - X.ARRAY(I.INT%) = .01 * X.ARRAY(I.INT%) - Y.ARRAY(I.INT%) = .01 * Y.ARRAY(I.INT%) - NEXT I.INT% - X.ARRAY(5) = .40 : Y.ARRAY(5) = .10 - SET BEAM "OFF" - MAT PLOT 4: X.ARRAY,Y.ARRAY - KEY% = PAUSE - CLEAR - MAT PLOT 5: X.ARRAY,Y.ARRAY - KEY% = PAUSE - - REM DO POLYGON VIA "PLOT" STATEMENTS - - PLT: CLEAR - SET WINDOW 0,100,0,100 - SET CHARACTER HEIGHT 0 - SET COLOR 1 - GRAPHIC PRINT AT (0,90): "PLOT STATEMENT" - PLOT (40,10),(35,25); - SET COLOR 2 - PLOT (35,25),(50,40); - SET LINE STYLE 2 - PLOT (50,40),(65,25); - SET LINE STYLE 1 - SET COLOR 3 - PLOT (65,25),(60,10),(40,10) - KEY% = PAUSE - - REM EXERCISE ARBITRARY POSITIONING OF GRAPHIC BEAM - - POSIT: CLEAR - GRAPHIC PRINT AT (0,90): "POSITION STATEMENT" - SET BEAM "OFF" - SET POSITION 50,50 - SET POSITION 50,100 - SET BEAM "ON" - SET POSITION 0,0 - SET POSITION 50,50 - KEY% = PAUSE - - REM SHOW ALL LINE STYLES - - STCNT: CLEAR - GRAPHIC PRINT AT (0,90): "STYLE COUNT STATEMENT" - SET WINDOW 0,100,0,100 - SET CHARACTER HEIGHT 0 - ASK STYLE COUNT ST% - PRINT "THE NUMBER OF LINE STYLES IS: "; ST% - FOR I.INT% = 1 TO ST% - SET LINE STYLE I.INT% - SET BEAM "OFF" - PLOT (10*I.INT%,10),(10*I.INT%,90) - NEXT I.INT% - KEY% = PAUSE - SET LINE STYLE 1 - - REM DEMONSTRATE ROTATION OF TEXT - - ANGEL: CLEAR - GRAPHIC PRINT AT (0,90): "TEXT ANGLE STATEMENT" - SET WINDOW 0,1,0,1 - SET CHARACTER HEIGHT 0 - PI = 3.1415926 - RAD = PI*2 - DEG = RAD/360 - FOR I.INT% = 90 TO 360 STEP 90 - SET TEXT ANGLE I.INT%*DEG - GRAPHIC PRINT AT (.5,.5): "ROTATE ME" - NEXT I.INT% - KEY% = PAUSE - SET TEXT ANGLE 0 - - REM ILLUSTRATE EFFECT OF VARYING VIEWPORT - - VYOU: CLEAR - GRAPHIC PRINT AT (0,.9): "VIEWPORT STATEMENT" - X.ARRAY(0) = 0 : Y.ARRAY(0) = 0 - X.ARRAY(1) = 0 : Y.ARRAY(1) = 100 - X.ARRAY(2) = 100 : Y.ARRAY(2) = 100 - X.ARRAY(3) = 100 : Y.ARRAY(3) = 0 - X.ARRAY(4) = 0 : Y.ARRAY(4) = 0 - SET VIEWPORT 0,1,0,1 - SET WINDOW 0,100,0,100 - SET CHARACTER HEIGHT 0 - MAT PLOT 4: X.ARRAY,Y.ARRAY - SET VIEWPORT .1,.9,.1,.9 - MAT PLOT 4: X.ARRAY,Y.ARRAY - SET VIEWPORT .2,.8,.2,.8 - MAT PLOT 4: X.ARRAY,Y.ARRAY - SET VIEWPORT .3,.5,.3,.5 - MAT PLOT 4: X.ARRAY,Y.ARRAY - SET VIEWPORT .5,.7,.5,.7 - MAT PLOT 4: X.ARRAY,Y.ARRAY - KEY% = PAUSE - - REM ILLUSTRATE EFFECT OF VARYING WINDOW - - WINDW: CLEAR - SET VIEWPORT 0,1,0,1 - SET WINDOW 0,100,0,100 - SET CHARACTER HEIGHT 0 - GRAPHIC PRINT AT (0,90): "WINDOW STATEMENT" - PLOT (0,0),(60,60),(60,0),(0,0) - SET WINDOW 0,200,0,200 - SET CHARACTER HEIGHT 0 - PLOT (0,0),(60,60),(60,0),(0,0) - SET VIEWPORT 0,.5,.5,1.0 - PLOT (0,0),(60,60),(60,0),(0,0) - KEY% = PAUSE - - REM FINISH DEMONSTRATION AND END PROGRAM - - FIN: CLEAR - SET WINDOW 0,100,0,100 - SET CHARACTER HEIGHT 0 - SET VIEWPORT 0,1,0,1 - SET COLOR 1 - FOR I.INT% = 1 TO CT% - SET COLOR I.INT% - MAT PLOT 5: X.ARRAY,Y.ARRAY - SET VIEWPORT .01*I.INT%,1-(I.INT%*.01), \ - .01*I.INT%,1-(I.INT%*.01) - NEXT I.INT% - SET JUSTIFY .5,.5 - SET COLOR 1 - SET VIEWPORT 0,1,0,1 - GRAPHIC PRINT AT (50,50): "THANKS FOR THE VIEWING" - KEY% = PAUSE - STOP - END -  \ No newline at end of file diff --git a/software/CPM/CPM06_COBOL80_v20/GRAPHCOM.BAS b/software/CPM/CPM06_COBOL80_v20/GRAPHCOM.BAS deleted file mode 100644 index 86ac41c..0000000 --- a/software/CPM/CPM06_COBOL80_v20/GRAPHCOM.BAS +++ /dev/null @@ -1,4 +0,0 @@ -COMMON ?VIEW(2),?WIND(2),?P(2),?P1(2),?KAPU(2) -COMMON ?PTSI%(1),?PTSO%(1),?CONT%(1),?INTI%(1),?INTO%(1) -COMMON ?VWTX(2),?RVIW(2),?VX(1),?XN,?YN,?XW,?YW - \ No newline at end of file diff --git a/software/CPM/CPM06_COBOL80_v20/GRAPHR.BAS b/software/CPM/CPM06_COBOL80_v20/GRAPHR.BAS deleted file mode 100644 index 6704471..0000000 --- a/software/CPM/CPM06_COBOL80_v20/GRAPHR.BAS +++ /dev/null @@ -1,321 +0,0 @@ -REM THIS IS A DEMONSTRATION PROGRAM FOR DRAWING -REM PIE AND BAR CHARTS. -REM -REM PROGRAM NAME: GRAPHR.BAS -REM - %INCLUDE GRAPHCOM.BAS - GRAPHIC OPEN 1 - CLEAR - - REM If the device supports color fill, MAT FILL - REM statements are used. Otherwise, MAT PLOT - REM is used to draw figures. - -IN.FL: INPUT "DOES THIS DEVICE SUPPORT COLOR FILL? Y/N: ";FILL.FLG$ - IF FILL.FLG$ = "Y" OR FILL.FLG$ = "N" THEN GOTO OK.FL - PRINT "ENTER Y OR N, PLEASE" - GOTO IN.FL -OK.FL: PRINT "THANK-YOU" - - REM Initialize the arrays used for drawing the - REM slices in the pie chart. Two 100 element arrays - REM are constructed for drawing a full circle. Each - REM point in the arrays then represents one percent. - - PRINT "CALCULATING OCCURRING --- PLEASE WAIT" - DIM X.ARRAY(100) - DIM Y.ARRAY(100) - DIM A.ARRAY(72) - DIM B.ARRAY(72) - A.ARRAY(0) = .5 - B.ARRAY(0) = .5 - L.CIR = 0 - FOR I.ANGLE = 0 TO 6.28-.0628 STEP .0628 - X.ARRAY(L.CIR) = .5 + (.5 * COS(I.ANGLE)) - Y.ARRAY(L.CIR) = .5 + (.5 * SIN(I.ANGLE)) - L.CIR = L.CIR + 1 - NEXT I.ANGLE - - REM Close the circle - - X.ARRAY(L.CIR) = X.ARRAY(0) - Y.ARRAY(L.CIR) = Y.ARRAY(0) - GOTO START.IT - - REM This function draws a slice beginning at the - REM point represented by BEG.PER and extending - REM through PER.CENT points. The color is set to - REM COL.OR and the ASCII.ID prints as an identifier - REM for the slice. - - REM The function extracts the points from X.ARRAY - REM and Y.ARRAY and places them in A.ARRAY and - REM B.ARRAY. MAT FILL and MAT PLOT always begin - REM drawing at the first elements of the arrays, so - REM the slice must be extracted from the arrays. - - REM The function makes provision for slices that - REM exceed 71 points. MAT FILL and MAT PLOT allow - REM a maximum element number of 72. - -DEF DRAW.SLICE (BEG.PER,PER.CENT,COL.OR,ASCII.ID) - REAL BEG.PER,PER.CENT,COL.OR - STRING ASCII.ID - L.CIR = 1 - SET COLOR COL.OR - OVR.FLOW = 0 - - REM Setup for slices greater than 71 percent. - - IF PER.CENT > 71 THEN SAVE.PER = 71:OVR.FLOW = 1\ - ELSE SAVE.PER = PER.CENT - - REM Extract points from circle array. - -BAK.UP: FOR CNT.ER = BEG.PER TO BEG.PER + SAVE.PER - IN.DEX = CNT.ER - IF CNT.ER > 100 THEN IN.DEX = CNT.ER - 100 - A.ARRAY(L.CIR) = X.ARRAY(IN.DEX) - B.ARRAY(L.CIR) = Y.ARRAY(IN.DEX) - L.CIR = L.CIR + 1 - NEXT CNT.ER - - REM OVER.FLOW is 1 for a more than 71 percent slice. - - IF OVR.FLOW <> 1 THEN GOTO OVER.A - - REM FILL.FLG$ is "N" for non-color-fill devices. - - IF FILL.FLG$ = "N" THEN MAT PLOT L.CIR-1: A.ARRAY,B.ARRAY\ - ELSE MAT FILL L.CIR-1: A.ARRAY,B.ARRAY - OVR.FLOW = 0 - BEG.PER = BEG.PER + 71 - SAVE.PER = PER.CENT - 71 - IF FILL.FLG$ = "N" THEN L.CIR = 0 ELSE L.CIR = 1 - GOTO BAK.UP -OVER.A: A.ARRAY(0) = .5 - B.ARRAY(0) = .5 - - REM The slice must be closed for MAT PLOT. MAT FILL - REM closes automatically. - - IF FILL.FLG$ = "N" THEN\ - A.ARRAY(L.CIR) = .5: \ - B.ARRAY(L.CIR) = .5: \ - MAT PLOT L.CIR: A.ARRAY,B.ARRAY \ - ELSE \ - MAT FILL L.CIR-1: A.ARRAY,B.ARRAY - - REM Expand the viewport for printing the slice ID. - REM The minimum character height is used to adjust - REM the window so the slice ID will appear outside - REM the slice perimeter. - - SET VIEWPORT 1.0-Y.AXIS,1,0,1 - ADJ.IT = MIN.HGT/1.45 - SET WINDOW -ADJ.IT,1+ADJ.IT,-ADJ.IT,1+ADJ.IT - - REM MID.PT is the center elements in the slice. This - REM is the position where the ID is printed. - - MID.PT = INT(BEG.PER+(PER.CENT/2)) - X.AXIS = X.ARRAY(MID.PT) - Y.AXIS = Y.ARRAY(MID.PT) - GRAPHIC PRINT AT (X.AXIS,Y.AXIS): ASCII.ID - SET WINDOW 0,1,0,1 - RETURN -FEND - - REM The first portion of the program allows entry - REM of up to 9 slices. Enter the item number (1-9) - REM and press the return key. Then type the slice - REM description (up to 6 characters), the dollar - REM value of the slice, and the color code for - REM the slice. - - REM The following entries are a good sample: - - REM 1 - REM RENT,550,1 - REM 2 - REM FOOD,450,2 - REM 3 - REM CAR,225,3 - REM 4 - REM OTHER,750,4 - - REM This sets up a graph of four items--rent of - REM $550 in color 1, food for $450 in color 2, etc. - - REM Terminate the input by typing 0 in response - REM to the ITEM NUMBER(0 TO FINISH): prompt. - - REM After the 0 entry, the program calculates the - REM percentages and prints a listing of the entries. - - REM Corrections may be made by entering the - REM item number to be corrected and inputting - REM the correct data. - -START.IT: PRINT - DIM ITM.DESC$(9) - DIM ITM.VALUE(9) - DIM ITM.COLOR(9) - DIM ITM.PERC(9) -GO.A: PRINT "ENTER AN ITEM NUMBER FROM 1 TO 9 TO ADD OR CHANGE" - PRINT - PRINT "THEN ENTER--DESCRIPTION,AMOUNT,COLOR,RETURN" - PRINT - PRINT " DESCRIPTION IS THE SLICE DESCRIPTION" - PRINT " AMOUNT IS THE QUANTITY/AMOUNT OF THE SLICE" - PRINT " COLOR IS THE COLOR NUMBER TO USE FOR THE SLICE" - PRINT " RETURN MEANS TO PRESS THE RETURN KEY" - PRINT - PRINT "THE FIELDS ARE SEPARATED BY COMMAS" - PRINT -IN.IT: INPUT "ITEM NUMBER(0 TO FINISH): "; ITM.NUMBER% - IF ITM.NUMBER% = 0 THEN GOTO PRT.EM - IF ITM.NUMBER% > 0 AND ITM.NUMBER% < 10 THEN GOTO OKAY.IN - PRINT "THE ITEM NUMBER MUST BE FROM 1 TO 9" - GOTO IN.IT -OKAY.IN: IF ITM.VALUE(ITM.NUMBER%) = 0 THEN GOTO NEW.IN - PRINT ITM.DESC$(ITM.NUMBER%),ITM.VALUE(ITM.NUMBER%), - PRINT ITM.COLOR(ITM.NUMBER%) -NEW.IN: INPUT "DESC,AMOUNT,COLOR: ";DESC.IN$,VAL.IN,CLR.IN% - ITM.DESC$(ITM.NUMBER%) = DESC.IN$ - ITM.VALUE(ITM.NUMBER%) = VAL.IN - ITM.COLOR(ITM.NUMBER%) = CLR.IN% - PRINT - GOTO IN.IT -PRT.EM: TOT.VAL = 0 - - REM Calculate the total for percentages. - - FOR CNT.R = 1 TO 9 - TOT.VAL = TOT.VAL + ITM.VALUE(CNT.R) - NEXT CNT.R - PRINT - - REM Print the item list with percentages. - - FOR CNT.R = 1 TO 9 - IF ITM.VALUE(CNT.R) <> 0 THEN\ - ITM.PERC(CNT.R) = ITM.VALUE(CNT.R)/TOT.VAL:\ - ITM.PERC(CNT.R) = INT((100*ITM.PERC(CNT.R))+.5):\ - PRINT CNT.R;"-";ITM.DESC$(CNT.R),ITM.VALUE(CNT.R),:\ - PRINT ITM.COLOR(CNT.R);" ";ITM.PERC(CNT.R);"%" - NEXT CNT.R - PRINT:PRINT "TOTAL VALUE: ";TOT.VAL - PRINT:INPUT "DRAW THE GRAPH? ";Y.N$ - IF Y.N$ <> "Y" THEN GOTO IN.IT - CLEAR - BEG.PER = 0 - - REM THE MINIMUM CHARACTER HEIGHT FOR THE DEVICE - REM IS USED TO ESTABLISH A BORDER AROUND THE CIRCLE - REM WHERE THE SLICE ID (THE ITEM NUMBER) CAN BE - REM PRINTED. - - SET CHARACTER HEIGHT 0 - ASK CHARACTER HEIGHT MIN.HGT - MIN.HGT = 2 * MIN.HGT - FOR CNT.R = 1 TO 9 - IF ITM.VALUE(CNT.R) = 0 THEN GOTO NXT.CNT - - REM Determine the aspect ratio and square the device. - REM A border is left around the viewport for the - REM slice ID. The viewport is set to the right - REM of the device. - - ASK DEVICE X.AXIS,Y.AXIS - SET VIEWPORT 1-Y.AXIS+MIN.HGT,1-MIN.HGT,MIN.HGT,1-MIN.HGT - DESC.IN$ = ITM.DESC$(CNT.R) - VAL.IN = ITM.VALUE(CNT.R) - CLR.IN% = ITM.COLOR(CNT.R) - PER.CENT = ITM.PERC(CNT.R) - CALL DRAW.SLICE (BEG.PER,PER.CENT,CLR.IN%,STR$(CNT.R)) - BEG.PER = BEG.PER + PER.CENT - SET VIEWPORT 0,1,0,1 - S.1$ = DESC.IN$+" "+STR$(PER.CENT)+"%" - GRAPHIC PRINT AT (0,1-(CNT.R/10)):S.1$ -NXT.CNT: NEXT CNT.R - - REM Is the graph filled? The percentage calculation - REM can be less than 100 percent due to roundoff. - - IF BEG.PER >= 100 THEN GOTO BAR.A - PER.CENT = 100 - BEG.PER - DESC.IN$ = " " - ASK DEVICE X.AXIS,Y.AXIS - SET VIEWPORT 1-Y.AXIS+MIN.HGT,1-MIN.HGT,MIN.HGT,1-MIN.HGT - CALL DRAW.SLICE (BEG.PER,PER.CENT,CLR.IN%,DESC.IN$) - - REM This routine draws a simple bar chart of the - REM data. The window range is set to 1/3 greater - REM than the largest item in the array. This - REM technique makes the largest bar draw across - REM 75% of the viewport. - -BAR.A: KEY%=CONCHAR% - DIM BAR.X(4) - DIM BAR.Y(4) - SET VIEWPORT 0,1,0,1 - SET WINDOW 0,1,0,1 - SET CHARACTER HEIGHT 0 - ASK CHARACTER HEIGHT MIN.HGT - CLEAR - SET JUSTIFY .5,0 - SET COLOR 1 - GRAPHIC PRINT AT (.5,.99-MIN.HGT):"BAR CHART" - SET JUSTIFY 0,0 - MAX.VAL = 0 - - REM Determine the maximum percentage. - - FOR CNT.R = 1 TO 9 - IF MAX.VAL < ITM.PERC(CNT.R) THEN\ - MAX.VAL = ITM.PERC(CNT.R) - NEXT CNT.R - MAX.VAL = 1.33 * MAX.VAL - - REM Scale the window. The X axis is 1/3 larger - REM than the largest item to be graphed. - REM The Y axis is scaled to 10 lines. - - SET WINDOW 0,MAX.VAL,0,10 - SET CHARACTER HEIGHT 0 - ASK CHARACTER HEIGHT MIN.HGT - - REM Draw the items. - - FOR CNT.R = 1 TO 9 - IF ITM.VALUE(CNT.R) = 0 THEN GOTO NXT.A - SET COLOR ITM.COLOR(CNT.R) - P.LINE = 10 - CNT.R - S.1$ = ITM.DESC$(CNT.R)+"-"+STR$(ITM.PERC(CNT.R))+"%" - IF ITM.VALUE(CNT.R) <> ITM.PERC(CNT.R) THEN\ - S.1$ = S.1$+" $"+STR$(ITM.VALUE(CNT.R)) - GRAPHIC PRINT AT (0,P.LINE): S.1$ - - REM Setup the BAR.X and BAR.Y arrays to draw the - REM bar. MAX.VAL is the percentage for the item. - REM The window scaling automatically scales the - REM bar. No special calculations are required. - - MAX.VAL = ITM.PERC(CNT.R) - TOP = P.LINE - .1 - BOT = TOP - .4 - BAR.Y(0) = BOT - BAR.Y(1) = TOP - BAR.X(2) = MAX.VAL - BAR.Y(2) = TOP - BAR.X(3) = MAX.VAL - BAR.Y(3) = BOT - BAR.Y(4) = BOT - IF FILL.FLG$ = "N" THEN MAT PLOT 4: BAR.X,BAR.Y\ - ELSE MAT FILL 3: BAR.X,BAR.Y -NXT.A: NEXT CNT.R - KEY% = CONCHAR% - STOP - END - \ No newline at end of file diff --git a/software/CPM/CPM06_COBOL80_v20/GSXPREP.BAS b/software/CPM/CPM06_COBOL80_v20/GSXPREP.BAS deleted file mode 100644 index 42fbd9a..0000000 --- a/software/CPM/CPM06_COBOL80_v20/GSXPREP.BAS +++ /dev/null @@ -1,16 +0,0 @@ -100 REM GSXPREP.BAS -110 REM -120 REM -130 REM -140 GSX%=&H30 -150 POKE GSX%+0, -160 POKE GSX%+1,&H59 -170 POKE GSX%+2,&HE -180 POKE GSX%+3,115 -190 POKE GSX%+4,&HC3 -200 POKE GSX%+5,&H5 -210 POKE GSX%+6,&H0 -220 NEW -SX%+1,&H59 -170 POKE GSX%+2,&HE -180 \ No newline at end of file diff --git a/software/CPM/CPM06_COBOL80_v20/LIB.COM b/software/CPM/CPM06_COBOL80_v20/LIB.COM deleted file mode 100644 index 21be8c1..0000000 Binary files a/software/CPM/CPM06_COBOL80_v20/LIB.COM and /dev/null differ diff --git a/software/CPM/CPM06_COBOL80_v20/LINK.COM b/software/CPM/CPM06_COBOL80_v20/LINK.COM deleted file mode 100644 index fe55743..0000000 Binary files a/software/CPM/CPM06_COBOL80_v20/LINK.COM and /dev/null differ diff --git a/software/CPM/CPM06_COBOL80_v20/LK80.COM b/software/CPM/CPM06_COBOL80_v20/LK80.COM deleted file mode 100644 index 5f2ee79..0000000 Binary files a/software/CPM/CPM06_COBOL80_v20/LK80.COM and /dev/null differ diff --git a/software/CPM/CPM06_COBOL80_v20/READ.ME b/software/CPM/CPM06_COBOL80_v20/READ.ME deleted file mode 100644 index 50b7ae9..0000000 --- a/software/CPM/CPM06_COBOL80_v20/READ.ME +++ /dev/null @@ -1,780 +0,0 @@ - ---------------------------------------------------------------- - | | - | | - | | - | | - | ================================================ | - | | | | - | | | | - | | ***** CBASIC Compiler (CB80) ***** | | - | | | | - | | for the CP/M Family of | | - | | of Operating Systems | | - | | | | - | | --------------- | | - | | | | - | | READ.ME File Notes | | - | | | | - | | - June 1983 - | | - | | | | - | | Digital Research Inc. | | - | | P.O. Box 579 | | - | | Pacific Grove, CA 93950 | | - | | | | - | ================================================ | - | | - | | - | | - | This file presents enhancements and modifications | - | made to CBASIC Compiler software and documentation. | - | Changes described in this file apply to CBASIC | - | Compiler (CB80) Version 2.0 and supercede existing | - | product documentation. | - | | - | You can print the information in this file on your | - | line printer using 8 by 11 inch paper with the | - | printer set to 6 lines per inch. You can trim the | - | pages along the dotted lines and place the pages | - | in your product documentation binder. | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - ---------------------------------------------------------------- - - - - - - - - - - - - - - - - ---------------------------------------------------------------- - | CBASIC Compiler (CB80) READ.ME File Notes June 1983 | - | | - | | - | | - | Table of Contents | - | ================================================ | - | | - | Bug Fixes . . . . . . . . . . . . . . . . . . 1 | - | CHAIN Statement . . . . . . . . . . . . . . . 4 | - | DATE$ Function (NEW!) . . . . . . . . . . . . 5 | - | TIME$ Function (NEW!) . . . . . . . . . . . . 6 | - | Graphics Extension Error Messages (NEW!) . . 7 | - | | - | ================================================ | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | i. | - | | - ---------------------------------------------------------------- - - - - - - - - - - - - - - - - ---------------------------------------------------------------- - | CBASIC Compiler (CB80) READ.ME File Notes Bug Fixes | - | | - | | - | | - | Bug Fixes for CB80 | - | =============================================== | - | | - | * The compiler would hang if you used toggle P and | - | F together in the order PF (not FP). | - | | - | * The listing file would be empty if the %NOLIST | - | directive appeared last in a %LIST / %NOLIST pair | - | within the source code. | - | | - | * The system did not issue execution error NS | - | causing the system to hang if a program attempted | - | to format output for an unassigned string variable | - | when no string field existed in the format string. | - | | - | * The compiler would issue error message 41 for an | - | executable statement with a line number when that | - | statement was preceded by a blank line or remark | - | that had a line number. | - | | - | * Compiler toggle O did not work if used in the | - | same command line with toggle I. | - | | - | * PRINT USING did not work if the output string was | - | unassigned. | - | | - | * The run-time system did not trap integer division | - | by zero. | - | | - | * The ERRX function returned MP/M extended error | - | codes multiplied by 256. | - | | - | * The trigonometric functions have been rewritten | - | to resolve certain parameter remove inaccuracies. | - | | - | * Compiler error 101 occured when a keyword was | - | used as a formal parameter in a multiple-line | - | function definition. | - | | - | | - | | - | | - | Page 1 | - | | - ---------------------------------------------------------------- - - - - - - - - - - - - - - - - - - ---------------------------------------------------------------- - | CBASIC Compiler (CB80) READ.ME File Notes Bug Fixes | - | | - | | - | | - | * The compiler did not do signed integer arithmetic | - | correctly. For example, i% = -1 / 16000 would | - | assign the value 4 to i%. | - | | - | * The first read of a fixed file, designed to | - | position the file pointer to the desired record | - | number, did not work. | - | | - | * The system did not close INCLUDE files after | - | reading. | - | | - | * INCLUDE files were not opened in read-only mode. | - | | - | * DELETE and RENAME statements did not trap MP/M | - | extended errors. | - | | - | * If a program attempted to open a file with an | - | improper filename, the system marked that file ID | - | as open. Therefore, if execution continued | - | through an "ON ERROR" statement and a second open | - | was attempted for that ID, the system issued a DF | - | execution error message. Similarly, if a | - | program attempted to open a file with a proper | - | filename, but detected an MP/M extended error, | - | the buffer space was released but the file ID was | - | not released. Therefore, a close error resulted | - | at the end of the program or when chaining. This | - | problem also applied to the CREATE function. | - | | - | * The CREATE function did not trap extended errors. | - | | - | * Execution error TL was not detected for the TAB | - | function. | - | | - | * Compiler error message 213 was issued for the | - | following source lines: | - | PRINT #1; T,OPEN | - | PRINT #1; T,, | - | | - | | - | | - | | - | Page 2 | - | | - |______________________________________________________________| - - - - - - - - - - - - - - - - - ---------------------------------------------------------------- - | CBASIC Compiler (CB80) READ.ME File Notes Bug Fixes | - | | - | | - | | - | * The INITIALIZE function would return execution | - | error message EX under MP/M II upon failure of | - | BDOS functions 13 or 37. (disk system reset or | - | drive reset). | - | | - | * If the first line in the body of a multiple-line | - | function definition was an assignment statement | - | with a built-in function name to the left of the | - | equal sign, the compiler did not detect the error | - | and generated bad code. | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | Page 3 | - | | - ---------------------------------------------------------------- - - - - - - - - - - - - - - - - - ---------------------------------------------------------------- - | CBASIC Compiler (CB80) READ.ME File Notes CHAIN Statement | - | | - | | - | | - | CHAIN Statement | - | =============================================== | - | | - | The CHAIN statement loads another program into | - | memory and starts execution. | - | | - | | - | Syntax: CHAIN | - | | - | | - | Explanation: The CHAIN statement can load two types | - | of programs - an overlay program generated by the | - | linker, or a directly executable file. CHAIN can | - | load files generated by languages other than CBASIC. | - | However, before you chain to an overlay file, the | - | linker must create that overlay and the root | - | program at the same time. | - | | - | The filespec can be a string expression, a variable, | - | or a constant. CB80 assumes a filetype of .OVL and | - | CB86 assumes a filetype of .OVR if you do not | - | specify otherwise in the filespec. | - | | - | When a program chains to a second program, all open | - | files in the original program are closed and all | - | data is reinitialized to 0. Refer to the | - | Programming Guide for more information on chaining | - | modules and programs. | - | | - | | - | Examples: CHAIN "B:AVERAGES" | - | | - | CHAIN NEW.PROG$ | - | | - | TOTALS$ = "ACCOUNTS.OVL" | - | | - | CHAIN CDRIVE$ + TOTAL$ | - | | - | | - | | - | | - | | - | Page 4 | - | | - ---------------------------------------------------------------- - - - - - - - - - - - - - - - - - - ---------------------------------------------------------------- - | CBASIC Compiler (CB80) READ.ME File Notes DATE$ Function | - | | - | | - | | - | DATE$ Function (NEW!) | - | =============================================== | - | | - | The DATE$ function returns a string indicating the | - | current year, month, and day set through the | - | operating system. | - | | - | | - | Syntax: a$ = DATE$ | - | | - | | - | Explanation: DATE$ returns a six character string | - | in the form YYMMDD. YY is the last two digits of | - | a year reference, such as 84 for 1984. MM is one | - | of twelve digit combinations representing the | - | month such as 02 for February or 11 for November. | - | DD is one of thirty-one digit combinations | - | representing the day of the month. The string that | - | DATE$ returns is undefined if the operating system | - | is set to a date later than December 31, 1999 or | - | earlier than January 1, 1978. | - | | - | If your operating system does not support time and | - | date functions, the CBASIC DATE$ function returns | - | a string consisting of six blanks. Refer to your | - | operating system manuals to see if your operating | - | system supports time and date functions. | - | | - | | - | Example: CURRDATE$ = DATE$ | - | PRINT "Today's date is: "; CURRDATE$ | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | Page 5 | - | | - ---------------------------------------------------------------- - - - - - - - - - - - - - - - - - ---------------------------------------------------------------- - | CBASIC Compiler (CB80) READ.ME File Notes TIME$ Function | - | | - | | - | | - | TIME$ Function (NEW!) | - | ================================================ | - | | - | The TIME$ function returns a string indicating the | - | current time of day. | - | | - | | - | Syntax: a$ = TIME$ | - | | - | | - | Explanation: TIME$ returns a six character string | - | of the form HHMMSS. HH is one of 24 digit | - | combinations representing the hour, such as 06 for | - | 6:00 AM or 15 for 3:00 PM. MM is one of sixty | - | digit combinations representing the minute. SS is | - | one of sixty digit combinations representing the | - | second. | - | | - | If your operating system does not support time and | - | date functions, the CBASIC TIME$ function returns a | - | string consisting of six blanks. Refer to your | - | operating system manuals to see if your operating | - | system supports time and date functions. | - | | - | | - | Example: CURRTIME$ = TIME$ | - | PRINT "The current time is: "; CURRTIME$ | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | | - | Page 6 | - | | - ---------------------------------------------------------------- - - - - - - - - - - - - - - - - - ---------------------------------------------------------------- - | CBASIC Compiler (CB80) READ.ME File Notes Graphics Errors | - | | - | | - | | - | Graphics Extension Error Messages (NEW!) | - | ================================================ | - | | - | The following error messages indicate compilation | - | errors that can occur during compilation of a | - | graphics statement in a program. Compilation | - | continues after the error is recorded. | - | | - | Error numbers 180 through 240 inclusive are | - | reserved for use with the CBASIC Compiler | - | graphics extention. | - | | - | | - | Error Meaning | - | | - | 180 A left parenthesis is missing. A left | - | parenthesis is inserted. | - | | - | 181 A right parenthesis is missing. A right | - | parenthesis is inserted. | - | | - | 182 A comma is missing in a PLOT statement. | - | A comma is inserted. | - | | - | 183 The keyword STYLE is missing in a SET or | - | ASK statement. STYLE is inserted. | - | | - | 184 A comma is missing in a SET statement. A | - | comma is inserted. | - | | - | 185 The keyword HEIGHT is missing in a SET or | - | ASK CHARACTER statement. HEIGHT is | - | inserted. | - | | - | 186 The keyword ANGLE is missing in a SET or | - | ASK TEXT statement. ANGLE is inserted. | - | | - | 187 A comma is missing in a SET or ASK WINDOW | - | statement. A comma is inserted. | - | | - | | - | | - | Page 7 | - | | - ---------------------------------------------------------------- - - - - - - - - - - - - - - - - - - ---------------------------------------------------------------- - | CBASIC Compiler (CB80) READ.ME File Notes Graphics Errors | - | | - | | - | | - | 188 A comma is missing in a SET or ASK | - | VIEWPORT statement. A comma is inserted. | - | | - | 189 The keyword PAGE is missing in a SET | - | statement. PAGE is inserted. | - | | - | 190 Not used. | - | | - | 191 The keyword COUNT is missing in a ASK | - | STYLE statement. COUNT is inserted. | - | | - | 192 A comma is missing in an ASK statement. | - | A comma is inserted. | - | | - | 193 Not used. | - | | - | 194 Not used. | - | | - | 195 The keyword COUNT is missing in a SET | - | COLOR statement. COLOR is inserted. | - | | - | 196 Not used. | - | | - | 197 Not used. | - | | - | 198 Not used. | - | | - | 199 Not used. | - | | - | 200 Not used. | - | | - | 201 Not used. | - | | - | 202 Not used. | - | | - | | - | | - | | - | | - | | - | | - | | - | Page 8 | - | | - ---------------------------------------------------------------- - - - - - - - - - - - - - - - - - ---------------------------------------------------------------- - | CBASIC Compiler (CB80) READ.ME File Notes Graphics Errors | - | | - | | - | | - | 203 A comma is missing in an GRAPHIC statement. | - | A comma is inserted. | - | | - | 204 The keyword following GRAPHIC is unexpected. | - | INPUT is inserted. | - | | - | 205 A left parenthesis is missing in a GRAPHIC | - | statement. A left parenthesis is inserted. | - | | - | 206 A right parenthesis is missing in a GRAPHIC | - | statement. A right parenthesis is inserted. | - | | - | 207 A colon is missing in a GRAPHIC statement. | - | A colon is inserted. | - | | - | 208 The variable in an ASK statement is of type | - | real or string. An integer variable is | - | required. | - | | - | 209 The variable in an ASK statement is of type | - | integer or string. A real variable is | - | required. | - | | - | 210 The variable in an ASK statement is of type | - | integer or real. A string variable is | - | required. | - | | - | 211 Not used. | - | | - | 212 Not used. | - | | - | 213 Not used. | - | | - | 214 Not used. | - | | - | 215 Not used. | - | | - | | - | | - | | - | | - | | - | Page 9 | - | | - ---------------------------------------------------------------- - - - - - - - - - - - - - - - - - - - ---------------------------------------------------------------- - | CBASIC Compiler (CB80) READ.ME File Notes Graphics Errors | - | | - | | - | | - | 216 A comma is missing in a GRAPHIC statement. | - | A comma is inserted. | - | | - | 217 The variable in a MAT statement is of type | - | integer or string. A real variable is | - | required. | - | | - | 218 Not used. | - | | - | 219 Not used. | - | | - | 220 Not used. | - | | - | 221 The keyword following MAT is unexpected. | - | FILL is inserted. | - | | - | 222 A colon is missing in a MAT statement. A colon | - | is inserted. | - | | - | 223 An identifier is missing in a MAT statement. | - | An identifier is inserted. | - | | - | 224 A comma is missing in a MAT statement. A | - | comma is inserted. | - | | - | | - | | - | | - | VVVVVVV | - | VVVVV | - | VVV | - | VVV | - | VVV | - | VVVVV | - | VVV | - | V | - | | - | END OF READ.ME FILE | - | | - | | - | | - | | - | Page 10 | - | | - ---------------------------------------------------------------- \ No newline at end of file diff --git a/software/CPM/CPM06_COBOL80_v20/TSTCIR.BAS b/software/CPM/CPM06_COBOL80_v20/TSTCIR.BAS deleted file mode 100644 index 716542d..0000000 --- a/software/CPM/CPM06_COBOL80_v20/TSTCIR.BAS +++ /dev/null @@ -1,46 +0,0 @@ -REM DEMONSTRATION PROGRAM FOR CIRCLE DRAWING FUNCTIONS -REM -REM PROGRAM NAME: TSTCIR.BAS -REM - %INCLUDE GRAPHCOM.BAS - %INCLUDE CIRCOM.BAS - GRAPHIC OPEN 1 - CLEAR - PRINT "COMPUTING" - CALL BEG.CIR - PRINT "ENDED" - CALL PLOT.CIR - KEY% = CONCHAR% REM WAIT FOR KEYBOARD - -REM SCALE THE WINDOW TO DRAW A PROPERLY PROPORTIONED CIRCLE - - ASK DEVICE X.AXIS,Y.AXIS - PRINT X.AXIS,Y.AXIS - SET WINDOW 0,X.AXIS/Y.AXIS,0,1 - CALL PLOT.CIR - KEY%=CONCHAR% - CALL FILL.CIR - KEY%=CONCHAR% - -REM CHANGE THE VIEWPORT TO REPOSITION THE CIRCLE - - SET VIEWPORT 0,.5,0,.5 REM LOWER LEFT QUARTER - CLEAR - CALL PLOT.CIR - KEY%=CONCHAR% - - SET VIEWPORT .5,1,0,.5 REM LOWER RIGHT QUARTER - CALL PLOT.CIR - KEY%=CONCHAR% - - SET VIEWPORT 0,.5,.5,1 REM UPPER LEFT QUARTER - CALL PLOT.CIR - KEY%=CONCHAR% - - SET VIEWPORT .5,1,.5,1 REM UPPER RIGHT QUARTER - CALL PLOT.CIR - KEY%=CONCHAR% - - STOP - END - \ No newline at end of file diff --git a/software/CPM/CPM07_COBOL80/CALL.ASM b/software/CPM/CPM07_COBOL80/CALL.ASM deleted file mode 100644 index 3300152..0000000 --- a/software/CPM/CPM07_COBOL80/CALL.ASM +++ /dev/null @@ -1,23 +0,0 @@ -; Program "Call" called by "Testcall"; this is assembler version; -; compare with functionally equivalent COBOL version. - - cseg - - ldax b ; read first param: A = text length -loop: - dcr a ; count down length - rm ; finished - push psw - ldax d ; next byte from second param = text - inx d - push d - mov e,a - mvi c,6 ; CP/M function code - call 5 ; call CP/M to send character - pop d - pop psw - jmp loop - -; End of demonstration program "Call" - -end diff --git a/software/CPM/CPM07_COBOL80/CALL.CBL b/software/CPM/CPM07_COBOL80/CALL.CBL deleted file mode 100644 index b452a83..0000000 --- a/software/CPM/CPM07_COBOL80/CALL.CBL +++ /dev/null @@ -1,26 +0,0 @@ -000000****************************************************************** -000000* -000000* Program "Call" called by "Testcall"; this is COBOL version; -000000* compare with functionally equivalent assembler version. -000000* -000000****************************************************************** -000000 Working-storage section. -000000 01 temp pic 9(2) comp. -000000 01 text-buffer value space. -000000 02 tbuf-table pic x occurs 80. -000000 Linkage section. -000000 01 mess-text. -000000 02 mtex-table pic x occurs 80. -000000 01 mess-size pic 9(2) comp. -000000 Procedure division using mess-size,mess-text. -000000 l. -000000 move 0 to temp perform move-byte until temp = mess-size. -000000 display text-buffer. -000000 exit program. -000000 move-byte. -000000 add 1 to temp move mtex-table (temp) to tbuf-table (temp). -000000****************************************************************** -000000* -000000* End of demonstration program "Call" -000000* -000000****************************************************************** diff --git a/software/CPM/CPM07_COBOL80/CALL.INT b/software/CPM/CPM07_COBOL80/CALL.INT deleted file mode 100644 index 68c2a20..0000000 Binary files a/software/CPM/CPM07_COBOL80/CALL.INT and /dev/null differ diff --git a/software/CPM/CPM07_COBOL80/CALL.PRL b/software/CPM/CPM07_COBOL80/CALL.PRL deleted file mode 100644 index a877d42..0000000 Binary files a/software/CPM/CPM07_COBOL80/CALL.PRL and /dev/null differ diff --git a/software/CPM/CPM07_COBOL80/CLI b/software/CPM/CPM07_COBOL80/CLI deleted file mode 100644 index d382802..0000000 Binary files a/software/CPM/CPM07_COBOL80/CLI and /dev/null differ diff --git a/software/CPM/CPM07_COBOL80/CLI.CBL b/software/CPM/CPM07_COBOL80/CLI.CBL deleted file mode 100644 index fc39ba3..0000000 --- a/software/CPM/CPM07_COBOL80/CLI.CBL +++ /dev/null @@ -1,240 +0,0 @@ -000000 IDENTIFICATION DIVISION. -000000****************************************************************** -000000* * -000000* COPYRIGHT (C) 1982,1982 MICRO FOCUS LTD. * -000000* * -000000* MICRO FOCUS LTD. * -000000* 58, ACACIA ROAD, * -000000* ST. JOHNS WOOD, * -000000* LONDON NW8 6AG. * -000000* * -000000* TEL. 01 722 8843/4/5/6/7 * -000000* TELEX 28536 MICROF G * -000000* * -000000****************************************************************** -000000* -000000 PROGRAM-ID. COMMAND LINE INTERPRETOR. -000000 AUTHOR. MICRO FOCUS LTD. -000000 INSTALLATION. MICRO FOCUS - SWINDON. -000000 DATE-WRITTEN. 6TH DECEMBER 1982. -000000 DATE-COMPILED. 6TH DECEMBER 1982. -000000* -000000 ENVIRONMENT DIVISION. -000000 SOURCE-COMPUTER. 8080. -000000 OBJECT-COMPUTER. 8080. -000000 SPECIAL-NAMES. CONSOLE IS CRT. -000000/***************************************************************** -000000* * -000000* DATA USED BY THE CLI TO STORE THE USER'S INSTRUCTIONS. * -000000* * -000000****************************************************************** -000000* -000000 DATA DIVISION. -000000 WORKING-STORAGE SECTION. -000000* -000000 01 TEMP PIC 9(2) COMP. -000000 01 SUB1 PIC 9(2) COMP. -000000 01 SUB2 PIC 9(2) COMP. -000000 01 SUB2-SAV PIC 9(2) COMP. -000000 01 TMAX PIC 9(2) COMP. -000000 01 CHOICE PIC X. -000000* -000000 01 RTS-ROUTINES. -000000 02 POKE-CLI PIC X VALUE X"91". -000000 02 CHAIN PIC X VALUE X"84". -000000 02 GET-CHAR PIC X VALUE X"D8". -000000 02 SOUND-ALARM PIC X VALUE X"E5". -000000* -000000* DISPLAY LINES -000000* -000000 01 INIT-LINE. -000000 02 INIT-LINE-1 PIC X(68) VALUE "COBOL: A(nimate) C(ompile) D( -000000- "rive) F(orms2) Q(uit) R(un) S(witches)". -000000 02 FILLER PIC X(4). -000000 02 INIT-CHOICE PIC X. -000000* -000000 01 FILE-QUESTION-LINE. -000000 02 FQL-1 PIC X(22) VALUE "Enter name of file to ". -000000 02 VERB PIC X(8). -000000* -000000* COMMAND-LINE COMPONENTS -000000* -000000 01 SWITCH-AREA. -000000 02 FILLER PIC X VALUE "(". -000000 02 SWITCHES PIC X(40) VALUE SPACE. -000000* -000000 01 FILE-NAME PIC X(16). -000000* -000000 01 CLI-REST PIC X(80). -000000* -000000 01 WORK-AREA. -000000 02 WORK-BYTE PIC 9(2) OCCURS 80 COMP. -000000* -000000 01 OUTPUT-CLI VALUE SPACE. -000000 02 OUT-BYTE PIC 9(2) OCCURS 128 COMP. -000000* -000000 01 PROG-AREA. -000000 02 DRIVE PIC X VALUE SPACE. -000000 02 FILLER PIC X VALUE ":". -000000 02 PROG-NAME PIC X(16). -000000* -000000/***************************************************************** -000000* * -000000* MAIN ENTRY TO CLI PROGRAM. IS USED BY ORDINARY ENTRY TO * -000000* COMMAND LINE INTERPRETOR, AS WELL AS BY PROGRAMS WHICH ARE * -000000* RETURNING CONTROL TO THE CLI FOR CONTINUATION COMMANDS. * -000000* * -000000****************************************************************** -000000* -000000 PROCEDURE DIVISION. -000000 MAIN-ENTRY. -000000* -000000* TEST IF SCREEN SHOULD BE CLEARED. IF "X" ON COMMAND LINE, THEN -000000* THIS IS A SECOND OR SUBSEQUENT ENTRY, AND THE SCREEN SHOULD -000000* NOT BE CLEARED. -000000* -000000 ACCEPT WORK-AREA FROM CONSOLE. -000000 IF WORK-AREA NOT = "X" -000000 DISPLAY SPACE. -000000 CALL SOUND-ALARM. -000000* -000000 LOOP. -000000 MOVE SPACE TO INIT-CHOICE. -000000 DISPLAY INIT-LINE. -000000 DISPLAY LOW-VALUE AT 0170. -000000 CALL GET-CHAR USING CHOICE. -000000 DISPLAY SPACE. -000000 MOVE CHOICE TO INIT-CHOICE. -000000 DISPLAY INIT-LINE. -000000* -000000 IF CHOICE = "A" OR "a" -000000 MOVE "ANIMATE:" TO VERB -000000 MOVE "ANIMATE.COM" TO PROG-NAME -000000 GO TO FILE-QUESTION. -000000 IF CHOICE = "C" OR "c" -000000 MOVE "COMPILE:" TO VERB -000000 MOVE "COBOL.COM" TO PROG-NAME -000000 GO TO FILE-QUESTION. -000000 IF CHOICE = "D" OR "d" -000000 GO TO DRIVE-SET. -000000 IF CHOICE = "F" OR "f" -000000 MOVE "FORMS2.COM" TO PROG-NAME -000000 MOVE 0 TO SUB2 -000000 GO TO LOADER. -000000 IF CHOICE = "Q" OR "q" -000000 GO TO EXITING. -000000 IF CHOICE = "R" OR "r" -000000 MOVE "RUN:" TO VERB -000000 MOVE "RUN.COM" TO PROG-NAME -000000 GO TO FILE-QUESTION. -000000 IF CHOICE = "S" OR "s" -000000 GO TO SWITCH-SET. -000000 CALL SOUND-ALARM. -000000 GO TO LOOP. -000000* -000000/***************************************************************** -000000* * -000000* CODE TO HANDLE FILENAME OF PROGRAM TO BE COMPILED, ANIMATED * -000000* OR EXECUTED. * -000000* * -000000****************************************************************** -000000* -000000 FILE-QUESTION. -000000 MOVE SPACE TO FILE-NAME. -000000 DISPLAY FILE-QUESTION-LINE AT 0201. -000000 ACCEPT FILE-NAME AT 0232. -000000 IF FILE-NAME = SPACES -000000 GO TO LOOP. -000000* -000000 PERFORM CLEAR-LINES. -000000 MOVE SPACE TO CLI-REST. -000000 DISPLAY "Any further command line ?" AT 0201. -000000 ACCEPT CLI-REST AT 0301. -000000* -000000 MOVE 0 TO SUB2. -000000 IF "RUN.COM" = PROG-NAME -000000 IF SPACE NOT = SWITCHES -000000 MOVE SWITCH-AREA TO WORK-AREA -000000 MOVE 41 TO TMAX -000000 MOVE 0 TO SUB1 -000000 PERFORM TRANSFER-BUFFER -000000 ADD 1 TO SUB2 -000000 MOVE 41 TO OUT-BYTE (SUB2). -000000 MOVE FILE-NAME TO WORK-AREA. -000000 MOVE 0 TO SUB1. -000000 MOVE 16 TO TMAX. -000000 PERFORM TRANSFER-BUFFER. -000000 MOVE CLI-REST TO WORK-AREA. -000000 MOVE 0 TO SUB1. -000000 MOVE 80 TO TMAX. -000000 PERFORM TRANSFER-BUFFER. -000000 IF SUB2 > 80 -000000 GO TO CLI-OVF. -000000* -000000* COMMAND LINE NOW CREATED, CHAIN TO THE NEXT PROGRAM. THIS -000000* IS DONE BY SETTING A COMMAND LINE FOR THE RTS TO EXECUTE. -000000* -000000 LOADER. -000000 CALL POKE-CLI USING SUB2, OUTPUT-CLI. -000000 PERFORM CLEAR-LINES. -000000 DISPLAY "Loading ..." at 0201. -000000 DISPLAY LOW-VALUE AT 0301. -000000 IF DRIVE = SPACE -000000 CALL CHAIN USING PROG-NAME -000000 ELSE -000000 CALL CHAIN USING PROG-AREA. -000000* -000000/***************************************************************** -000000* * -000000* SUPPORT CLI ROUTINES, USED TO MANIPULATE THE FIELDS BEFORE * -000000* CONTROL IS TRANSFERRED TO A SUPPORT PROGRAM. * -000000* * -000000****************************************************************** -000000* -000000 SWITCH-SET. -000000 MOVE SPACE TO SWITCHES. -000000 DISPLAY "Switches:" AT 0201. -000000 ACCEPT SWITCHES AT 0211. -000000 INSPECT SWITCHES REPLACING -000000 ALL "(" BY SPACE -000000 ALL ")" BY SPACE. -000000 GO TO LOOP. -000000* -000000 DRIVE-SET. -000000 DISPLAY "Enter Drive:" AT 0201. -000000 ACCEPT DRIVE AT 0214. -000000 GO TO LOOP. -000000* -000000 EXITING. -000000 DISPLAY "Returning to CP/M" AT 0201. -000000 DISPLAY LOW-VALUE AT 0301. -000000 STOP RUN. -000000* -000000/***************************************************************** -000000* * -000000* WORK ROUTINES USED TO MANIPULATE THE SCREEN. * -000000* * -000000****************************************************************** -000000* -000000 CLI-OVF. -000000 PERFORM CLEAR-LINES. -000000 DISPLAY "Command buffer overflow" AT 0301. -000000 GO TO LOOP. -000000* -000000 CLEAR-LINES. -000000 MOVE SPACE TO WORK-AREA. -000000 DISPLAY WORK-AREA AT 0201. -000000 DISPLAY WORK-AREA AT 0301. -000000* -000000 TRANSFER-BUFFER. -000000 ADD 1 TO SUB1. -000000 ADD 1 TO SUB2. -000000 MOVE WORK-BYTE (SUB1) TO TEMP. -000000 IF TEMP NOT = 32 -000000 MOVE SUB2 TO SUB2-SAV -000000 MOVE TEMP TO OUT-BYTE (SUB2). -000000 IF SUB1 < TMAX -000000 GO TO TRANSFER-BUFFER. -000000 MOVE SUB2-SAV TO SUB2. -000000 ADD 1 TO SUB2. -000000* diff --git a/software/CPM/CPM07_COBOL80/CLI.COM b/software/CPM/CPM07_COBOL80/CLI.COM deleted file mode 100644 index 08e83e6..0000000 Binary files a/software/CPM/CPM07_COBOL80/CLI.COM and /dev/null differ diff --git a/software/CPM/CPM07_COBOL80/COBOL b/software/CPM/CPM07_COBOL80/COBOL deleted file mode 100644 index c0d5fcc..0000000 Binary files a/software/CPM/CPM07_COBOL80/COBOL and /dev/null differ diff --git a/software/CPM/CPM07_COBOL80/COBOL.COM b/software/CPM/CPM07_COBOL80/COBOL.COM deleted file mode 100644 index f9e131b..0000000 Binary files a/software/CPM/CPM07_COBOL80/COBOL.COM and /dev/null differ diff --git a/software/CPM/CPM07_COBOL80/COBOL.ERR b/software/CPM/CPM07_COBOL80/COBOL.ERR deleted file mode 100644 index 890d40e..0000000 --- a/software/CPM/CPM07_COBOL80/COBOL.ERR +++ /dev/null @@ -1,160 +0,0 @@ -Compiler error; consult Technical Support -Illegal format : Data-name -Illegal format : Literal, or invalid use of ALL -Illegal format : Character -Data-name not unique -Too many data or procedure names declared -Illegal character in column 7 or continuation error -Nested COPY statement or unknown COPY file specified -'.' missing -Statement starts in wrong area of source line -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -'.' missing -DIVISION missing -SECTION missing -IDENTIFICATION missing -PROGRAM-ID missing -AUTHOR missing -INSTALLATION missing -DATE-WRITTEN missing -SECURITY missing -ENVIRONMENT missing -CONFIGURATION missing -SOURCE-COMPUTER missing -OBJECT-COMPUTER/SPECIAL-NAMES clause error -OBJECT-COMPUTER missing -Compiler error; consult Technical Support -SPECIAL-NAMES missing -SWITCH clause error or system name/mnemonic name error -DECIMAL-POINT clause error -CONSOLE clause error -Illegal currency symbol -'.' missing -DIVISION missing -SECTION missing -INPUT-OUTPUT missing -FILE-CONTROL missing -ASSIGN missing -SEQUENTIAL or RELATIVE or INDEXED missing -ACCESS missing on indexed/relative file -SEQUENTIAL or DYNAMIC missing or > 64 alternate keys -Illegal ORGANIZATION/ACCESS/KEY combination -Unrecognized phrase in SELECT clause -RERUN clause syntax error -SAME AREA clause syntax error -Missing or illegal file-name -DATA DIVISION missing -PROCEDURE DIVISION missing or unknown statement -Program collating sequence not defined -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -'.' missing -DIVISION missing -SECTION missing -File-name not specified in SELECT stmt or invalid CD name -RECORD SIZE integer missing or line sequential rec > 1024 bytes -Illegal level no (01-49),01 level reqd,or level hierarachy wrong -FD, CD or SD qualification syntax error -WORKING-STORAGE missing -PROCEDURE DIVISION missing or unknown statement -Data description qualifier or '.' missing -Incompatible PICTURE clause and qualifiers -BLANK illegal with non-numeric data-item -PICTURE clause too long -VALUE with non-elementary item,wrong data-type or value truncated -VALUE in error or illegal for PICTURE type -Non-elementary item has FILLER/SYNC/JUST/BLANK clause -Preceding item at this level has > 8192 bytes or 0 bytes -REDEFINES of unequal fields or different levels -Data storage exceeds 64K bytes -Compiler error; consult Technical Support -Data description qualifier inappropriate or repeated -REDEFINES data-name not declared -USAGE must be COMP,DISPLAY or INDEX -SIGN must be LEADING or TRAILING -SYNCHRONIZED must be LEFT or RIGHT -JUSTIFIED must be RIGHT -BLANK must be ZERO -OCCURS must be numeric, non-zero, unsigned or DEPENDING -VALUE must be literal, numeric literal or figurative constant -PICTURE string has illegal precedence or illegal char -INDEXED data-name missing or already declared -Numeric-edited PICTURE string is too large -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Unrecognized verb -IF....ELSE mismatch -Operand has wrong data-type, is not declared or '.' missing -Procedure not unique -Procedure name same as data-name -Name required -Wrong combination of data-types -Conditional statement not allowed in this context -Malformed subscript -ACCEPT/DISPLAY wrong or Communications syntax incorrect -Illegal syntax used with I-O verb -Invalid arithmetic statement -Invalid arithmetic expression -Compiler error; consult Technical Support -Invalid conditional expression -IF stmts nested too deep, or too many AFTERs in PERFORM stmt -Incorrect structure of PROCEDURE DIVISION -Reserved word missing or incorrectly used -Too many subscripts in one statement (internal buffer overflow) -Too many operands in one statement -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Inter-segment procedure name duplication -Unterminated condition at end of source -Operand has wrong data-type or not declared -Procedure name undeclared -INDEX data-name declared twice -Bad cursor control : illegal AT clause -KEY declaration missing or illegal -STATUS declaration missing -Bad STATUS record -Undefined inter-segment reference or error in ALTERed para -PROCEDURE DIVISION in error -USING parameter not declared in LINKAGE SECTION -USING parameter not level 01 or 77 -USING parameter used twice in parameter list -FD missing -Compiler error; consult Technical Support -Incorrect structure of PROCEDURE DIVISION -Compiler error; consult Technical Support -Compiler error; consult Technical Support -Too many operands in one statement diff --git a/software/CPM/CPM07_COBOL80/COBOL.I51 b/software/CPM/CPM07_COBOL80/COBOL.I51 deleted file mode 100644 index c7bf8fb..0000000 Binary files a/software/CPM/CPM07_COBOL80/COBOL.I51 and /dev/null differ diff --git a/software/CPM/CPM07_COBOL80/COBOL.I52 b/software/CPM/CPM07_COBOL80/COBOL.I52 deleted file mode 100644 index 07953e3..0000000 Binary files a/software/CPM/CPM07_COBOL80/COBOL.I52 and /dev/null differ diff --git a/software/CPM/CPM07_COBOL80/COBOL.I53 b/software/CPM/CPM07_COBOL80/COBOL.I53 deleted file mode 100644 index 2506bd7..0000000 Binary files a/software/CPM/CPM07_COBOL80/COBOL.I53 and /dev/null differ diff --git a/software/CPM/CPM07_COBOL80/COBOL.I56 b/software/CPM/CPM07_COBOL80/COBOL.I56 deleted file mode 100644 index 4f1be47..0000000 Binary files a/software/CPM/CPM07_COBOL80/COBOL.I56 and /dev/null differ diff --git a/software/CPM/CPM07_COBOL80/COBOL.I59 b/software/CPM/CPM07_COBOL80/COBOL.I59 deleted file mode 100644 index 2566943..0000000 Binary files a/software/CPM/CPM07_COBOL80/COBOL.I59 and /dev/null differ diff --git a/software/CPM/CPM07_COBOL80/COBOL.ISR b/software/CPM/CPM07_COBOL80/COBOL.ISR deleted file mode 100644 index 6ad3a50..0000000 Binary files a/software/CPM/CPM07_COBOL80/COBOL.ISR and /dev/null differ diff --git a/software/CPM/CPM07_COBOL80/CONFIG b/software/CPM/CPM07_COBOL80/CONFIG deleted file mode 100644 index ea03942..0000000 Binary files a/software/CPM/CPM07_COBOL80/CONFIG and /dev/null differ diff --git a/software/CPM/CPM07_COBOL80/IXSIO.INT b/software/CPM/CPM07_COBOL80/IXSIO.INT deleted file mode 100644 index 38fc577..0000000 Binary files a/software/CPM/CPM07_COBOL80/IXSIO.INT and /dev/null differ diff --git a/software/CPM/CPM07_COBOL80/PI.CBL b/software/CPM/CPM07_COBOL80/PI.CBL deleted file mode 100644 index 4a952fb..0000000 --- a/software/CPM/CPM07_COBOL80/PI.CBL +++ /dev/null @@ -1,83 +0,0 @@ - IDENTIFICATION DIVISION. - PROGRAM-ID. PI-CALC. - AUTHOR. PF/TR. - * - ENVIRONMENT DIVISION. - CONFIGURATION SECTION. - OBJECT-COMPUTER. MDS-800. - SPECIAL-NAMES. CONSOLE IS CRT. - * - DATA DIVISION. - WORKING-STORAGE SECTION. - * - 01 SCREEN PIC X(1920). - * - 01 DI-1 REDEFINES SCREEN. - 02 FILLER PIC X(160). - 02 DI-TX1 PIC X(160). - 02 DI-TX2 PIC X(13). - 02 DI-TERM PIC X(15). - 02 FILLER PIC X(136). - 02 DI-TX3 PIC X(6). - 02 DI-PI PIC X(15). - 02 FILLER PIC X(1415). - * - 01 DI-2 REDEFINES SCREEN. - 02 FILLER PIC X(333). - 02 DI-TERM2 PIC X(15). - 02 FILLER PIC X(142). - 02 DI-PI2 PIC X(15). - 02 FILLER PIC X(1415). - * - 01 WORK-AREA. - 02 PI PIC S9V9(14). - 02 TERM PIC S9V9(14). - 02 W PIC S9V9(14). - 02 N PIC 9999. - 02 N1 PIC 9999. - 02 N2 PIC 9999. - 02 ED PIC -9.9(12). - * - 01 CONSTANTS. - 02 TX1 PIC X(17) VALUE "CALCULATION OF PI". - 02 TX2 PIC X(12) VALUE "NEXT TERM IS". - 02 TX3 PIC X(5) VALUE "PI IS". - * - PROCEDURE DIVISION. - LA-START. - DISPLAY SPACE. - MOVE SPACE TO SCREEN. - MOVE TX1 TO DI-TX1. - MOVE TX2 TO DI-TX2. - MOVE TX3 TO DI-TX3. - MOVE 0.5 TO ED. - MOVE ED TO DI-TERM. - MOVE 3 TO ED. - MOVE ED TO DI-PI. - DISPLAY DI-1. - MOVE 0.5 TO PI. - MOVE 0.5 TO TERM. - MOVE 3 TO N. - LOOP. - MOVE N TO N2. - SUBTRACT 2 FROM N2. - MULTIPLY N2 BY N2. - MULTIPLY N2 BY TERM. - MOVE N TO N1. - SUBTRACT 1 FROM N1. - MULTIPLY N BY N1. - MULTIPLY 4 BY N1. - DIVIDE N1 INTO TERM. - IF TERM < 0.0000000000001 THEN GO TO HALT. - ADD TERM TO PI. - MOVE PI TO W. - MULTIPLY 6 BY W. - MOVE W TO ED. - MOVE ED TO DI-PI2. - MOVE TERM TO ED. - MOVE ED TO DI-TERM2. - DISPLAY DI-2. - ADD 2 TO N. - IF N < 100 GO TO LOOP. - HALT. - STOP RUN. diff --git a/software/CPM/CPM07_COBOL80/RUN.COM b/software/CPM/CPM07_COBOL80/RUN.COM deleted file mode 100644 index 5a7d240..0000000 Binary files a/software/CPM/CPM07_COBOL80/RUN.COM and /dev/null differ diff --git a/software/CPM/CPM07_COBOL80/STOCK1.CBL b/software/CPM/CPM07_COBOL80/STOCK1.CBL deleted file mode 100644 index 3a73fd3..0000000 --- a/software/CPM/CPM07_COBOL80/STOCK1.CBL +++ /dev/null @@ -1,59 +0,0 @@ -000010 IDENTIFICATION DIVISION. -000020 PROGRAM-ID. STOCK-FILE-SET-UP. -000030 AUTHOR. MICRO FOCUS LTD. -000040 ENVIRONMENT DIVISION. -000050 CONFIGURATION SECTION. -000060 SOURCE-COMPUTER. MDS-800. -000070 OBJECT-COMPUTER. MDS-800. -000075 SPECIAL-NAMES. CONSOLE IS CRT. -000080 INPUT-OUTPUT SECTION. -000090 FILE-CONTROL. -000100 SELECT STOCK-FILE ASSIGN "STOCK.IT" -000110 ORGANIZATION INDEXED -000120 ACCESS DYNAMIC -000130 RECORD KEY STOCK-CODE. -000140 DATA DIVISION. -000150 FILE SECTION. -000160 FD STOCK-FILE; RECORD 32. -000170 01 STOCK-ITEM. -000180 02 STOCK-CODE PIC X(4). -000190 02 PRODUCT-DESC PIC X(24). -000200 02 UNIT-SIZE PIC 9(4). -000210 WORKING-STORAGE SECTION. -000220 01 SCREEN-HEADINGS. -000230 02 ASK-CODE PIC X(21) VALUE "STOCK CODE < >". -000240 02 FILLER PIC X(59). -000250 02 ASK-DESC PIC X(16) VALUE "DESCRIPTION <". -000260 02 SI-DESC PIC X(25) VALUE " >". -000270 02 FILLER PIC X(39). -000280 02 ASK-SIZE PIC X(21) VALUE "UNIT SIZE < >". -000290 01 ENTER-IT REDEFINES SCREEN-HEADINGS. -000300 02 FILLER PIC X(16). -000310 02 CRT-STOCK-CODE PIC X(4). -000320 02 FILLER PIC X(76). -000330 02 CRT-PROD-DESC PIC X(24). -000340 02 FILLER PIC X(56). -000350 02 CRT-UNIT-SIZE PIC 9(4). -000360 02 FILLER PIC X. -000370 PROCEDURE DIVISION. -000380 SR1. -000390 DISPLAY SPACE. -000400 OPEN I-O STOCK-FILE. -000410 DISPLAY SCREEN-HEADINGS. -000420 NORMAL-INPUT. -000430 MOVE SPACE TO ENTER-IT. -000440 DISPLAY ENTER-IT. -000450 CORRECT-ERROR. -000460 ACCEPT ENTER-IT. -000470 IF CRT-STOCK-CODE = SPACE GO TO END-IT. -000480 IF CRT-UNIT-SIZE NOT NUMERIC GO TO CORRECT-ERROR. -000490 MOVE CRT-PROD-DESC TO PRODUCT-DESC. -000500 MOVE CRT-UNIT-SIZE TO UNIT-SIZE. -000510 MOVE CRT-STOCK-CODE TO STOCK-CODE. -000520 WRITE STOCK-ITEM; INVALID GO TO CORRECT-ERROR. -000530 GO TO NORMAL-INPUT. -000540 END-IT. -000550 CLOSE STOCK-FILE. -000560 DISPLAY SPACE. -000570 DISPLAY "END OF PROGRAM". -000580 STOP RUN. diff --git a/software/CPM/CPM07_COBOL80/STOCK2.CBL b/software/CPM/CPM07_COBOL80/STOCK2.CBL deleted file mode 100644 index 46c1097..0000000 --- a/software/CPM/CPM07_COBOL80/STOCK2.CBL +++ /dev/null @@ -1,119 +0,0 @@ - IDENTIFICATION DIVISION. - PROGRAM-ID. GOODS-IN. - AUTHOR. MICRO FOCUS LTD. - ENVIRONMENT DIVISION. - CONFIGURATION SECTION. - SOURCE-COMPUTER. MDS-800. - OBJECT-COMPUTER. MDS-800. - SPECIAL-NAMES. CONSOLE IS CRT. - INPUT-OUTPUT SECTION. - FILE-CONTROL. - SELECT STOCK-FILE ASSIGN "STOCK.IT" - ORGANIZATION INDEXED - ACCESS DYNAMIC - RECORD KEY STOCK-CODE. - SELECT TRANS-FILE - ASSIGN "STOCK.TRS" - ORGANIZATION SEQUENTIAL. - / - DATA DIVISION. - FILE SECTION. - FD STOCK-FILE; RECORD 32. - 01 STOCK-ITEM. - 02 STOCK-CODE PIC X(4). - 02 STOCK-DESCRIPT PIC X(24). - 02 UNIT-SIZE PIC 9(4). - FD TRANS-FILE; RECORD 30. - 01 TRANS-RECORD. - 02 TRAN-NO PIC 9(4). - 02 TF-STOCK-CODE PIC X(4). - 02 TF-QUANTITY PIC 9(8). - 02 TF-ORDER-NO PIC X(6). - 02 TF-DATE PIC X(8). - WORKING-STORAGE SECTION. - 01 STOCK-INWARD-FORM. - 02 PRG-TITLE PIC X(20) VALUE " GOODS INWARD". - 02 FILLER PIC X(140). - 02 CODE-HDNG PIC X(23) VALUE "STOCK CODE < >". - 02 FILLER PIC X(57). - 02 ORDER-NO-HDNG PIC X(23) VALUE "ORDER NO < >". - 02 FILLER PIC X(57). - 02 DATE-HDNG PIC X(24) VALUE "DELIVERY DATE MM/DD/YY". - 02 FILLER PIC X(56). - 02 UNITS-HDNG PIC X(23) VALUE "NO OF UNITS < >". - 01 STOCK-RECEIPT REDEFINES STOCK-INWARD-FORM. - 02 FILLER PIC X(178). - 02 SR-STOCK-CODE PIC X(4). - 02 FILLER PIC X(74). - 02 SR-ORDER-NO PIC X(6). - 02 FILLER PIC X(73). - 02 SR-DATE. - 04 SR-MM PIC 99. - 04 FILLER PIC X. - 04 SR-DD PIC 99. - 04 FILLER PIC X. - 04 SR-YY PIC 99. - 02 FILLER PIC X(75). - 02 SR-NO-OF-UNITS PIC 9(4). - 01 CONFIRM-MSG REDEFINES STOCK-INWARD-FORM. - 02 FILLER PIC X(184). - 02 CM-STOCK-DESCRIPT PIC X(24). - 02 FILLER PIC X(352). - 02 UNIT-SIZE-HDNG PIC X(18). - 02 CM-UNIT-SIZE PIC 9(4). - 02 FILLER PIC X(58). - 02 QUANTITY-HDNG PIC X(14). - 02 CM-QUANTITY PIC 9(8). - 02 FILLER PIC X(58). - 02 OK-HDNG PIC X(3). - 02 CM-Y-OR-N PIC X. - / - PROCEDURE DIVISION. - START-PROC. - OPEN I-O STOCK-FILE. - OPEN OUTPUT TRANS-FILE. - DISPLAY SPACE. - MOVE 0 TO TRAN-NO. - DISPLAY STOCK-INWARD-FORM. - GET-INPUT. - ACCEPT STOCK-RECEIPT. - IF SR-STOCK-CODE = SPACE GO TO END-IT. - IF SR-NO-OF-UNITS NOT NUMERIC GO TO INVALID-ENTRY. - MOVE SR-STOCK-CODE TO STOCK-CODE. - READ STOCK-FILE; INVALID GO TO INVALID-CODE. - *VALID ENTRY, CALCULATE AND DISPLAY TOTAL QUANTITY IN TO CONFIRM - MOVE STOCK-DESCRIPT TO CM-STOCK-DESCRIPT. - MOVE "UNIT SIZE" TO UNIT-SIZE-HDNG. - MOVE UNIT-SIZE TO CM-UNIT-SIZE. - MOVE "QUANTITY IN" TO QUANTITY-HDNG. - MOVE UNIT-SIZE TO TF-QUANTITY. - MULTIPLY SR-NO-OF-UNITS BY TF-QUANTITY. - MOVE TF-QUANTITY TO CM-QUANTITY. - MOVE "OK?" TO OK-HDNG. - DISPLAY CONFIRM-MSG. - ACCEPT CM-Y-OR-N AT 1004. - IF CM-Y-OR-N = "Y" PERFORM WRITE-TRANS. - *CLEAR INPUT DATA ON SCREEN - MOVE SPACE TO CONFIRM-MSG. - MOVE "MM/DD/YY" TO SR-DATE. - DISPLAY STOCK-RECEIPT. - DISPLAY CONFIRM-MSG. - GO TO GET-INPUT. - WRITE-TRANS. - ADD 1 TO TRAN-NO. - MOVE STOCK-CODE TO TF-STOCK-CODE. - MOVE SR-ORDER-NO TO TF-ORDER-NO. - MOVE GET-INPUT TO TF-DATE. - WRITE TRANS-RECORD. - INVALID-ENTRY. - DISPLAY "NON-NUMERIC NO OF UNITS" AT 0325. - GO TO GET-INPUT. - INVALID-CODE. - DISPLAY "INVALID CODE " AT 0325. - GO TO GET-INPUT. - END-IT. - CLOSE STOCK-FILE. - CLOSE TRANS-FILE. - DISPLAY SPACE. - DISPLAY "END OF PROGRAM". - STOP RUN. diff --git a/software/CPM/CPM07_COBOL80/TESTCALL.CBL b/software/CPM/CPM07_COBOL80/TESTCALL.CBL deleted file mode 100644 index ddc74b8..0000000 --- a/software/CPM/CPM07_COBOL80/TESTCALL.CBL +++ /dev/null @@ -1,19 +0,0 @@ -000000****************************************************************** -000000* -000000* Program "Testcall" to demonstrate L/II COBOL calling mechanism -000000* -000000****************************************************************** -000000 Working-storage section. -000000 01 progname pic x(4). -000000 01 message-size pic 9(2) comp value 60. -000000 01 message-text pic x(60) value -000000 "This message is sent via a called program to the screen.". -000000 Procedure division. -000000 move "call" to progname. -000000 call progname using message-size,message-text -000000 overflow display "call overflowed". -000000****************************************************************** -000000* -000000* End of demonstration program "Testcall" -000000* -000000****************************************************************** diff --git a/software/CPM/CPM07_COBOL80/TESTCALL.INT b/software/CPM/CPM07_COBOL80/TESTCALL.INT deleted file mode 100644 index 83e25e3..0000000 Binary files a/software/CPM/CPM07_COBOL80/TESTCALL.INT and /dev/null differ diff --git a/software/CPM/CPM08_Z80FORTH/%DISC.DOC b/software/CPM/CPM08_Z80FORTH/%DISC.DOC deleted file mode 100644 index cfd2214..0000000 --- a/software/CPM/CPM08_Z80FORTH/%DISC.DOC +++ /dev/null @@ -1,27 +0,0 @@ - Size Recs Bytes Ext Acc - 0 0 0k 1 R/W E:%DISC.DOC - 17 17 3k 1 R/O E:CONPRTIO.280 - 38 38 5k 1 R/O E:DISCIO.280 - 18 18 3k 1 R/O E:EDITOR.DOC - 1441 537 58k 6 R/O E:SCREENS.FRT - 64 64 8k 1 R/O E:STARTUP.FRT - 52 52 7k 1 R/O E:280FORTH.COM - 16 16 2k 1 R/O E:280FORTH.UPD - 425 425 54k 4 R/O E:280FORTH.280 - - - -%DISC .DOC this text -CONPRTIO.280 Z280 fig-FORTH console driver (*include file) -DISCIO .280 Z280 fig-FORTH disc driver (*include file) -EDITOR .DOC fig-FORTH editor commands -SCREENS .FRT misc. screens, EDITOR from SCR #7. ASSEMBLER from SCR #13. - MODEM7 from SCR # 18. - Random access file, copy to empty disc before use. -STARTUP .FRT more screens -280FORTH.COM Z280 fig-FORTH 1.1a -280FORTH.UPD Deviations from Installation Manual -280FORTH.280 Source, *include-s CONPRTIO.FTH & DISCIO.FTH - -Invoke the desired screens file at CCP level, e.g. A>280FORTH B:SCREENS.FRT - \ No newline at end of file diff --git a/software/CPM/CPM08_Z80FORTH/280FORTH b/software/CPM/CPM08_Z80FORTH/280FORTH deleted file mode 100644 index b936b58..0000000 --- a/software/CPM/CPM08_Z80FORTH/280FORTH +++ /dev/null @@ -1,4071 +0,0 @@ - title < Z280 fig-FORTH 1.1 a > - subttl Adaptive version -; -; -; Modified from Z80 fig-FORTH 1.1h by EHR 880830 -; Modified frm FIG document keyed by Dennis L. Wilson 800907 -; Converted frm "8080 FIG-FORTH VERSION A0 15SEP79" -; -; fig-FORTH release 1.1 for the 8080 processor. -; -; ALL PUBLICATIONS OF THE FORTH INTEREST GROUP -; ARE PUBLIC DOMAIN. THEY MAY BE FURTHER -; DISTRIBUTED BY THE INCLUSION OF THIS CREDIT NOTICE: -; -; This publication has been made available by the -; Forth Interest Group -; P.O.Box 1105 -; San Carlos, CA 94070 -; U.S.A. -; -; Implementation on 8080 by: -; John Cassady -; 339 15th Street -; Oakland, CA 94612 -; U.S.A -; on 790528 -; Modified by: -; Kim Harris -; Acknowledgements: -; George Flammer -; Robt. D. Villwock -; ---------------------------------------------------------------------- -; Z80 Version for Cromemco CDOS & Digital Research CP/M by: -; Dennis Lee Wilson c/o -; Aristotelian Logicians -; 2631 East Pinchot Avenue -; Phoenix, AZ 85016 -; U.S.A. -; ---------------------------------------------------------------------- -; The 2 byte Z80 code for Jump Relative (JR) has been substituted for -; the 3 byte Jump (JP) wherever practical. The port I/O words P@ & P! -; have been made ROMable by use of Z80 instructions. -; ---------------------------------------------------------------------- -; Further modifications (marked ;/) by: -; Edmund Ramm -; P.O.Box 38 -; 2358 Kaltenkirchen -; Fed. Rep. of Germany 840418 -; -; 850419 changed * (star) -; 850507 added 0<>, 0>, TUCK, NIP, -ROT, CSWAP, PICK -; 850511 added -CMOVE -; -; ----------------------------------------------------------------------------- -; Disc I/O has been modified a la Albert van der Horst (HCCH) to employ -; CP/M 2.x's random access feature. -; ----------------------------------------------------------------------------- -; ----------------------------------------------------------------------------- -; -; Z280 specifics -; -; -iopreg equ 08h ; i/o page register -; -config0 equ 0e0h ; c/t 0 configuration register -cntrl0 equ 0e1h ; c/t 0 command/status register -tcon0 equ 0e2h ; c/t 0 time constatnt register -count0 equ 0e3h ; c/t 0 count-time register -config1 equ 0e8h ; c/t 1 configuration register -cntrl1 equ 0e9h ; c/t 1 command/status register -tcon1 equ 0eah ; c/t 1 time constant register -count1 equ 0ebh ; c/t 1 count-time register -; -; ----------------------------------------------------------------------------- -; -; Release & Version numbers -; -figrel equ 1 ;FIG RELEASE # -figrev equ 1 ;FIG REVISION # -usrver equ 61h ;USER VERSION # a by EHR -; -;Console & printer drivers are in external source named -;CONPRTIO.FTH & disc drivers in DISCIO.FTH. It has 4 screen -;buffers & end of memory is set to FBASE from locn. 0007H. - page -; ASCII characters used -; -abl equ 20h ;BLANK -acr equ 0dh ;CR -adot equ 2eh ;. -bell equ 07h ;^G -bsin equ 08h ;backspace chr = ^H -bsout equ 08h -dle equ 10h ;^P -lf equ 0ah ;^J -ff equ 0ch ;^L -; -; Memory allocation -; -bdoss equ 0005h ;/ system entry -nscr equ 4 ; # of 1024 byte screens -kbbuf equ 128 ; bytes/disc buffer -us equ 40h ; user variables space -rts equ 400h ; Return Stack & term buff space -co equ kbbuf+4 ; Disc buff + 2 header + 2 tail -nbuf equ nscr*400h/kbbuf ; # of buffers -bufsiz equ co*nbuf ;/ total disc buffer size - page - aseg - .z280 -; - org 0100h -; -orig: - nop - jp cld ; vector to cold start - nop - jp wrm ; vector to warm start - defb figrel ; fig release # - defb figrev ; fig revision # - defb usrver ; user version # - defb 0eh ; implementation attributes -; -; -; -; 0eh = 0000:1110 -; --------- -; B +ORIGIN ...W:IEBA -; -; W: 0=above sufficient -; 1=other differences exist -; I: Interpreter is 0=pre- -; 1=post incrementing -; E: Addr must be even: 0 yes -; 1 no -; B: High byte @ 0=low addr. -; 1=high addr. -; A: CPU Addr. 0=BYTE -; 1=WORD -; -; -; - defw task-7 ; topmost word in FORTH vocabulary - defw bsin ; backspace chr -upinit: defw 0 ;/ init (up) -; -; * Following used by COLD; must be in same order as user variables * -; -s0init: defw 0 ;/ init (s0) -r0init: defw 0 ;/ init (r0) -tibini: defw 0 ;/ init (TIB) - defw 1fh ; init (WIDTH) - defw 0 ; init (WARNING) - defw initdp ; init (FENCE) - defw initdp ; init (dp) - defw forth+8 ; init (VOC-LINK) -; -; * END DATA USED BY COLD * -; - defw 0018h,0f600h ; Z280 CPU name (hw,lw) - ; (32 bit base 36 integer) - page -; REGISTERS -; -; FORTH Z80 FORTH PRESERVATION RULES -; ----- --- ----------------------- -; IP BC should be preserved -; accross FORTH words. -; W DE sometimes output from -; NEXT, may be altered -; b4 JP'ing to NEXT, -; input only when -; "DPUSH" called. -; SP SP should be used only as -; Data Stack accross -; FORTH words, may be -; used within FORTH -; words if restored -; b4 "NEXT" -; HL Never output frm NEXT -; input only when -; "HPUSH" called -; -; -up: defw 0 ;/ user area ptr -rpp: defw 0 ;/ return stack ptr -buf1: defw 0 ;/ address of 1st disc buffer -; -; -; COMMENT CONVENTIONS: -; -; == means "is equal to" -; <-- means assignment -; #NAME = value of name -; NAME = contents @ name -; (NAME) = contents of cell addressed by name -; cfa = code field address -; lfa = link field address -; nfa = name field address -; pfa = parameter field address -; s1 = 1st word of parameter stack -; s2 = 2nd -"- of -"- -"- -; r1 = 1st -"- of return stack -; r2 = 2nd -"- of -"- -"- -; ( above Stack posn. valid b4 & after execution of any word, not during) -; -; lsb = least significant bit -; msb = most significant bit -; lb = low byte -; hb = high byte -; lw = low word -; hw = high word -; (May be used as suffix to above names) - page -; FORTH ADDRESS INTERPRETER -; POST INCREMENTING VERSION -; -; -; -dpush: - push de -hpush: - push hl ; iy points here -next: - ld h,b ;/ w <-- (ip) ix points here - ld l,c ;/ - ldw hl,(hl) ;/ (hl) --> cfa - inc bc - inc bc ;/ ip += 2 -next1: - ldw de,(hl) ;/ pc <-- (w) - ex de,hl - inc de - jp (hl) ; note: de <-- cfa + 1 -; -; -jnext macro - jp (ix) - endm -; -jhpush macro - jp (iy) - endm -; - page -; FORTH DICTIONARY -; DICTIONARY FORMAT: -; -; BYTE -; ADDRESS NAME CONTENTS -; ------- ---- -------- -; (MSB=1 -; (P=PRECEDENCE BIT -; (S=SMUDGE BIT -; NFA NAME FIELD 1PS MSB=0, NAME'S 1st CHAR -; 0<2CHAR> -; ... -; 1 MSB=1, NAME'S LAST CHAR -; LFA LINK FIELD =PREVIOUS WORD'S NFA -; -;LABEL: CFA CODE FIELD =ADDR CPU CODE -; -; PFA PARAMETER <1PARAM> 1st PARAMETER BYTE -; FIELD <2PARAM> -; ... -; -; -; -dp0: - defb 83h ; LIT - defc 'LIT' - defw 0 ; lfa == 0 marks end of dictionary -lit: - defw $+2 ; s1 <-- (ip) - ld h,b - ld l,c - ldw hl,(hl) ; hl <-- (ip) = literal - inc bc ;/ - inc bc ;/ ip += 2 - jhpush ; s1 <-- hl -; -; - defb 87h ; EXECUTE - defc 'EXECUTE' - defw lit-6 -exec: - defw $+2 - pop hl - jp next1 -; -; - defb 86h ; BRANCH - defc 'BRANCH' - defw exec-0ah -bran: - defw $+2 ; ip += (ip) -bran1: - ld h,b - ld l,c ; hl <-- ip - addw hl,(hl) ; hl <-- ip + branch offset - ld c,l - ld b,h ; ip += branch offset - jnext -; -; - defb 87h ; 0BRANCH - defc '0BRANCH' - defw bran-9 -zbran: - defw $+2 - pop hl - ld a,l - or h - jr z,bran1 ; branch if if s1 == 0 - inc bc ; else skip branch offset - inc bc - jnext -; -; - defb 86h ; (LOOP) - defc '(LOOP)' - defw zbran-0ah -xloop: - defw $+2 - ld hl,(rpp) ; (hl) --> index = r1 - incw (hl) ;/ index += 1 - ldw de,(hl) ;/ de <-- new index - inc hl ;/ - inc hl ;/ hl --> limit(lb) - ld a,e - sub (hl) - ld a,d - inc hl ; hl --> limit(hb) - sbc a,(hl) ; index < limit? - jp m,bran1 ; yes, loop again - inc hl ; no, done - ld (rpp),hl ; discard r1 & r2 - inc bc - inc bc ; skip branch offset - jnext -; -; - defb 87h ; (+LOOP) - defc '(+LOOP)' - defw xloop-9 -xploo: - defw $+2 - pop de ; de <-- increment - ld hl,(rpp) ; hl --> index - ld a,(hl) ; index += increment - add a,e - ld (hl),a - ld e,a - inc hl - ld a,(hl) - adc a,d - ld (hl),a - inc hl ; (hl) --> limit - inc d - dec d - ld d,a ; de <-- new index - jp m,xloo2 ; if incr > 0 - ld a,e - sub (hl) ; then a <-- index - limit - ld a,d - inc hl - sbc a,(hl) - jp xloo3 - -xloo2: - ld a,(hl) ; else a <-- limit - index - sub e - inc hl - ld a,(hl) - sbc a,d -; ; if a < 0 -xloo3: - jp m,bran1 ; then loop again - inc hl ; else done - ld (rpp),hl ; discard r1 & r2 - inc bc ; skip branch offset - inc bc - jnext -; -; - defb 84h ; (DO) - defc '(DO)' - defw xploo-0ah -xdo: - defw $+2 - pop de ; de <-- initial index - ld hl,(rpp) ; hl <-- rp - dec hl - dec hl - pop (hl) ;/ r2 <-- limit - dec hl - dec hl - ldw (hl),de ;/ r1 <-- initial index - ld (rpp),hl ; rp -= 4 - jnext -; -; - defb 81h ; I - defc 'I' - defw xdo-7 -ido: - defw $+2 - ld hl,(rpp) - push (hl) ;/ s1 <-- r1, r1 unchanged - jnext -; -; - defb 85h ; DIGIT - defc 'DIGIT' - defw ido-4 -digit: - defw $+2 - pop hl ; l <-- s1.lb = base value - pop de ; e <-- s2.lb = chr to be converted - ld a,e ; a <-- chr - sub '0' ; >= 0? - jr c,digi2 ;/ < 0 is invalid - cp 0ah ; > 9? - jr c,digi1 ;/ no, test base value - sub 07h ; gap between '9' & 'A', nw 'A'=0ah - cp 0ah ; >= 'A'? - jr c,digi2 ;/ chrs btwn '9' & 'A' are invalid -digi1: - cp l ; < base value? - jr nc,digi2 ;/ no, invalid - ld e,a ; s2 <-- de = converted digit - ld hl,0001h ; s1 <-- true - jp dpush -; -digi2: - ld l,h ; hl <-- false - jhpush ; s1 <-- false -; -; - defb 86h ; (FIND) (2-1)FAILURE - defc '(FIND)' ; (2-3)SUCCESS - defw digit-8 -pfind: - defw $+2 - pop de ; de <-- nfa -pfin1: - pop hl ; hl <-- string addr - push hl ; save for next iteration - ld a,(de) - xor (hl) ; filter differences - and 3fh ; mask msb & precedence bit - jr nz,pfin4 ; lengths differ -pfin2: - inc hl ; hl --> next string chr - inc de ; de --> next name field chr - ld a,(de) - xor (hl) ; filter differences - add a,a ; shift msbit into carry - jr nz,pfin3 ; no match - jr nc,pfin2 ; match so far, loop agn - ld hl,0005h ; string matches - add hl,de ; (sp) <-- pfa - ex (sp),hl -pfin6: - dec de ; de --> nfa - ld a,(de) - or a ; msb=1? =length byte - jp p,pfin6 ; no, try next chr - ld e,a ; e <-- length byte - ld d,00h - ld hl,0001h ; hl <-- true - jp dpush ; name field found, return -; -; above name field not a match, try next one -; -pfin3: - jr c,pfin5 ; carry=end of name field -pfin4: - inc de ; find name field end - ld a,(de) - or a ; msb=1? - jp p,pfin4 ; no, loop -pfin5: - inc de ; de <-- lfa - ex de,hl - ldw de,(hl) ;/ de <-- lfa - ld a,d - or e ; end of dictionary (lfa = 0)? - jr nz,pfin1 ; no, try previous definition - pop hl ; drop string address - ld hl,0 ; hl <-- false - jhpush ; no match found, return -; -; - defb 87h ; ENCLOSE - defc 'ENCLOSE' - defw pfind-9 -encl: - defw $+2 - pop de ; de <-- s1 = delimiter chr - pop hl ; hl <-- s2 = addr of text to scan - push hl ; s4 <-- addr - ld a,e - ld d,a ; d <-- delim chr - ld e,-1 ; init chr offset counter - dec hl ; hl <-- addr - 1 -encl1: - inc hl ; skip over leading delim chrs - inc e - cp (hl) ; delim chr? - jr z,encl1 ; yes, loop - ld d,0 - push de ; s3 <-- e = offset to 1st non delim - ld d,a ; d <-- delim chr - ld a,(hl) - and a ; 1st non-delim=null? - jr nz,encl2 ; no - ld d,0 ; yes - inc e - push de ; s2 <-- offset to byte following null - dec e - push de ; s1 <-- offset to null - jnext -; -encl2: - ld a,d ; A <-- delim chr - inc hl ; hl <-- next chr's address - inc e ; e <-- offset to next chr - cp (hl) ; delim chr? - jr z,encl4 ; yes - ld a,(hl) - and a ; null? - jr nz,encl2 ; no, continue scan -encl3: - ld d,0 - push de ; s2 <-- offset to null - push de ; s1 <-- offset to null - jnext -; -encl4: - ld d,0 - push de ; s2 <-- offset to byte following text - inc e - push de ; s1 <-- offset 2 bytes aft end of word - jnext -; -; - defb 84h ; EMIT - defc 'EMIT' - defw encl-0ah -emit: - defw docol - defw pemit - defw one,outt - defw pstor,semis -; -; - defb 83h ; KEY - defc 'KEY' - defw emit-7 -key: - defw $+2 - jp pkey -; -; - defb 89h ; ?TERMINAL - defc '?TERMINAL' - defw key-6 -qterm: - defw $+2 - ld hl,0 - jp pqter -; -; - defb 82h ; CR - defc 'CR' - defw qterm-0ch -cr: - defw $+2 - jp pcr -; -; - defb 85h ; CMOVE - defc 'CMOVE' - defw cr-5 -cmove: - defw $+2 - exx ;/ save ip - pop bc ; bc <-- s1 = # of chrs - pop de ; de <-- s2 = dest addr - pop hl ;/ hl <-- s3 = source addr - ld a,b - or c ; bc=0? - jr z,cmove1 ; yes, nothing to move - ldir ;/ xfer string -cmove1: - exx ;/ restore ip - jnext -; -; - defb 86h ;/ -CMOVE ( from to count --- ) - defc '-CMOVE' - defw cmove-8 -bcmov: - defw $+2 - exx ; save ip - pop bc ; bc <-- count - pop de ; de <-- destination - pop hl ; hl <-- source - ld a,b - or c ; bc =0? - jr z,bcmov1 ; yes, nothing to move - add hl,bc - dec hl ; hl --> hi end of source block - ex de,hl - add hl,bc - dec hl - ex de,hl ; de --> hi end of dest. block - lddr ; (de) <-- (hl), --hl,bc until bc=0 -bcmov1: - exx ; restore ip - jnext -; -; - defb 82h ; U* 16*16 unsigned multiply - defc 'U*' ; with 32 bit result - defw bcmov-9 -ustar: - defw $+2 - pop de ; de <-- multiplier - pop hl ; hl <-- multiplicant - multuw hl,de ;/ - ex de,hl ;/ de <-- product.lw, hl <-- product.hw - jp dpush ; s2,s1 <-- product.lw,hw -; -; - defb 82h ; U/ ( ud u1 -- urem uq ) - defc 'U/' - defw ustar-5 -uslas: - defw $+2 - exx ;/ save ip - pop bc ; bc <-- divisor - pop hl ; hl <-- dividend.hw - pop de ; de <-- dividend.lw - cpw hl,bc ;/ dividend.hw >= divisor? - jr c,usla1 ; no, go ahead - ld hl,0ffffh ; yes, overflow - ld d,h - ld e,l ;/ set rem & quot to max - jr usla2 -usla1: - ex de,hl ;/ de,hl <-- dividend.hw,lw - divuw dehl,bc ;/ de <-- remainder, hl <-- quotient -usla2: - push de ;/ s2 <-- remainder - push hl ;/ s1 <-- quotient - exx ;/ restore ip - jnext -; -; - defb 83h ; AND - defc 'AND' - defw uslas-5 -andd: - defw $+2 ; s1 <-- s1 AND s2 - pop de - pop hl - ld a,e - and l - ld l,a - ld a,d - and h - ld h,a - jhpush -; -; - defb 82h ; OR - defc 'OR' - defw andd-6 -orr: - defw $+2 ; s1 <-- s1 OR s2 - pop de - pop hl - ld a,e - or l - ld l,a - ld a,d - or h - ld h,a - jhpush -; -; - defb 83h ; XOR - defc 'XOR' - defw orr-5 -xorr: - defw $+2 ; s1 <-- s1 XOR s2 - pop de - pop hl - ld a,e - xor l - ld l,a - ld a,d - xor h - ld h,a - jhpush -; -; - defb 83h ; SP@ - defc 'SP@' - defw xorr-6 -spat: - defw $+2 - ld hl,0 - add hl,sp ; hl <-- sp - jhpush ; s1 <-- sp -; -; - defb 83h ; SP! - defc 'SP!' - defw spat-6 -spsto: - defw $+2 ; sp <-- s0 (user variable) - ld hl,(up) ; hl <-- user variables base address - ld de,6 - add hl,de ; hl --> s0 - ldw sp,(hl) ;/ sp <-- s0 - jnext -; -; - defb 83h ; RP@ - defc 'RP@' - defw spsto-6 -rpat: - defw $+2 - ld hl,(rpp) - jhpush ; s1 <-- rp -; -; - defb 83h ; RP! - defc 'RP!' - defw rpat-6 -rpsto: - defw $+2 ; rp <-- r0 (user variable) - ld hl,(up) ; hl <-- user variables base address - ld de,0008h - add hl,de ; hl --> r0 - ldw hl,(hl) ;/ hl <-- r0 - ld (rpp),hl ;/ rp <-- r0 - jnext -; -; - defb 82h ; ;S - defc ';S' - defw rpsto-6 -semis: - defw $+2 ; ip <-- r1 - ld hl,(rpp) - ldw bc,(hl) ;/ bc <-- r1 - inc hl - inc hl - ld (rpp),hl ; rp += 2 - jnext -; -; - defb 85h ; LEAVE - defc 'LEAVE' - defw semis-5 -leave: - defw $+2 ; limit <-- index - ld hl,(rpp) - ldw de,(hl) ;/ de <-- r1 (= index) - inc hl - inc hl - ldw (hl),de ;/ r2 (= limit) <-- index - jnext -; -; - defb 82h ; >R - defc '>R' - defw leave-8 -tor: - defw $+2 - ld hl,(rpp) - dec hl - dec hl - pop (hl) ;/ r1 <-- s1 - ld (rpp),hl ; rp -= 2 - jnext -; -; - defb 82h ; R> - defc 'R>' - defw tor-5 -fromr: - defw $+2 - ld hl,(rpp) - push (hl) ;/ s1 <-- r1 - inc hl - inc hl - ld (rpp),hl ; rp += 2 - jnext -; -; - defb 81h ; R - defc 'R' - defw fromr-5 -rr: - defw ido+2 -; -; - defb 82h ; 0= - defc '0=' - defw rr-4 -zequ: - defw $+2 - pop de - ld hl,0 - cpw hl,de ;/ - jr nz,zequ1 - inc l ; hl <-- true -zequ1: - jhpush -; -; - defb 83h ;/ 0<> - defc '0<>' - defw zequ-5 -znequ: - defw $+2 - pop de - ld hl,0 - cpw hl,de ;/ - jr z,znequ1 - inc l ; hl <-- true -znequ1: - jhpush -; -; - defb 82h ; 0< - defc '0<' - defw znequ-6 -zless: - defw $+2 - pop af ;/ a <-- s1.hb - rla ;/ carry <-- bit 7 - ld hl,0 ; hl <-- false - rl l ;/ bit 0 <-- carry - jhpush -; -; - defb 82h ;/ 0> - defc '0>' - defw zless-5 -zgt: - defw $+2 - pop de - ld hl,0 - cpw hl,de ;/ - jp p,zgt1 ;/ <= 0 - jp pe,zgt1 ;/ 8000h special case - inc l ;/ hl <-- true -zgt1: - jhpush -; -; - defb 81h ;+ - defc '+' - defw zgt-5 -plus: - defw $+2 - pop de - pop hl - add hl,de - jhpush -; -; - defb 82h ; D+ ( d1l d1h d2l d2h -- d3l d3h) - defc 'D+' - defw plus-4 -dplus: - defw $+2 - exx ;/ save ip - pop bc ; bc <-- d2.hw - pop hl ; hl <-- d2.lw - pop af ;d af <-- d1.hw - pop de ; de <-- d1.lw - push af ;/ s1 <-- d1.hw - add hl,de ; hl <-- d2.lw + d1.lw (= d3.lw) - ex de,hl ; de <-- d3.lw - pop hl ; hl <-- d1.hw - adc hl,bc ;/ hl <-- d1.hw + d2.hw +carry (=d3.hw) - push de ; s2 <-- d3.lw - push hl ;/ s1 <-- d3.hw - exx ;/ restore ip - jnext -; -; - defb 85h ; MINUS - defc 'MINUS' - defw dplus-5 -minus: - defw $+2 - pop hl ;/ - neg hl ;/ - jhpush -; -; - defb 86h ; DMINUS - defc 'DMINUS' - defw minus-8 -dminu: - defw $+2 - exx ;/ save ip - pop de ;/ de <-- d1.hw - pop bc ;/ bc <-- d1.lw - ld hl,0 ;/ - subw hl,bc ;/ - push hl ; s2 <-- d2.lw - ld hl,0 ;/ - sbc hl,de ;/ - push hl ; s1 <-- d2.hw - exx ;/ - jnext -; -; - defb 84h ; OVER - defc 'OVER' - defw dminu-9 -over: - defw $+2 - ldw hl,(sp+2) ;/ - jhpush ;/ -; -; - defb 84h ; DROP - defc 'DROP' - defw over-7 -drop: - defw $+2 - inc sp - inc sp ;/ faster on z280 than dummy pop - jnext -; -; - defb 84h ; SWAP - defc 'SWAP' - defw drop-7 -swap: - defw $+2 - pop hl - ex (sp),hl - jhpush -; -; - defb 83h ; DUP - defc 'DUP' - defw swap-7 -dup: - defw $+2 - ldw hl,(sp+0) ;/ - jhpush -; -; - defb 84h ;/ TUCK ( n1 n2 --- n2 n1 n2) - defc 'TUCK' - defw dup-6 -tuck: - defw $+2 - pop hl ;/ hl <-- s1 - pop de ;/ de <-- s2 - push hl ;/ s3 <-- hl - jp dpush -; -; - defb 83h ;/ NIP ( n1 n2 --- n2) - defc 'NIP' - defw tuck-7 -nip: - defw $+2 - pop hl ; hl <-- s1 - ldw (sp+0),hl ;/ s1 <-- hl - jnext -; -; - defb 84h ;/ -ROT ( n1 n2 n3 --- n3 n1 n2) - defc '-ROT' - defw nip-6 -mrot: - defw $+2 - pop hl - pop de - ex (sp),hl - ex de,hl - jp dpush -; -; - defb 85h ;/ CSWAP ( n1 --- n1, bytes swapped) - defc 'CSWAP' - defw mrot-7 -cswap: - defw $+2 - pop hl - ex h,l ;/ - jhpush -; -; - defb 84h ;/ PICK ( nn...n0 k --- nn..n0 nk) - defc 'PICK' - defw cswap-8 -pick: - defw $+2 - pop hl ; hl <-- depth - add hl,hl ; adjust to word size - add hl,sp ; offset into stack - push (hl) ;/ - jnext -; -; - defb 84h ; 2DUP - defc '2DUP' - defw pick-7 -tdup: - defw $+2 - pop hl - pop de - push de - push hl - jp dpush -; -; - defb 82h ; +! - defc '+!' - defw tdup-7 -pstor: - defw $+2 - pop hl ; hl --> variable - pop de ; de <-- number - ld a,(hl) - add a,e - ld (hl),a - inc hl - ld a,(hl) - adc a,d - ld (hl),a ; (hl) += number - jnext -; -; - defb 86h ; TOGGLE - defc 'TOGGLE' - defw pstor-5 -toggl: - defw $+2 - pop de ; e <-- bit pattern - pop hl ; hl --> address - ld a,(hl) - xor e - ld (hl),a - jnext -; -; - defb 81h ; @ - defc '@' - defw toggl-9 -at: - defw $+2 - pop hl - push (hl) ;/ - jnext -; -; - defb 82h ; C@ - defc 'C@' - defw at-4 -cat: - defw $+2 - pop hl - ld l,(hl) - ld h,0 - jhpush -; -; - defb 82h ; 2@ - defc '2@' - defw cat-5 -tat: - defw $+2 - pop hl ; hl --> address - ldw de,(hl) ;/ de <-- d.hw - inc hl - inc hl ; hl --> d.lw - push (hl) ;/ s2 <-- d.lw - push de ;/ s1 <-- d.hw - jnext -; -; - defb 81h ; ! - defc '!' - defw tat-5 -store: - defw $+2 - pop hl ; hl --> address - pop (hl) ;/ - jnext -; -; - defb 82h ; C! - defc 'C!' - defw store-4 -cstor: - defw $+2 - pop hl ; hl --> address - pop de ; e <-- char - ld (hl),e - jnext -; -; - defb 82h ; 2! - defc '2!' - defw cstor-5 -tstor: - defw $+2 - pop hl ; hl --> address - pop (hl) ;/ store d.hw - inc hl - inc hl - pop (hl) ;/ store d.lw - jnext -; -; - defb 0c1h ; : - defc ':' - defw tstor-5 -colon: - defw docol - defw qexec - defw scsp - defw curr - defw at - defw cont - defw store - defw creat - defw rbrac - defw pscod -docol: - ld hl,(rpp) - dec hl - dec hl - ldw (hl),bc ;/ save return address - ld (rpp),hl - inc de - ld c,e - ld b,d - jnext -; -; - defb 0c1h ; ; - defc ';' - defw colon-4 -semi: - defw docol - defw qcsp - defw comp - defw semis - defw smudg - defw lbrac - defw semis -; -; - defb 84h ; NOOP - defc 'NOOP' - defw semi-4 -noop: - defw docol - defw semis -; -; - defb 88h ; CONSTANT - defc 'CONSTANT' - defw noop-7 -con: - defw docol - defw creat - defw smudg - defw comma - defw pscod -docon: - inc de - ex de,hl - push (hl) ;/ - jnext -; -; - defb 88h ; VARIABLE - defc 'VARIABLE' - defw con-0bh -var: - defw docol - defw con - defw pscod -dovar: - inc de - push de - jnext -; -; - defb 84h ; USER - defc 'USER' - defw var-0bh -user: - defw docol - defw con - defw pscod -douse: - inc de - ex de,hl - ld l,(hl) ;/ - ld h,0 ;/ - addw hl,(up) ;/ - jhpush -; -; - defb 81h ; 0 - defc '0' - defw user-7 -zero: - defw $+2 ;/ - push 0000h ;/ - jnext -; -; - defb 81h ; 1 - defc '1' - defw zero-4 -one: - defw $+2 ;/ - push 0001h ;/ - jnext -; -; - defb 81h ; 2 - defc '2' - defw one-4 -two: - defw $+2 ;/ - push 0002h ;/ - jnext -; -; - defb 81h ; 3 - defc '3' - defw two-4 -three: - defw $+2 ;/ - push 0003h ;/ - jnext -; -; - defb 82h ; BL - defc 'BL' - defw three-4 -bl: - defw docon - defw 20h -; -; - defb 83h ; C/L - defc 'C/L' - defw bl-5 -csll: - defw docon - defw 64 -; -; - defb 85h ; FIRST - defc 'FIRST' - defw csll-6 -first: - defw docon - defw 0 ;/ set by CLD -; -; - defb 85h ; LIMIT - defc 'LIMIT' - defw first-8 -limit: - defw docon - defw 0 ;/ set by CLD -; -; - defb 85h ; B/BUF - defc 'B/BUF' - defw limit-8 -bbuf: - defw docon - defw kbbuf -; -; - defb 85h ; B/SCR - defc 'B/SCR' - defw bbuf-8 -bscr: - defw docon - defw 400h/kbbuf -; -; - defb 87h ; +ORIGIN - defc '+ORIGIN' - defw bscr-8 -porig: - defw docol - defw lit - defw orig - defw plus - defw semis -; -; USER VARIABLES -; - defb 82h ; S0 - defc 'S0' - defw porig-0ah -szero: - defw douse - defw 6 -; -; - defb 82h ; R0 - defc 'R0' - defw szero-5 -rzero: - defw douse - defw 8 -; -; - defb 83h ; TIB - defc 'TIB' - defw rzero-5 -tib: - defw douse - defb 0ah -; -; - defb 85h ; WIDTH - defc 'WIDTH' - defw tib-6 -width: - defw douse - defb 0ch -; -; - defb 87h ; WARNING - defc 'WARNING' - defw width-8 -warn: - defw douse - defb 0eh -; -; - defb 85h ; FENCE - defc 'FENCE' - defw warn-0ah -fence: - defw douse - defb 10h -; -; - defb 82h ; DP - defc 'DP' - defw fence-8 -dp: - defw douse - defb 12h -; -; - defb 88h ; VOC-LINK - defc 'VOC-LINK' - defw dp-5 -vocl: - defw douse - defw 14h -; -; - defb 83h ; BLK - defc 'BLK' - defw vocl-0bh -blk: - defw douse - defb 16h -; -; - defb 82h ; IN - defc 'IN' - defw blk-6 -inn: - defw douse - defb 18h -; -; - defb 83h ; OUT - defc 'OUT' - defw inn-5 -outt: - defw douse - defb 1ah -; -; - defb 83h ; SCR - defc 'SCR' - defw outt-6 -scr: - defw douse - defb 1ch -; -; - defb 86h ; OFFSET - defc 'OFFSET' - defw scr-6 -ofset: - defw douse - defb 1eh -; -; - defb 87h ; CONTEXT - defc 'CONTEXT' - defw ofset-9 -cont: - defw douse - defb 20h -; -; - defb 87h ; CURRENT - defc 'CURRENT' - defw cont-0ah -curr: - defw douse - defb 22h -; -; - defb 85h ; STATE - defc 'STATE' - defw curr-0ah -state: - defw douse - defb 24h -; -; - defb 84h ; BASE - defc 'BASE' - defw state-8 -base: - defw douse - defb 26h -; -; - defb 83h ; DPL - defc 'DPL' - defw base-7 -dpl: - defw douse - defb 28h -; -; - defb 83h ; FLD - defc 'FLD' - defw dpl-6 -fld: - defw douse - defb 2ah -; -; - defb 83h ; CSP - defc 'CSP' - defw fld-6 -cspp: - defw douse - defb 2ch -; - - defb 82h ; R# - defc 'R#' - defw cspp-6 -rnum: - defw douse - defb 2eh -; - - defb 83h ; HLD - defc 'HLD' - defw rnum-5 -hld: - defw douse - defw 30h -; -; END OF USER VARIABLES -; - defb 82h ; 1+ - defc '1+' - defw hld-6 -onep: - defw $+2 ;/ - pop hl ;/ - inc hl ;/ - jhpush ;/ -; -; - defb 82h ; 2+ - defc '2+' - defw onep-5 -twop: - defw $+2 ;/ - pop hl ;/ - inc hl ;/ - inc hl ;/ - jhpush ;/ -; -; - defb 82h ;/ 1- - defc '1-' ;/ - defw twop-5 ;/ -onemin: - defw $+2 ;/ - pop hl ;/ - dec hl ;/ - jhpush ;/ -; -; - defb 82h ;/ 2- - defc '2-' ;/ - defw onemin-5 ;/ -twomin: - defw $+2 ;/ - pop hl ;/ - dec hl ;/ - dec hl ;/ - jhpush ;/ -; -; - defb 82h ;/ 2* - defc '2*' ;/ - defw twomin-5 ;/ -twosta: - defw $+2 ;/ - pop hl ;/ - add hl,hl ;/ asl hl - jhpush ;/ -; -; - defb 82h ;/ 2/ - defc '2/' ;/ - defw twosta-5 ;/ -twosla: - defw $+2 ;/ - pop hl ;/ - bit 7,h ;/ negative? - jr z,twosl1 ;/ no - inc hl ;/ yes, add 1 -twosl1: - sra h ;/ - rr l ;/ asr hl - jhpush ;/ -; -; - defb 84h ; HERE - defc 'HERE' - defw twosla-5 -here: - defw docol - defw dp - defw at - defw semis -; -; - defb 85h ; ALLOT - defc 'ALLOT' - defw here-7 -allot: - defw docol - defw dp - defw pstor - defw semis -; -; - defb 81h ; , - defc ',' - defw allot-8 -comma: - defw docol - defw here - defw store - defw two - defw allot - defw semis -; - - defb 82h ; C, - defc 'C,' - defw comma-4 -ccomm: - defw docol - defw here - defw cstor - defw one - defw allot - defw semis -; -; - defb 81h ; - - defc '-' - defw ccomm-5 -subb: - defw $+2 - pop de - pop hl - subw hl,de ;/ - jhpush -; -; - defb 81h ; = - defc '=' - defw subb-4 -equal: - defw $+2 ;/ - pop de ;/ - pop hl ;/ - subw hl,de ;/ - ld hl,0 ; hl <-- false - jr nz,equal1 - inc l ;/ hl <-- true -equal1: - jhpush -; -; - defb 81h ; < - defc '<' - defw equal-4 -less: - defw $+2 - pop de - pop hl ; hl de < - ld a,d - xor h ; one operand negative? - jp m,less1 ; yes, determine which - subw hl,de ;/ -less1: - bit 7,h ;/ h negative? - ld hl,0 ; hl <-- false - jr z,less2 - inc l ;/ hl <-- true -less2: - jhpush -; -; - defb 82h ; U< - defc 'U<' - defw less-4 -uless: - defw $+2 - pop de - pop hl ;/ hl de U< - subw hl,de ;/ - ld hl,0 ; hl <-- false - rl l ;/ bit 0 <-- carry -uless1: - jhpush -; -; - defb 81h ; > - defc '>' - defw uless-5 -great: - defw $+2 - pop hl ;/ - pop de ;/ hl de > (= de hl < ) - ld a,d - xor h ; one operand negative? - jp m,great1 ; yes, determine which - subw hl,de ;/ -great1: - bit 7,h ;/ h negative? - ld hl,0 ; hl <-- false - jr z,great2 - inc l ;/ hl <-- true -great2: - jhpush -; -; - defb 83h ; ROT ( n1 n2 n3 --- n2 n3 n1) - defc 'ROT' - defw great-4 -rot: - defw $+2 - pop de ; de <-- n3 - pop hl ; hl <-- n2 - ex (sp),hl ; s1 <-- n2, hl <-- n1 - jp dpush ; s2 <-- n3, s3 <-- n1 -; -; - defb 85h ; SPACE - defc 'SPACE' - defw rot-6 -space: - defw docol - defw bl - defw emit - defw semis -; -; - defb 84h ; -DUP - defc '-DUP' - defw space-8 -ddup: - defw $+2 ;/ - ldw hl,(sp+0) ;/ - ld a,h ;/ - or l ;/ hl = 0? - jr z,ddup1 ;/ yes, don't dup - push hl ;/ -ddup1: - jnext -; -; - defb 88h ; TRAVERSE - defc 'TRAVERSE' - defw ddup-7 -trav: - defw docol - defw swap -trav1: - defw over ; begin - defw plus - defw lit - defw 7fh - defw over - defw cat - defw less - defw zbran ; until - defw trav1-$ - defw swap - defw drop - defw semis -; -; - defb 86h ; LATEST - defc 'LATEST' - defw trav-0bh -lates: - defw docol - defw curr - defw at - defw at - defw semis -; -; - defb 83h ; LFA - defc 'LFA' - defw lates-9 -lfa: - defw $+2 - pop hl ;/ hl <-- pfa - subw hl,4 ;/ - jhpush ;/ s1 <-- lfa -; -; - defb 83h ; CFA - defc 'CFA' - defw lfa-6 -cfa: - defw docol - defw twomin ;/ - defw semis -; -; - defb 83h ; NFA - defc 'NFA' - defw cfa-6 -nfa: - defw docol - defw lit - defw 5 - defw subb - defw lit - defw -1 - defw trav - defw semis -; -; - defb 83h ; PFA - defc 'PFA' - defw nfa-6 -pfa: - defw docol - defw one - defw trav - defw lit - defw 5 - defw plus - defw semis -; -; - defb 84h ; !CSP - defc '!CSP' - defw pfa-6 -scsp: - defw docol - defw spat - defw cspp - defw store - defw semis -; -; - defb 86h ; ?ERROR - defc '?ERROR' - defw scsp-7 -qerr: - defw docol - defw swap - defw zbran ; if - defw qerr1-$ - defw error - defw bran ; else - defw qerr2-$ -qerr1: - defw drop ; endif -qerr2: - defw semis -; -; - defb 85h ; ?COMP - defc '?COMP' - defw qerr-9 -qcomp: - defw docol - defw state - defw at - defw zequ - defw lit - defw 11h - defw qerr - defw semis -; -; - defb 85h ; ?EXEC - defc '?EXEC' - defw qcomp-8 -qexec: - defw docol - defw state - defw at - defw lit - defw 12h - defw qerr - defw semis -; -; - defb 86h ; ?PAIRS - defc '?PAIRS' - defw qexec-8 -qpair: - defw docol - defw subb - defw lit - defw 13h - defw qerr - defw semis -; -; - defb 84h ; ?CSP - defc '?CSP' - defw qpair-9 -qcsp: - defw docol - defw spat - defw cspp - defw at - defw subb - defw lit - defw 14h - defw qerr - defw semis -; -; - defb 88h ; ?LOADING - defc '?LOADING' - defw qcsp-7 -qload: - defw docol - defw blk - defw at - defw zequ - defw lit - defw 16h - defw qerr - defw semis -; -; - defb 87h ; COMPILE - defc 'COMPILE' - defw qload-0bh -comp: - defw docol - defw qcomp - defw fromr - defw dup - defw twop - defw tor - defw at - defw comma - defw semis -; -; - defb 0c1h ; [ - defc '[' - defw comp-0ah -lbrac: - defw docol - defw zero - defw state - defw store - defw semis -; -; - defb 81h ; ] - defc ']' - defw lbrac-4 -rbrac: - defw docol - defw lit,0c0h - defw state,store - defw semis -; -; - defb 86h ; SMUDGE - defc 'SMUDGE' - defw rbrac-4 -smudg: - defw docol - defw lates - defw lit - defw 20h - defw toggl - defw semis -; -; - defb 83h ; HEX - defc 'HEX' - defw smudg-9 -hex: - defw docol - defw lit - defw 10h - defw base - defw store - defw semis -; -; - defb 87h ; DECIMAL - defc 'DECIMAL' - defw hex-6 -dec: - defw docol - defw lit - defw 0ah - defw base - defw store - defw semis -; -; - defb 87h ; (;CODE) - defc '(;CODE)' - defw dec-0ah -pscod: - defw docol - defw fromr - defw lates - defw pfa - defw cfa - defw store - defw semis -; -; - defb 0c5h ; ;CODE - defc ';CODE' - defw pscod-0ah -semic: - defw docol - defw qcsp - defw comp - defw pscod - defw lbrac -semi1: - defw noop ; assembler - defw semis -; -; - defb 87h ; - defc 'DOES>' - defw build-0ah -does: - defw docol - defw fromr - defw lates - defw pfa - defw store - defw pscod -dodoe: - ld hl,(rpp) - dec hl - dec hl - ldw (hl),bc ;/ - ld (rpp),hl - inc de - ex de,hl - ldw bc,(hl) ;/ - inc hl - inc hl - jhpush -; -; - defb 85h ; COUNT - defc 'COUNT' - defw does-8 -count: - defw docol - defw dup - defw onep - defw swap - defw cat - defw semis -; -; - defb 84h ; TYPE - defc 'TYPE' - defw count-8 -type: - defw docol - defw ddup - defw zbran ; if - defw type1-$ - defw over - defw plus - defw swap - defw xdo ; do -type2: - defw ido - defw cat - defw emit - defw xloop ; loop - defw type2-$ - defw bran ; else - defw type3-$ -type1: - defw drop ; endif -type3: - defw semis -; -; - defb 89h ; -TRAILING - defc '-TRAILING' - defw type-7 -dtrai: - defw docol - defw dup - defw zero - defw xdo ; do -dtra1: - defw tdup ;/ - defw plus - defw onemin ;/ - defw cat - defw bl - defw subb - defw zbran ; if - defw dtra2-$ - defw leave - defw bran ; else - defw dtra3-$ -dtra2: - defw onemin ;/ -dtra3: - defw xloop ; loop - defw dtra1-$ - defw semis -; -; - defb 84h ; (.") - defc '(.")' - defw dtrai-0ch -pdotq: - defw docol - defw rr - defw count - defw dup - defw onep - defw fromr - defw plus - defw tor - defw type - defw semis -; -; - defb 0c2h ; ." - defc '."' - defw pdotq-7 -dotq: - defw docol - defw lit - defw 22h - defw state - defw at - defw zbran ; if - defw dotq1-$ - defw comp - defw pdotq - defw word - defw here - defw cat - defw onep - defw allot - defw bran ; else - defw dotq2-$ -dotq1: - defw word - defw here - defw count - defw type ; endif -dotq2: - defw semis -; -; - defb 86h ; EXPECT - defc 'EXPECT' - defw dotq-5 -expec: - defw docol - defw over - defw plus - defw over - defw xdo ; do -expe1: - defw key - defw dup - defw lit - defw 0eh - defw porig - defw at - defw equal - defw zbran ; if - defw expe2-$ - defw drop - defw dup - defw ido - defw equal - defw dup - defw fromr - defw twomin ;/ - defw plus - defw tor - defw zbran ; if - defw expe6-$ - defw lit - defw bell - defw bran ; else - defw expe7-$ -expe6: - defw lit - defw bsout ; endif -expe7: - defw bran ; else - defw expe3-$ -expe2: - defw dup - defw lit - defw acr ;/ - defw equal - defw zbran ; if - defw expe4-$ - defw leave - defw drop - defw bl - defw zero - defw bran ; else - defw expe5-$ -expe4: - defw dup ; endif -expe5: - defw ido - defw cstor - defw zero - defw ido - defw onep - defw store ; endif -expe3: - defw emit - defw xloop ; loop - defw expe1-$ - defw drop - defw semis -; -; - defb 85h ; QUERY - defc 'QUERY' - defw expec-9 -query: - defw docol - defw tib - defw at - defw lit - defw 50h - defw expec - defw zero - defw inn - defw store - defw semis -; -; - defb 0c1h ; NULL - defb 80h - defw query-8 -null: - defw docol - defw blk - defw at - defw zbran ; if - defw null1-$ - defw one - defw blk - defw pstor - defw zero - defw inn - defw store - defw blk - defw at - defw bscr - defw onemin ;/ - defw andd - defw zequ - defw zbran ; if - defw null2-$ - defw qexec - defw fromr - defw drop ; endif -null2: - defw bran ; else - defw null3-$ -null1: - defw fromr - defw drop ; endif -null3: - defw semis -; - defb 84h ; FILL - defc 'FILL' - defw null-4 -fill: - defw $+2 - exx ;/ save ip - pop de ;/ e <-- byte - pop bc ; bc <-- quantity - pop hl ;/ hl <-- address -fill1: - ld a,b - or c ; qty == 0? - jr z,fill2 ; yes, nothing (more) to fill - ld (hl),e ;/ (hl) <-- byte - inc hl ; inc pointer - dec bc ; dec counter - jp fill1 ;/ -fill2: - exx ;/ restore ip - jnext -; -; - defb 85h ; ERASE - defc 'ERASE' - defw fill-7 -erasee: - defw docol - defw zero - defw fill - defw semis -; -; - defb 86h ; BLANKS - defc 'BLANKS' - defw erasee-8 -blank: - defw docol - defw bl - defw fill - defw semis -; -; - defb 84h ; HOLD - defc 'HOLD' - defw blank-9 -hold: - defw docol - defw lit - defw -1 - defw hld - defw pstor - defw hld - defw at - defw cstor - defw semis -; -; - defb 83h ; PAD - defc 'PAD' - defw hold-7 -pad: - defw docol - defw here - defw lit - defw 44h - defw plus - defw semis -; -; - defb 84h ; WORD - defc 'WORD' - defw pad-6 -word: - defw docol - defw blk - defw at - defw zbran ; if - defw word1-$ - defw blk - defw at - defw block - defw bran ; else - defw word2-$ -word1: - defw tib - defw at ; endif -word2: - defw inn - defw at - defw plus - defw swap - defw encl - defw here - defw lit - defw 22h - defw blank - defw inn - defw pstor - defw over - defw subb - defw tor - defw rr - defw here - defw cstor - defw plus - defw here - defw onep - defw fromr - defw cmove - defw semis -; -; - defb 88h ; (NUMBER) - defc '(NUMBER)' - defw word-7 -pnumb: - defw docol -pnum1: - defw onep ; begin - defw dup - defw tor - defw cat - defw base - defw at - defw digit - defw zbran ; while - defw pnum2-$ - defw swap - defw base - defw at - defw ustar - defw drop - defw rot - defw base - defw at - defw ustar - defw dplus - defw dpl - defw at - defw onep - defw zbran ; if - defw pnum3-$ - defw one - defw dpl - defw pstor ; endif -pnum3: - defw fromr - defw bran ; repeat - defw pnum1-$ -pnum2: - defw fromr - defw semis -; -; - defb 86h ; NUMBER - defc 'NUMBER' - defw pnumb-0bh -numb: - defw docol - defw zero - defw zero - defw rot - defw dup - defw onep - defw cat - defw lit - defw 2dh - defw equal - defw dup - defw tor - defw plus - defw lit - defw -1 -numb1: - defw dpl ; begin - defw store - defw pnumb - defw dup - defw cat - defw bl - defw subb - defw zbran ; while - defw numb2-$ - defw dup - defw cat - defw lit - defw 2eh - defw subb - defw zero - defw qerr - defw zero - defw bran ; repeat - defw numb1-$ -numb2: - defw drop - defw fromr - defw zbran ; if - defw numb3-$ - defw dminu ; endif -numb3: - defw semis -; -; - defb 85h ; -FIND (0-3) SUCCESS - defc '-FIND' ; (0-1) FAILURE - defw numb-9 -dfind: - defw docol - defw bl - defw word - defw here - defw cont - defw at - defw at - defw pfind - defw dup - defw zequ - defw zbran ; if - defw dfin1-$ - defw drop - defw here - defw lates - defw pfind ; endif -dfin1: - defw semis -; -; - defb 87h ; (ABORT) - defc '(ABORT)' - defw dfind-8 -pabor: - defw docol - defw abort - defw semis -; - defb 85h ; ERROR - defc 'ERROR' - defw pabor-0ah -error: - defw docol - defw warn - defw at - defw zless - defw zbran ; if - defw erro1-$ - defw pabor ; endif -erro1: - defw here - defw count - defw type - defw pdotq - defb 2 - db '? ' - defw mess - defw spsto -; CHANGE FROM fig MODEL -; defw inn,at,blk,at - defw blk,at - defw ddup - defw zbran,erro2-$ ; if - defw inn,at - defw swap ; endif -erro2: - defw quit -; -; - defb 83h ; ID. - defc 'ID.' - defw error-8 -iddot: - defw docol - defw pad - defw lit - defw 20h - defw blank ;/ - defw dup - defw pfa - defw lfa - defw over - defw subb - defw dup ;/ change frm MODEL - defw tor ;/ to suppress BIT 7 - defw pad - defw swap - defw cmove - defw pad - defw fromr ;/ for terminals - defw pad ;/ with an 8 bit - defw plus ;/ ASCII character set. - defw onemin ;/ - defw dup ;/ - defw at ;/ - defw lit ;/ - defw 7fh ;/ - defw andd ;/ - defw swap ;/ - defw store ;/ - defw count - defw lit - defw 1fh ; WIDTH - defw andd - defw type - defw space - defw semis -; - defb 86h ; CREATE - defc 'CREATE' - defw iddot-6 -creat: - defw docol - defw dfind - defw zbran ; if - defw crea1-$ - defw drop - defw nfa - defw iddot - defw lit - defw 4 - defw mess - defw space ; endif -crea1: - defw here - defw dup - defw cat - defw width - defw at - defw min - defw onep - defw allot - defw dup - defw lit - defw 0a0h - defw toggl - defw here - defw onemin - defw lit - defw 80h - defw toggl - defw lates - defw comma - defw curr - defw at - defw store - defw here - defw twop - defw comma - defw semis -; -; - defb 0c9h ; [COMPILE] - defc '[COMPILE]' - defw creat-9 -bcomp: - defw docol - defw dfind - defw zequ - defw zero - defw qerr - defw drop - defw cfa - defw comma - defw semis -; -; - defb 0c7h ; LITERAL - defc 'LITERAL' - defw bcomp-0ch -liter: - defw docol - defw state - defw at - defw zbran ; if - defw lite1-$ - defw comp - defw lit - defw comma ; endif -lite1: - defw semis -; -; - defb 0c8h ; DLITERAL - defc 'DLITERAL' - defw liter-0ah -dlite: - defw docol - defw state - defw at - defw zbran ; if - defw dlit1-$ - defw swap - defw liter - defw liter ; endif -dlit1: - defw semis -; -; - defb 86h ; ?STACK - defc '?STACK' - defw dlite-0bh -qstac: - defw docol - defw spat - defw szero - defw at - defw swap - defw uless - defw one - defw qerr - defw spat - defw here - defw lit - defw 80h - defw plus - defw uless - defw lit - defw 7 - defw qerr - defw semis -; -; - defb 89h ; INTERPRET - defc 'INTERPRET' - defw qstac-9 -inter: - defw docol -inte1: - defw dfind ; begin - defw zbran ; if - defw inte2-$ - defw state - defw at - defw less - defw zbran ; if - defw inte3-$ - defw cfa - defw comma - defw bran ; else - defw inte4-$ -inte3: - defw cfa - defw exec ; endif -inte4: - defw qstac - defw bran ; else - defw inte5-$ -inte2: - defw here - defw numb - defw dpl - defw at - defw onep - defw zbran ; if - defw inte6-$ - defw dlite - defw bran ; else - defw inte7-$ -inte6: - defw drop - defw liter ; endif -inte7: - defw qstac ; endif -inte5: - defw bran ; again - defw inte1-$ -; -; - defb 89h ; IMMEDIATE - defc 'IMMEDIATE' - defw inter-0ch -immed: - defw docol - defw lates - defw lit - defw 40h - defw toggl - defw semis -; -; - defb 8ah ; VOCABULARY - defc 'VOCABULARY' - defw immed-0ch -vocab: - defw docol - defw build - defw lit - defw 0a081h - defw comma - defw curr - defw at - defw cfa - defw comma - defw here - defw vocl - defw at - defw comma - defw vocl - defw store - defw does -dovoc: - defw twop - defw cont - defw store - defw semis -; -; - defb 0c5h ; FORTH - defc 'FORTH' - defw vocab-0dh -forth: - defw dodoe - defw dovoc - defw 0a081h - defw task-7 ; cold start value only -; changed aech time a def is appended -; to the FORTH vocabulary - defw 0 ; end of vocabulary list -; -; - defb 8bh ; DEFINITIONS - defc 'DEFINITIONS' - defw forth-8 -defin: - defw docol - defw cont - defw at - defw curr - defw store - defw semis -; -; - defb 0c1h ; ( - defc '(' - defw defin-0eh -paren: - defw docol - defw lit - defw 29h - defw word - defw semis -; -; - defb 84h ; QUIT - defc 'QUIT' - defw paren-4 -quit: - defw docol - defw zero - defw blk - defw store - defw lbrac -quit1: - defw rpsto ; begin - defw cr - defw query - defw inter - defw state - defw at - defw zequ - defw zbran ; if - defw quit2-$ - defw pdotq - defb 2 - db 'ok' ; endif -quit2: - defw bran ; again - defw quit1-$ -; -; - defb 85h ; ABORT - defc 'ABORT' - defw quit-7 -abort: - defw docol - defw spsto - defw dec - defw qstac - defw cr - defw dotcpu - defw pdotq - defb 0eh ; count of chrs to follow - db 'fig-FORTH ' - defb figrel+30h,adot,figrev+30h,usrver - defw forth - defw defin - defw quit -; -; -wrm: ld bc,wrm1 - jnext -wrm1: defw warm -; -; - defb 84h ; WARM - defc 'WARM' - defw abort-8 -warm: - defw docol - defw mtbuf - defw abort -; -; -cld: - ld hl,(bdoss+1) ;/ - ld l,0 ;/ hl <-- fbase - ld (limit+2),hl ;/ set limit - ld de,bufsiz ;/ de <-- total disc buffer size - subw hl,de ;/ hl <-- addr. of 1st disc buffer - ld (first+2),hl ;/ set FIRST - ld (use+2),hl ;/ set USE - ld (prev+2),hl ;/ set PREV - ld (buf1),hl ;/ - ld de,us ;/ de <-- user variable space - subw hl,de ;/ hl <-- initr0 - ld (upinit),hl ;/ - ld (r0init),hl ;/ - ld (up),hl ;/ - ld (rpp),hl ;/ - ld de,rts ;/ de <-- rtn stack & term. buf space - subw hl,de ;/ hl <-- inits0 - ld (s0init),hl ;/ - ld (tibini),hl ;/ - ld sp,hl ;/ - ld bc,cld1 - ld ix,next ; pointer to next - ld iy,hpush ; pointer to hpush - jnext -; -; -cld1: defw cold -; - defb 84h ; COLD - defc 'COLD' - defw warm-7 -cold: - defw docol - defw mtbuf - defw one,recadr ; AvdH - defw store - defw lit,buf1 - defw at ;/ - defw use,store - defw lit,buf1 - defw at ;/ - defw prev,store - defw drzer - defw zero ;/ - defw lit,eprint - defw cstor ;/ -; - defw lit - defw orig+12h - defw lit - defw up - defw at - defw lit - defw 6 - defw plus - defw lit - defw 10h - defw cmove - defw lit - defw orig+0ch - defw at - defw lit - defw forth+6 - defw store - defw fcb ;/A - defw lit,opnfil ;/A open mass storage - defw bdos ;/A - defw lit,0ffh ;/A - defw equal ;/A file present? - defw zbran,cld2-$ ;/A - defw zero ;/A - defw warn,store ;/A - defw cr,pdotq ;/A - defb 7 ;/A - db 'No file' ;/A -cld2: - defw abort -; -; - defb 84h ; S->D - defc 'S->D' - defw cold-7 -stod: defw $+2 - pop hl ;/ - exts hl ;/ de <-- h(7) - ex de,hl ;/ - jp dpush ; ( n1 -- d1L d1H) -; -; - defb 82h ; +- - defc '+-' - defw STOD-7 -pm: - defw docol - defw zless - defw zbran ; if - defw pm1-$ - defw minus ; endif -pm1: - defw semis -; -; - defb 83h ; D+- - defc 'D+-' - defw pm-5 -dpm: - defw docol - defw zless - defw zbran ; if - defw dpm1-$ - defw dminu ; endif -dpm1: - defw semis -; -; - defb 83h ; ABS - defc 'ABS' - defw dpm-6 -abs: - defw docol - defw dup - defw pm - defw semis -; -; - defb 84h ; DABS - defc 'DABS' - defw abs-6 -dabs: - defw docol - defw dup - defw dpm - defw semis -; -; - defb 83h ; MIN - defc 'MIN' - defw dabs-7 -min: - defw docol - defw tdup - defw great - defw zbran ; if - defw min1-$ - defw swap ; endif -min1: - defw drop - defw semis -; -; - defb 83h ; MAX - defc 'MAX' - defw min-6 -max: defw docol - defw tdup - defw less - defw zbran ; if - defw max1-$ - defw swap ; endif -max1: - defw drop - defw semis -; -; - defb 82h ; M* ( n1 n2 --- d) - defc 'M*' - defw max-6 -mstar: - defw $+2 ;/ - pop de ; de <-- multiplicator - pop hl ; hl <-- multiplicant - multw hl,de ;/ dehl <-- hl * de - ex de,hl ;/ - jp dpush ;/ ( n1 n2 --- d1l d1h) -; -; - defb 82h ;/ M/ ( d n1 --- nrem nquot) - defc 'M/' - defw mstar-5 -mslas: - defw $+2 ; ( d n1 --- n2 n3) - exx ; save ip - pop hl ; divisor - ld a,h - and 80h ; filter sign - jr z,mslas1 ; positive - neg hl ; make positive -mslas1: - ld b,h - ld c,l ; bc <-- divisor - pop hl ; dividend.hw - pop de ; dividend.lw - bit 7,h ; negative? - jr z,mslas2 ; no - inc a ; dividend sign flag - push hl - ld hl,0 - subw hl,de ; neg dividend.lw - pop de ; dividend.hw - push hl - ld hl,0 - sbc hl,de ; neg dividend.hw - pop de ; dividend.lw -mslas2: - cpw hl,bc ; dividend.hw >= divisor - jr c,mslas3 ; no overflow, continue - ld hl,0ffffh - ld d,h - ld e,l ; set rem & quot to max. - jr mslas5 -; -mslas3: - ex de,hl ; dehl <-- dividend.hw,lw - divuw dehl,bc ; de <-- remainder, hl <-- quotient - ex de,hl ; hl <-- remainder - bit 0,a ; was dividend negative - jr z,mslas4 ; no - neg hl ;/ yes, negate remainder -mslas4: - ex de,hl ; hl <-- quotient - or a - jr z,mslas5 ; neither operand negative - cp 81h ; both operands negative? - jr z,mslas5 ; yes, quotient stays positive - neg hl ;/ no, negate quotient -mslas5: - push de ; remainder - push hl ; quotient - exx ; restore ip - jnext -; -; - defb 81h ; * ( n1 n2 --- nproduct) - defc '*' - defw mslas-5 -star: - defw $+2 - pop de - pop hl - multw hl,de ;/ dehl <-- product - jhpush -; -; - defb 84h ; /MOD ( n1 n2 --- nrem nquot) - defc '/MOD' - defw star-4 -slmod: - defw $+2 - exx ;/ save ip - pop bc ;/ divisor - pop hl ; dividend - ld a,b - or c ;/ div by 0? - jr nz,slmod1 ;/ no, continue - ld de,0ffffh - ld h,d - ld l,e ;/ set remainder & quotient to max. - jr slmod3 -slmod1: - cpw hl,8000h ;/ special case -32768 -1 / - jr nz,slmod2 ;/ continue - ld a,b - cp 0ffh - jr nz,slmod2 - cp c ;/ lo byte also 0ffh? - jr nz,slmod2 ;/ no, go & divide - ld de,0 ;/ remainder - jr slmod3 ;/ exit with dividend unchanged -slmod2: - exts hl ;/ de <-- dividend.hw - divw dehl,bc ;/ de <-- remainder, hl <-- quotient -slmod3: - push de - push hl - exx ;/ restore ip - jnext -; -; - defb 81h ; / - defc '/' - defw slmod-7 -slash: - defw $+2 - exx ;/ save ip - pop bc ;/ divisor - pop hl ; dividend - ld a,b - or c ;/ division by 0? - jr nz,slash1 ;/ no, continue - ld hl,0ffffh ;/ set quotient to max. - jr slash3 -slash1: - cpw hl,8000h ;/ special case -32768 -1 / - jr nz,slash2 ;/ dividend not -32768 - ld a,b - cp 0ffh - jr nz,slash2 ;/ divisor not -1 - cp c - jr z,slash3 ;/ return with dividend unchanged -slash2: - exts hl ;/ de <-- dividend.hw - divw dehl,bc ;/ hl <-- quotient -slash3: - push hl ;/ quotient - exx ;/ restore ip - jnext -; -; - defb 83h ;/ MOD - defc 'MOD' - defw slash-4 -modd: - defw $+2 - exx ; save ip - pop bc ; divisor - pop hl ; dividend - ld a,b - or c ; division by 0? - jr nz,modd1 ; no, continue - ld de,0ffffh ; set remainder to max - jr modd3 -modd1: - cpw hl,8000h ;/ special case -32768 -1 / - jr nz,modd2 ; dividend not -32768 - ld a,b - cp 0ffh - jr nz,modd2 ; divisor not -1 - cp c - jr nz,modd2 ; go & divide - ld de,0 ; remainder - jr modd3 -modd2: - exts hl ; de <-- dividend.hw - divw dehl,bc ; de <-- remainder -modd3: - push de ; remainder - exx ; restore ip - jnext -; -; - defb 85h ;/ */MOD - defc '*/MOD' - defw modd-6 -ssmod: - defw $+2 - exx ; save ip - pop hl ; divisor - ld a,h - and 80h ; filter sign - jr z,ssmod1 ; positive - neg hl ; make positive -ssmod1: - ld b,h - ld c,l ; bc <-- divisor - pop hl ; multipicator - pop de ; multiplicant - ex af,af' ; save sign flag - multw hl,de ; dehl <-- product (= dividend) - ex af,af' ; restore sign flag - ex de,hl ; de <-- dividend.lw - bit 7,h ; dividend negative? - jr z,ssmod2 ; no - inc a ; dividend sign flag - push hl - ld hl,0 - subw hl,de ; neg dividend.lw - pop de ; dividend.hw - push hl - ld hl,0 - sbc hl,de ; neg dividend.hw - pop de ; dividend.lw -ssmod2: - cpw hl,bc ; dividend.hw >= divisor? - jr c,ssmod3 ; no overflow, continue - ld hl,0ffffh - ld d,h - ld e,l ; set rem & quot to max - jr ssmod5 -; -ssmod3: - ex de,hl ; dehl <-- dividend.hw,lw - divuw dehl,bc ; de <-- remainder, hl <-- quotient - ex de,hl ; hl <-- remainder - bit 0,a ; was dividend negative? - jr z,ssmod4 ; no - neg hl ; yes, negate remainder -ssmod4: - ex de,hl ; hl <-- quotient - or a - jr z,ssmod5 ; neither operand negative - cp 81h ; both operands negative? - jr z,ssmod5 ; yes, quotient stays positive - neg hl ; no, negate quotient -ssmod5: - push de ; remainder - push hl ; quotient - exx ; restore ip - jnext -; -; - defb 82h ; */ - defc '*/' - defw ssmod-8 -ssla: - defw $+2 ;/ - exx ; save ip - pop hl ; divisor - ld a,h - and 80h ; filter sign - jr z,ssla1 ; positive - neg hl ; make positive -ssla1: - ld b,h - ld c,l ; bc <-- divisor - pop hl ; multipicator - pop de ; multiplicant - ex af,af' ; save sign flag - multw hl,de ; dehl <-- product (= dividend) - ex af,af' ; restore sign flag - ex de,hl ; de <-- dividend.lw - bit 7,h ; dividend negative? - jr z,ssla2 ; no - inc a ; dividend sign flag - push hl - ld hl,0 - subw hl,de ; neg dividend.lw - pop de ; dividend.hw - push hl - ld hl,0 - sbc hl,de ; neg dividend.hw - pop de ; dividend.lw -ssla2: - cpw hl,bc ; dividend.hw >= divisor? - jr c,ssla3 ; no overflow, continue - ld hl,0ffffh ; set quotient to max - jr ssla4 -; -ssla3: - ex de,hl ; dehl <-- dividend.hw,lw - divuw dehl,bc ; de <-- remainder, hl <-- quotient - or a - jr z,ssla4 ; neither operand negative - cp 81h ; both operands negative? - jr z,ssla4 ; yes, quotient stays positive - neg hl ; no, negate quotient -ssla4: - push hl ; quotient - exx ; restore ip - jnext -; -; - defb 85h ; M/MOD - defc 'M/MOD' - defw ssla-5 -msmod: - defw docol - defw tor - defw zero - defw rr - defw uslas - defw fromr - defw swap - defw tor - defw uslas - defw fromr - defw semis -; -; -; Block moved down 2 pages -; - defb 86h ; (LINE) - defc '(LINE)' - defw msmod-8 -pline: - defw docol - defw tor - defw lit - defw 40h - defw bbuf - defw ssmod - defw fromr - defw bscr - defw star - defw plus - defw block - defw plus - defw lit - defw 40h - defw semis -; -; - defb 85h ; .LINE - defc '.LINE' - defw pline-9 -dline: - defw docol - defw pline - defw dtrai - defw type - defw semis -; -; - defb 87h ; MESSAGE - defc 'MESSAGE' - defw dline-8 -mess: - defw docol - defw warn - defw at - defw zbran ; if - defw mess1-$ - defw ddup - defw zbran ; if - defw mess2-$ - defw lit - defw 4 ; 1st message screen - defw ofset - defw at - defw bscr - defw slash - defw subb - defw dline - defw space ; endif -mess2: - defw bran ; else - defw mess3-$ -mess1: - defw pdotq - defb 6 - db 'MSG # ' - defw dot ; endif -mess3: defw semis -; -; - defb 82h ; P@ - defc 'P@' - defw mess-0ah -ptat: - defw $+2 - exx ;d save registers - pop bc ;d bc <-- port# - in l,(c) ;d l <-- data byte - ld h,0 - push hl - exx ;d restore registers - jnext -; -; - defb 82h ; P! - defc 'P!' - defw ptat-5 -ptsto: - defw $+2 - exx ;d save registers - pop bc ;d c <-- port# - pop hl ;d L <-- date byte - out (c),l - exx ;d restore registers - jnext -; -; - page -include DISCIO.Z80 - page -include CONPRTIO.Z80 - page -; - defb 0c1h ; ' (tick) - defb 0a7h - defw arrow-6 -tick: - defw docol - defw dfind - defw zequ - defw zero - defw qerr - defw drop - defw liter - defw semis -; -; - defb 86h ; FORGET - defc 'FORGET' - defw tick-4 -forg: - defw docol - defw curr - defw at - defw cont - defw at - defw subb - defw lit - defw 18h - defw qerr - defw tick - defw dup - defw fence - defw at - defw uless ;/ FORGET >8000h nw o.k. - defw lit - defw 15h - defw qerr - defw dup - defw nfa - defw dp - defw store - defw lfa - defw at - defw cont - defw at - defw store - defw semis -; -; - defb 84h ; BACK - defc 'BACK' - defw forg-9 -back: - defw docol - defw here - defw subb - defw comma - defw semis -; -; - defb 0c5h ; BEGIN - defc 'BEGIN' - defw back-7 -begin: - defw docol - defw qcomp - defw here - defw one - defw semis -; -; - defb 0c5h ; ENDIF - defc 'ENDIF' - defw begin-8 -endiff: - defw docol - defw qcomp - defw two - defw qpair - defw here - defw over - defw subb - defw swap - defw store - defw semis -; -; - defb 0c4h ; THEN - defc 'THEN' - defw endiff-8 -then: defw docol - defw endiff - defw semis -; -; - defb 0c2h ; DO - defc 'DO' - defw then-7 -do: - defw docol - defw comp - defw xdo - defw here - defw three - defw semis -; -; - defb 0c4h ; LOOP - defc 'LOOP' - defw do-5 -loop: - defw docol - defw three - defw qpair - defw comp - defw xloop - defw back - defw semis -; -; - defb 0c5h ; +LOOP - defc '+LOOP' - defw loop-7 -ploop: - defw docol - defw three - defw qpair - defw comp - defw xploo - defw back - defw semis -; -; - defb 0c5h ; UNTIL - defc 'UNTIL' - defw ploop-8 -until: - defw docol - defw one - defw qpair - defw comp - defw zbran - defw back - defw semis -; -; - defb 0c3h ; END - defc 'END' - defw until-8 -endd: - defw docol - defw until - defw semis -; -; - defb 0c5h ; AGAIN - defc 'AGAIN' - defw endd-6 -again: - defw docol - defw one - defw qpair - defw comp - defw bran - defw back - defw semis -; -; - defb 0c6h ; REPEAT - defc 'REPEAT' - defw again-8 -repea: - defw docol - defw tor - defw tor - defw again - defw fromr - defw fromr - defw twomin ;/ - defw endiff - defw semis -; -; - defb 0c2h ; IF - defc 'IF' - defw repea-9 -iff: - defw docol - defw comp - defw zbran - defw here - defw zero - defw comma - defw two - defw semis -; -; - defb 0c4h ; ELSE - defc 'ELSE' - defw iff-5 -elsee: - defw docol - defw two - defw qpair - defw comp - defw bran - defw here - defw zero - defw comma - defw swap - defw two - defw endiff - defw two - defw semis -; -; - defb 0c5h ; WHILE - defc 'WHILE' - defw elsee-7 -while: - defw docol - defw iff - defw twop - defw semis -; -; - defb 86h ; SPACES - defc 'SPACES' - defw while-8 -spacs: - defw docol - defw zero - defw max - defw ddup - defw zbran ; if - defw spax1-$ - defw zero - defw xdo ; do -spax2: - defw space - defw xloop ; loop endif - defw spax2-$ -spax1: - defw semis -; -; - defb 82h ; <# - defc '<#' - defw spacs-9 -bdigs: - defw docol - defw pad - defw hld - defw store - defw semis -; -; - defb 82h ; #> - defc '#>' - defw bdigs-5 -edigs: - defw docol - defw drop - defw drop - defw hld - defw at - defw pad - defw over - defw subb - defw semis -; -; - defb 84h ; SIGN - defc 'SIGN' - defw edigs-5 -sign: - defw docol - defw rot - defw zless - defw zbran ; if - defw sign1-$ - defw lit - defw 2dh - defw hold ; endif -sign1: - defw semis -; -; - defb 81h ; # - defc '#' - defw sign-7 -dig: - defw docol - defw base - defw at - defw msmod - defw rot - defw lit - defw 9 - defw over - defw less - defw zbran ; if - defw dig1-$ - defw lit - defw 7 - defw plus ; endif -dig1: defw lit - defw 30h - defw plus - defw hold - defw semis -; -; - defb 82h ; #S - defc '#S' - defw dig-4 -digs: - defw docol -digs1: - defw dig ; begin - defw tdup ;/ - defw orr - defw zequ - defw zbran ; until - defw digs1-$ - defw semis -; -; - defb 83h ; D.R - defc 'D.R' - defw digs-5 -ddotr: - defw docol - defw tor - defw swap - defw over - defw dabs - defw bdigs - defw digs - defw sign - defw edigs - defw fromr - defw over - defw subb - defw spacs - defw type - defw semis -; -; - defb 82h ; .R - defc '.R' - defw ddotr-6 -dotr: - defw docol - defw tor - defw stod - defw fromr - defw ddotr - defw semis -; -; - defb 82h ; D. - defc 'D.' - defw dotr-5 -ddot: - defw docol - defw zero - defw ddotr - defw space - defw semis -; -; - defb 81h ; . - defc '.' - defw ddot-5 -dot: - defw docol - defw stod - defw ddot - defw semis -; -; - defb 81h ; ? - defc '?' - defw dot-4 -ques: - defw docol - defw at - defw dot - defw semis -; -; - defb 82h ; U. - defc 'U.' - defw ques-4 -udot: defw docol - defw zero - defw ddot - defw semis -; - - defb 85h ; VLIST - defc 'VLIST' - defw udot-5 -vlist: - defw docol - defw lit - defw 80h - defw outt - defw store - defw cont - defw at - defw at -vlis1: - defw outt ; begin - defw at - defw csll - defw great - defw zbran ; if - defw vlis2-$ - defw cr - defw zero - defw outt - defw store ; endif -vlis2: - defw dup - defw iddot - defw space - defw space - defw pfa - defw lfa - defw at - defw dup - defw zequ - defw qterm - defw orr - defw zbran ; until - defw vlis1-$ - defw drop - defw semis -; -; - defb 83h ; BYE - defc 'BYE' - defw vlist-8 -bye: - defw docol ;/A - defw flush ;/A - defw fcb,lit ;/E - defw 10h,bdos ;/E close file - defw drop ;/E discard directory code - defw zero,zero ;/A - defw bdos ;/A return to CP/M - defw semis ;/A won't get this far, just for pretty -; -; - defb 84h ; LIST - defc 'LIST' - defw bye-6 -list: - defw docol,dec - defw cr,dup - defw scr,store - defw pdotq - defb 6 - db 'SCR # ' - defw dot - defw lit,10h - defw zero,xdo -list1: - defw cr,ido - defw three ;/ was lit,3 - defw dotr,space - defw ido,scr - defw at,dline - defw qterm - defw zbran,list2-$ ; if - defw leave -list2: - defw xloop,list1-$ ; endif - defw cr - defw semis -; -; - defb 85H ;INDEX - defc 'INDEX' - defw list-7 -index: - defw docol - defw lit,ff - defw emit - defw cr - defw onep,swap - defw xdo -inde1: - defw cr,ido - defw three ;/ was lit,3 - defw dotr,space - defw zero,ido - defw dline,qterm - defw zbran,inde2-$ ; if - defw leave ; endif -inde2: - defw xloop,inde1-$ - defw semis -; -; - defb 85h ; TRIAD - defc 'TRIAD' - defw index-8 -triad: - defw docol - defw lit,ff - defw emit - defw three ;/ was lit,3 - defw slash - defw three ;/ was lit,3 - defw star - defw three ;/ was lit,3 - defw over,plus - defw swap,xdo -tria1: - defw cr,ido - defw list - defw qterm - defw zbran,tria2-$ ; if - defw leave -tria2: - defw xloop,tria1-$ ; endif - defw cr - defw lit,15 - defw mess,cr - defw semis -; -; - defb 84h ; .CPU - defc '.CPU' - defw triad-8 -dotcpu: - defw docol - defw base,at - defw lit,36 - defw base,store - defw lit,22h - defw porig,tat - defw ddot - defw base,store - defw semis -; -; - defb 86h ; setclk - defc 'setclk' - defw dotcpu-7 -setclk: - defw $+2 - exx ; save ip - ld c,iopreg - ldctl hl,(c) ; l <-- current i/o page - ld a,l - ex af,af' ; save i/o page - ld l,0feh - ldctl (c),hl ; select i/o page 0feh - xor a - out (cntrl0),a ; disable c/t 0 - out (cntrl1),a ; disable c/t 1 - out (config1),a - ld hl,0ffffh - ld a,10h - out (config0),a ; cascade c/t 0 - c/t 1 - ld c,tcon0 - outw (c),hl ; load c/t 0 time constant - ld c,tcon1 - outw (c),hl ; load c/t 1 time constatnt - ld a,80h - out (config1),a ; continous mode - ld a,0e0h - out (cntrl1),a ; start 32bit counter - ex af,af' ; std. accu - ld l,a ; l <-- previous i/o page - ld c,iopreg - ldctl (c),hl ; restore i/o page - exx ; restore ip - jnext -; -; - defb 86h ; getclk - defc 'getclk' - defw setclk-9 -getclk: - defw $+2 - exx ; save ip - ld c,iopreg - ldctl hl,(c) ; l <-- current i/o page - ld a,l - ex af,af' ; save current i/o page - ld l,0feh - ldctl (c),hl ; select i/o page 0feh - ld a,80h - out (cntrl1),a ; halt 32bit counter - ld c,count1 - inw hl,(c) - ld d,h - ld e,l ; de <-- count1 - ld c,count0 - inw hl,(c) ; hl <-- count0 - ld c,0 - ld a,c ; a <-- 0 - sub l ; 0 - l - ld l,a ; l <-- neg(l) - ld a,c ; a <-- 0 - sbc a,h - ld h,a ; h <-- neg(h) - ld a,c ; a <-- 0 - sbc a,e - ld e,a ; e <-- neg(e) - ld a,c ; a <-- 0 - sbc a,d - ld d,a ; d <-- neg(d), dehl <-- neg(dehl) - divuw dehl,25000 ; scale to 1/100 secs - push hl ; result - ex af,af' ; std. accu - ld l,a ; l <-- previous i/o page - ld c,iopreg - ldctl (c),hl ; restore i/o page - exx ; restore ip - jnext -; -; - defb 84h ; TASK - defc 'TASK' - defw getclk-9 -; defw dotcpu-7 -task: - defw docol - defw semis -; -; -initdp: - defw 0 -; - end orig - \ No newline at end of file diff --git a/software/CPM/CPM08_Z80FORTH/280FORTH.280 b/software/CPM/CPM08_Z80FORTH/280FORTH.280 deleted file mode 100644 index b936b58..0000000 --- a/software/CPM/CPM08_Z80FORTH/280FORTH.280 +++ /dev/null @@ -1,4071 +0,0 @@ - title < Z280 fig-FORTH 1.1 a > - subttl Adaptive version -; -; -; Modified from Z80 fig-FORTH 1.1h by EHR 880830 -; Modified frm FIG document keyed by Dennis L. Wilson 800907 -; Converted frm "8080 FIG-FORTH VERSION A0 15SEP79" -; -; fig-FORTH release 1.1 for the 8080 processor. -; -; ALL PUBLICATIONS OF THE FORTH INTEREST GROUP -; ARE PUBLIC DOMAIN. THEY MAY BE FURTHER -; DISTRIBUTED BY THE INCLUSION OF THIS CREDIT NOTICE: -; -; This publication has been made available by the -; Forth Interest Group -; P.O.Box 1105 -; San Carlos, CA 94070 -; U.S.A. -; -; Implementation on 8080 by: -; John Cassady -; 339 15th Street -; Oakland, CA 94612 -; U.S.A -; on 790528 -; Modified by: -; Kim Harris -; Acknowledgements: -; George Flammer -; Robt. D. Villwock -; ---------------------------------------------------------------------- -; Z80 Version for Cromemco CDOS & Digital Research CP/M by: -; Dennis Lee Wilson c/o -; Aristotelian Logicians -; 2631 East Pinchot Avenue -; Phoenix, AZ 85016 -; U.S.A. -; ---------------------------------------------------------------------- -; The 2 byte Z80 code for Jump Relative (JR) has been substituted for -; the 3 byte Jump (JP) wherever practical. The port I/O words P@ & P! -; have been made ROMable by use of Z80 instructions. -; ---------------------------------------------------------------------- -; Further modifications (marked ;/) by: -; Edmund Ramm -; P.O.Box 38 -; 2358 Kaltenkirchen -; Fed. Rep. of Germany 840418 -; -; 850419 changed * (star) -; 850507 added 0<>, 0>, TUCK, NIP, -ROT, CSWAP, PICK -; 850511 added -CMOVE -; -; ----------------------------------------------------------------------------- -; Disc I/O has been modified a la Albert van der Horst (HCCH) to employ -; CP/M 2.x's random access feature. -; ----------------------------------------------------------------------------- -; ----------------------------------------------------------------------------- -; -; Z280 specifics -; -; -iopreg equ 08h ; i/o page register -; -config0 equ 0e0h ; c/t 0 configuration register -cntrl0 equ 0e1h ; c/t 0 command/status register -tcon0 equ 0e2h ; c/t 0 time constatnt register -count0 equ 0e3h ; c/t 0 count-time register -config1 equ 0e8h ; c/t 1 configuration register -cntrl1 equ 0e9h ; c/t 1 command/status register -tcon1 equ 0eah ; c/t 1 time constant register -count1 equ 0ebh ; c/t 1 count-time register -; -; ----------------------------------------------------------------------------- -; -; Release & Version numbers -; -figrel equ 1 ;FIG RELEASE # -figrev equ 1 ;FIG REVISION # -usrver equ 61h ;USER VERSION # a by EHR -; -;Console & printer drivers are in external source named -;CONPRTIO.FTH & disc drivers in DISCIO.FTH. It has 4 screen -;buffers & end of memory is set to FBASE from locn. 0007H. - page -; ASCII characters used -; -abl equ 20h ;BLANK -acr equ 0dh ;CR -adot equ 2eh ;. -bell equ 07h ;^G -bsin equ 08h ;backspace chr = ^H -bsout equ 08h -dle equ 10h ;^P -lf equ 0ah ;^J -ff equ 0ch ;^L -; -; Memory allocation -; -bdoss equ 0005h ;/ system entry -nscr equ 4 ; # of 1024 byte screens -kbbuf equ 128 ; bytes/disc buffer -us equ 40h ; user variables space -rts equ 400h ; Return Stack & term buff space -co equ kbbuf+4 ; Disc buff + 2 header + 2 tail -nbuf equ nscr*400h/kbbuf ; # of buffers -bufsiz equ co*nbuf ;/ total disc buffer size - page - aseg - .z280 -; - org 0100h -; -orig: - nop - jp cld ; vector to cold start - nop - jp wrm ; vector to warm start - defb figrel ; fig release # - defb figrev ; fig revision # - defb usrver ; user version # - defb 0eh ; implementation attributes -; -; -; -; 0eh = 0000:1110 -; --------- -; B +ORIGIN ...W:IEBA -; -; W: 0=above sufficient -; 1=other differences exist -; I: Interpreter is 0=pre- -; 1=post incrementing -; E: Addr must be even: 0 yes -; 1 no -; B: High byte @ 0=low addr. -; 1=high addr. -; A: CPU Addr. 0=BYTE -; 1=WORD -; -; -; - defw task-7 ; topmost word in FORTH vocabulary - defw bsin ; backspace chr -upinit: defw 0 ;/ init (up) -; -; * Following used by COLD; must be in same order as user variables * -; -s0init: defw 0 ;/ init (s0) -r0init: defw 0 ;/ init (r0) -tibini: defw 0 ;/ init (TIB) - defw 1fh ; init (WIDTH) - defw 0 ; init (WARNING) - defw initdp ; init (FENCE) - defw initdp ; init (dp) - defw forth+8 ; init (VOC-LINK) -; -; * END DATA USED BY COLD * -; - defw 0018h,0f600h ; Z280 CPU name (hw,lw) - ; (32 bit base 36 integer) - page -; REGISTERS -; -; FORTH Z80 FORTH PRESERVATION RULES -; ----- --- ----------------------- -; IP BC should be preserved -; accross FORTH words. -; W DE sometimes output from -; NEXT, may be altered -; b4 JP'ing to NEXT, -; input only when -; "DPUSH" called. -; SP SP should be used only as -; Data Stack accross -; FORTH words, may be -; used within FORTH -; words if restored -; b4 "NEXT" -; HL Never output frm NEXT -; input only when -; "HPUSH" called -; -; -up: defw 0 ;/ user area ptr -rpp: defw 0 ;/ return stack ptr -buf1: defw 0 ;/ address of 1st disc buffer -; -; -; COMMENT CONVENTIONS: -; -; == means "is equal to" -; <-- means assignment -; #NAME = value of name -; NAME = contents @ name -; (NAME) = contents of cell addressed by name -; cfa = code field address -; lfa = link field address -; nfa = name field address -; pfa = parameter field address -; s1 = 1st word of parameter stack -; s2 = 2nd -"- of -"- -"- -; r1 = 1st -"- of return stack -; r2 = 2nd -"- of -"- -"- -; ( above Stack posn. valid b4 & after execution of any word, not during) -; -; lsb = least significant bit -; msb = most significant bit -; lb = low byte -; hb = high byte -; lw = low word -; hw = high word -; (May be used as suffix to above names) - page -; FORTH ADDRESS INTERPRETER -; POST INCREMENTING VERSION -; -; -; -dpush: - push de -hpush: - push hl ; iy points here -next: - ld h,b ;/ w <-- (ip) ix points here - ld l,c ;/ - ldw hl,(hl) ;/ (hl) --> cfa - inc bc - inc bc ;/ ip += 2 -next1: - ldw de,(hl) ;/ pc <-- (w) - ex de,hl - inc de - jp (hl) ; note: de <-- cfa + 1 -; -; -jnext macro - jp (ix) - endm -; -jhpush macro - jp (iy) - endm -; - page -; FORTH DICTIONARY -; DICTIONARY FORMAT: -; -; BYTE -; ADDRESS NAME CONTENTS -; ------- ---- -------- -; (MSB=1 -; (P=PRECEDENCE BIT -; (S=SMUDGE BIT -; NFA NAME FIELD 1PS MSB=0, NAME'S 1st CHAR -; 0<2CHAR> -; ... -; 1 MSB=1, NAME'S LAST CHAR -; LFA LINK FIELD =PREVIOUS WORD'S NFA -; -;LABEL: CFA CODE FIELD =ADDR CPU CODE -; -; PFA PARAMETER <1PARAM> 1st PARAMETER BYTE -; FIELD <2PARAM> -; ... -; -; -; -dp0: - defb 83h ; LIT - defc 'LIT' - defw 0 ; lfa == 0 marks end of dictionary -lit: - defw $+2 ; s1 <-- (ip) - ld h,b - ld l,c - ldw hl,(hl) ; hl <-- (ip) = literal - inc bc ;/ - inc bc ;/ ip += 2 - jhpush ; s1 <-- hl -; -; - defb 87h ; EXECUTE - defc 'EXECUTE' - defw lit-6 -exec: - defw $+2 - pop hl - jp next1 -; -; - defb 86h ; BRANCH - defc 'BRANCH' - defw exec-0ah -bran: - defw $+2 ; ip += (ip) -bran1: - ld h,b - ld l,c ; hl <-- ip - addw hl,(hl) ; hl <-- ip + branch offset - ld c,l - ld b,h ; ip += branch offset - jnext -; -; - defb 87h ; 0BRANCH - defc '0BRANCH' - defw bran-9 -zbran: - defw $+2 - pop hl - ld a,l - or h - jr z,bran1 ; branch if if s1 == 0 - inc bc ; else skip branch offset - inc bc - jnext -; -; - defb 86h ; (LOOP) - defc '(LOOP)' - defw zbran-0ah -xloop: - defw $+2 - ld hl,(rpp) ; (hl) --> index = r1 - incw (hl) ;/ index += 1 - ldw de,(hl) ;/ de <-- new index - inc hl ;/ - inc hl ;/ hl --> limit(lb) - ld a,e - sub (hl) - ld a,d - inc hl ; hl --> limit(hb) - sbc a,(hl) ; index < limit? - jp m,bran1 ; yes, loop again - inc hl ; no, done - ld (rpp),hl ; discard r1 & r2 - inc bc - inc bc ; skip branch offset - jnext -; -; - defb 87h ; (+LOOP) - defc '(+LOOP)' - defw xloop-9 -xploo: - defw $+2 - pop de ; de <-- increment - ld hl,(rpp) ; hl --> index - ld a,(hl) ; index += increment - add a,e - ld (hl),a - ld e,a - inc hl - ld a,(hl) - adc a,d - ld (hl),a - inc hl ; (hl) --> limit - inc d - dec d - ld d,a ; de <-- new index - jp m,xloo2 ; if incr > 0 - ld a,e - sub (hl) ; then a <-- index - limit - ld a,d - inc hl - sbc a,(hl) - jp xloo3 - -xloo2: - ld a,(hl) ; else a <-- limit - index - sub e - inc hl - ld a,(hl) - sbc a,d -; ; if a < 0 -xloo3: - jp m,bran1 ; then loop again - inc hl ; else done - ld (rpp),hl ; discard r1 & r2 - inc bc ; skip branch offset - inc bc - jnext -; -; - defb 84h ; (DO) - defc '(DO)' - defw xploo-0ah -xdo: - defw $+2 - pop de ; de <-- initial index - ld hl,(rpp) ; hl <-- rp - dec hl - dec hl - pop (hl) ;/ r2 <-- limit - dec hl - dec hl - ldw (hl),de ;/ r1 <-- initial index - ld (rpp),hl ; rp -= 4 - jnext -; -; - defb 81h ; I - defc 'I' - defw xdo-7 -ido: - defw $+2 - ld hl,(rpp) - push (hl) ;/ s1 <-- r1, r1 unchanged - jnext -; -; - defb 85h ; DIGIT - defc 'DIGIT' - defw ido-4 -digit: - defw $+2 - pop hl ; l <-- s1.lb = base value - pop de ; e <-- s2.lb = chr to be converted - ld a,e ; a <-- chr - sub '0' ; >= 0? - jr c,digi2 ;/ < 0 is invalid - cp 0ah ; > 9? - jr c,digi1 ;/ no, test base value - sub 07h ; gap between '9' & 'A', nw 'A'=0ah - cp 0ah ; >= 'A'? - jr c,digi2 ;/ chrs btwn '9' & 'A' are invalid -digi1: - cp l ; < base value? - jr nc,digi2 ;/ no, invalid - ld e,a ; s2 <-- de = converted digit - ld hl,0001h ; s1 <-- true - jp dpush -; -digi2: - ld l,h ; hl <-- false - jhpush ; s1 <-- false -; -; - defb 86h ; (FIND) (2-1)FAILURE - defc '(FIND)' ; (2-3)SUCCESS - defw digit-8 -pfind: - defw $+2 - pop de ; de <-- nfa -pfin1: - pop hl ; hl <-- string addr - push hl ; save for next iteration - ld a,(de) - xor (hl) ; filter differences - and 3fh ; mask msb & precedence bit - jr nz,pfin4 ; lengths differ -pfin2: - inc hl ; hl --> next string chr - inc de ; de --> next name field chr - ld a,(de) - xor (hl) ; filter differences - add a,a ; shift msbit into carry - jr nz,pfin3 ; no match - jr nc,pfin2 ; match so far, loop agn - ld hl,0005h ; string matches - add hl,de ; (sp) <-- pfa - ex (sp),hl -pfin6: - dec de ; de --> nfa - ld a,(de) - or a ; msb=1? =length byte - jp p,pfin6 ; no, try next chr - ld e,a ; e <-- length byte - ld d,00h - ld hl,0001h ; hl <-- true - jp dpush ; name field found, return -; -; above name field not a match, try next one -; -pfin3: - jr c,pfin5 ; carry=end of name field -pfin4: - inc de ; find name field end - ld a,(de) - or a ; msb=1? - jp p,pfin4 ; no, loop -pfin5: - inc de ; de <-- lfa - ex de,hl - ldw de,(hl) ;/ de <-- lfa - ld a,d - or e ; end of dictionary (lfa = 0)? - jr nz,pfin1 ; no, try previous definition - pop hl ; drop string address - ld hl,0 ; hl <-- false - jhpush ; no match found, return -; -; - defb 87h ; ENCLOSE - defc 'ENCLOSE' - defw pfind-9 -encl: - defw $+2 - pop de ; de <-- s1 = delimiter chr - pop hl ; hl <-- s2 = addr of text to scan - push hl ; s4 <-- addr - ld a,e - ld d,a ; d <-- delim chr - ld e,-1 ; init chr offset counter - dec hl ; hl <-- addr - 1 -encl1: - inc hl ; skip over leading delim chrs - inc e - cp (hl) ; delim chr? - jr z,encl1 ; yes, loop - ld d,0 - push de ; s3 <-- e = offset to 1st non delim - ld d,a ; d <-- delim chr - ld a,(hl) - and a ; 1st non-delim=null? - jr nz,encl2 ; no - ld d,0 ; yes - inc e - push de ; s2 <-- offset to byte following null - dec e - push de ; s1 <-- offset to null - jnext -; -encl2: - ld a,d ; A <-- delim chr - inc hl ; hl <-- next chr's address - inc e ; e <-- offset to next chr - cp (hl) ; delim chr? - jr z,encl4 ; yes - ld a,(hl) - and a ; null? - jr nz,encl2 ; no, continue scan -encl3: - ld d,0 - push de ; s2 <-- offset to null - push de ; s1 <-- offset to null - jnext -; -encl4: - ld d,0 - push de ; s2 <-- offset to byte following text - inc e - push de ; s1 <-- offset 2 bytes aft end of word - jnext -; -; - defb 84h ; EMIT - defc 'EMIT' - defw encl-0ah -emit: - defw docol - defw pemit - defw one,outt - defw pstor,semis -; -; - defb 83h ; KEY - defc 'KEY' - defw emit-7 -key: - defw $+2 - jp pkey -; -; - defb 89h ; ?TERMINAL - defc '?TERMINAL' - defw key-6 -qterm: - defw $+2 - ld hl,0 - jp pqter -; -; - defb 82h ; CR - defc 'CR' - defw qterm-0ch -cr: - defw $+2 - jp pcr -; -; - defb 85h ; CMOVE - defc 'CMOVE' - defw cr-5 -cmove: - defw $+2 - exx ;/ save ip - pop bc ; bc <-- s1 = # of chrs - pop de ; de <-- s2 = dest addr - pop hl ;/ hl <-- s3 = source addr - ld a,b - or c ; bc=0? - jr z,cmove1 ; yes, nothing to move - ldir ;/ xfer string -cmove1: - exx ;/ restore ip - jnext -; -; - defb 86h ;/ -CMOVE ( from to count --- ) - defc '-CMOVE' - defw cmove-8 -bcmov: - defw $+2 - exx ; save ip - pop bc ; bc <-- count - pop de ; de <-- destination - pop hl ; hl <-- source - ld a,b - or c ; bc =0? - jr z,bcmov1 ; yes, nothing to move - add hl,bc - dec hl ; hl --> hi end of source block - ex de,hl - add hl,bc - dec hl - ex de,hl ; de --> hi end of dest. block - lddr ; (de) <-- (hl), --hl,bc until bc=0 -bcmov1: - exx ; restore ip - jnext -; -; - defb 82h ; U* 16*16 unsigned multiply - defc 'U*' ; with 32 bit result - defw bcmov-9 -ustar: - defw $+2 - pop de ; de <-- multiplier - pop hl ; hl <-- multiplicant - multuw hl,de ;/ - ex de,hl ;/ de <-- product.lw, hl <-- product.hw - jp dpush ; s2,s1 <-- product.lw,hw -; -; - defb 82h ; U/ ( ud u1 -- urem uq ) - defc 'U/' - defw ustar-5 -uslas: - defw $+2 - exx ;/ save ip - pop bc ; bc <-- divisor - pop hl ; hl <-- dividend.hw - pop de ; de <-- dividend.lw - cpw hl,bc ;/ dividend.hw >= divisor? - jr c,usla1 ; no, go ahead - ld hl,0ffffh ; yes, overflow - ld d,h - ld e,l ;/ set rem & quot to max - jr usla2 -usla1: - ex de,hl ;/ de,hl <-- dividend.hw,lw - divuw dehl,bc ;/ de <-- remainder, hl <-- quotient -usla2: - push de ;/ s2 <-- remainder - push hl ;/ s1 <-- quotient - exx ;/ restore ip - jnext -; -; - defb 83h ; AND - defc 'AND' - defw uslas-5 -andd: - defw $+2 ; s1 <-- s1 AND s2 - pop de - pop hl - ld a,e - and l - ld l,a - ld a,d - and h - ld h,a - jhpush -; -; - defb 82h ; OR - defc 'OR' - defw andd-6 -orr: - defw $+2 ; s1 <-- s1 OR s2 - pop de - pop hl - ld a,e - or l - ld l,a - ld a,d - or h - ld h,a - jhpush -; -; - defb 83h ; XOR - defc 'XOR' - defw orr-5 -xorr: - defw $+2 ; s1 <-- s1 XOR s2 - pop de - pop hl - ld a,e - xor l - ld l,a - ld a,d - xor h - ld h,a - jhpush -; -; - defb 83h ; SP@ - defc 'SP@' - defw xorr-6 -spat: - defw $+2 - ld hl,0 - add hl,sp ; hl <-- sp - jhpush ; s1 <-- sp -; -; - defb 83h ; SP! - defc 'SP!' - defw spat-6 -spsto: - defw $+2 ; sp <-- s0 (user variable) - ld hl,(up) ; hl <-- user variables base address - ld de,6 - add hl,de ; hl --> s0 - ldw sp,(hl) ;/ sp <-- s0 - jnext -; -; - defb 83h ; RP@ - defc 'RP@' - defw spsto-6 -rpat: - defw $+2 - ld hl,(rpp) - jhpush ; s1 <-- rp -; -; - defb 83h ; RP! - defc 'RP!' - defw rpat-6 -rpsto: - defw $+2 ; rp <-- r0 (user variable) - ld hl,(up) ; hl <-- user variables base address - ld de,0008h - add hl,de ; hl --> r0 - ldw hl,(hl) ;/ hl <-- r0 - ld (rpp),hl ;/ rp <-- r0 - jnext -; -; - defb 82h ; ;S - defc ';S' - defw rpsto-6 -semis: - defw $+2 ; ip <-- r1 - ld hl,(rpp) - ldw bc,(hl) ;/ bc <-- r1 - inc hl - inc hl - ld (rpp),hl ; rp += 2 - jnext -; -; - defb 85h ; LEAVE - defc 'LEAVE' - defw semis-5 -leave: - defw $+2 ; limit <-- index - ld hl,(rpp) - ldw de,(hl) ;/ de <-- r1 (= index) - inc hl - inc hl - ldw (hl),de ;/ r2 (= limit) <-- index - jnext -; -; - defb 82h ; >R - defc '>R' - defw leave-8 -tor: - defw $+2 - ld hl,(rpp) - dec hl - dec hl - pop (hl) ;/ r1 <-- s1 - ld (rpp),hl ; rp -= 2 - jnext -; -; - defb 82h ; R> - defc 'R>' - defw tor-5 -fromr: - defw $+2 - ld hl,(rpp) - push (hl) ;/ s1 <-- r1 - inc hl - inc hl - ld (rpp),hl ; rp += 2 - jnext -; -; - defb 81h ; R - defc 'R' - defw fromr-5 -rr: - defw ido+2 -; -; - defb 82h ; 0= - defc '0=' - defw rr-4 -zequ: - defw $+2 - pop de - ld hl,0 - cpw hl,de ;/ - jr nz,zequ1 - inc l ; hl <-- true -zequ1: - jhpush -; -; - defb 83h ;/ 0<> - defc '0<>' - defw zequ-5 -znequ: - defw $+2 - pop de - ld hl,0 - cpw hl,de ;/ - jr z,znequ1 - inc l ; hl <-- true -znequ1: - jhpush -; -; - defb 82h ; 0< - defc '0<' - defw znequ-6 -zless: - defw $+2 - pop af ;/ a <-- s1.hb - rla ;/ carry <-- bit 7 - ld hl,0 ; hl <-- false - rl l ;/ bit 0 <-- carry - jhpush -; -; - defb 82h ;/ 0> - defc '0>' - defw zless-5 -zgt: - defw $+2 - pop de - ld hl,0 - cpw hl,de ;/ - jp p,zgt1 ;/ <= 0 - jp pe,zgt1 ;/ 8000h special case - inc l ;/ hl <-- true -zgt1: - jhpush -; -; - defb 81h ;+ - defc '+' - defw zgt-5 -plus: - defw $+2 - pop de - pop hl - add hl,de - jhpush -; -; - defb 82h ; D+ ( d1l d1h d2l d2h -- d3l d3h) - defc 'D+' - defw plus-4 -dplus: - defw $+2 - exx ;/ save ip - pop bc ; bc <-- d2.hw - pop hl ; hl <-- d2.lw - pop af ;d af <-- d1.hw - pop de ; de <-- d1.lw - push af ;/ s1 <-- d1.hw - add hl,de ; hl <-- d2.lw + d1.lw (= d3.lw) - ex de,hl ; de <-- d3.lw - pop hl ; hl <-- d1.hw - adc hl,bc ;/ hl <-- d1.hw + d2.hw +carry (=d3.hw) - push de ; s2 <-- d3.lw - push hl ;/ s1 <-- d3.hw - exx ;/ restore ip - jnext -; -; - defb 85h ; MINUS - defc 'MINUS' - defw dplus-5 -minus: - defw $+2 - pop hl ;/ - neg hl ;/ - jhpush -; -; - defb 86h ; DMINUS - defc 'DMINUS' - defw minus-8 -dminu: - defw $+2 - exx ;/ save ip - pop de ;/ de <-- d1.hw - pop bc ;/ bc <-- d1.lw - ld hl,0 ;/ - subw hl,bc ;/ - push hl ; s2 <-- d2.lw - ld hl,0 ;/ - sbc hl,de ;/ - push hl ; s1 <-- d2.hw - exx ;/ - jnext -; -; - defb 84h ; OVER - defc 'OVER' - defw dminu-9 -over: - defw $+2 - ldw hl,(sp+2) ;/ - jhpush ;/ -; -; - defb 84h ; DROP - defc 'DROP' - defw over-7 -drop: - defw $+2 - inc sp - inc sp ;/ faster on z280 than dummy pop - jnext -; -; - defb 84h ; SWAP - defc 'SWAP' - defw drop-7 -swap: - defw $+2 - pop hl - ex (sp),hl - jhpush -; -; - defb 83h ; DUP - defc 'DUP' - defw swap-7 -dup: - defw $+2 - ldw hl,(sp+0) ;/ - jhpush -; -; - defb 84h ;/ TUCK ( n1 n2 --- n2 n1 n2) - defc 'TUCK' - defw dup-6 -tuck: - defw $+2 - pop hl ;/ hl <-- s1 - pop de ;/ de <-- s2 - push hl ;/ s3 <-- hl - jp dpush -; -; - defb 83h ;/ NIP ( n1 n2 --- n2) - defc 'NIP' - defw tuck-7 -nip: - defw $+2 - pop hl ; hl <-- s1 - ldw (sp+0),hl ;/ s1 <-- hl - jnext -; -; - defb 84h ;/ -ROT ( n1 n2 n3 --- n3 n1 n2) - defc '-ROT' - defw nip-6 -mrot: - defw $+2 - pop hl - pop de - ex (sp),hl - ex de,hl - jp dpush -; -; - defb 85h ;/ CSWAP ( n1 --- n1, bytes swapped) - defc 'CSWAP' - defw mrot-7 -cswap: - defw $+2 - pop hl - ex h,l ;/ - jhpush -; -; - defb 84h ;/ PICK ( nn...n0 k --- nn..n0 nk) - defc 'PICK' - defw cswap-8 -pick: - defw $+2 - pop hl ; hl <-- depth - add hl,hl ; adjust to word size - add hl,sp ; offset into stack - push (hl) ;/ - jnext -; -; - defb 84h ; 2DUP - defc '2DUP' - defw pick-7 -tdup: - defw $+2 - pop hl - pop de - push de - push hl - jp dpush -; -; - defb 82h ; +! - defc '+!' - defw tdup-7 -pstor: - defw $+2 - pop hl ; hl --> variable - pop de ; de <-- number - ld a,(hl) - add a,e - ld (hl),a - inc hl - ld a,(hl) - adc a,d - ld (hl),a ; (hl) += number - jnext -; -; - defb 86h ; TOGGLE - defc 'TOGGLE' - defw pstor-5 -toggl: - defw $+2 - pop de ; e <-- bit pattern - pop hl ; hl --> address - ld a,(hl) - xor e - ld (hl),a - jnext -; -; - defb 81h ; @ - defc '@' - defw toggl-9 -at: - defw $+2 - pop hl - push (hl) ;/ - jnext -; -; - defb 82h ; C@ - defc 'C@' - defw at-4 -cat: - defw $+2 - pop hl - ld l,(hl) - ld h,0 - jhpush -; -; - defb 82h ; 2@ - defc '2@' - defw cat-5 -tat: - defw $+2 - pop hl ; hl --> address - ldw de,(hl) ;/ de <-- d.hw - inc hl - inc hl ; hl --> d.lw - push (hl) ;/ s2 <-- d.lw - push de ;/ s1 <-- d.hw - jnext -; -; - defb 81h ; ! - defc '!' - defw tat-5 -store: - defw $+2 - pop hl ; hl --> address - pop (hl) ;/ - jnext -; -; - defb 82h ; C! - defc 'C!' - defw store-4 -cstor: - defw $+2 - pop hl ; hl --> address - pop de ; e <-- char - ld (hl),e - jnext -; -; - defb 82h ; 2! - defc '2!' - defw cstor-5 -tstor: - defw $+2 - pop hl ; hl --> address - pop (hl) ;/ store d.hw - inc hl - inc hl - pop (hl) ;/ store d.lw - jnext -; -; - defb 0c1h ; : - defc ':' - defw tstor-5 -colon: - defw docol - defw qexec - defw scsp - defw curr - defw at - defw cont - defw store - defw creat - defw rbrac - defw pscod -docol: - ld hl,(rpp) - dec hl - dec hl - ldw (hl),bc ;/ save return address - ld (rpp),hl - inc de - ld c,e - ld b,d - jnext -; -; - defb 0c1h ; ; - defc ';' - defw colon-4 -semi: - defw docol - defw qcsp - defw comp - defw semis - defw smudg - defw lbrac - defw semis -; -; - defb 84h ; NOOP - defc 'NOOP' - defw semi-4 -noop: - defw docol - defw semis -; -; - defb 88h ; CONSTANT - defc 'CONSTANT' - defw noop-7 -con: - defw docol - defw creat - defw smudg - defw comma - defw pscod -docon: - inc de - ex de,hl - push (hl) ;/ - jnext -; -; - defb 88h ; VARIABLE - defc 'VARIABLE' - defw con-0bh -var: - defw docol - defw con - defw pscod -dovar: - inc de - push de - jnext -; -; - defb 84h ; USER - defc 'USER' - defw var-0bh -user: - defw docol - defw con - defw pscod -douse: - inc de - ex de,hl - ld l,(hl) ;/ - ld h,0 ;/ - addw hl,(up) ;/ - jhpush -; -; - defb 81h ; 0 - defc '0' - defw user-7 -zero: - defw $+2 ;/ - push 0000h ;/ - jnext -; -; - defb 81h ; 1 - defc '1' - defw zero-4 -one: - defw $+2 ;/ - push 0001h ;/ - jnext -; -; - defb 81h ; 2 - defc '2' - defw one-4 -two: - defw $+2 ;/ - push 0002h ;/ - jnext -; -; - defb 81h ; 3 - defc '3' - defw two-4 -three: - defw $+2 ;/ - push 0003h ;/ - jnext -; -; - defb 82h ; BL - defc 'BL' - defw three-4 -bl: - defw docon - defw 20h -; -; - defb 83h ; C/L - defc 'C/L' - defw bl-5 -csll: - defw docon - defw 64 -; -; - defb 85h ; FIRST - defc 'FIRST' - defw csll-6 -first: - defw docon - defw 0 ;/ set by CLD -; -; - defb 85h ; LIMIT - defc 'LIMIT' - defw first-8 -limit: - defw docon - defw 0 ;/ set by CLD -; -; - defb 85h ; B/BUF - defc 'B/BUF' - defw limit-8 -bbuf: - defw docon - defw kbbuf -; -; - defb 85h ; B/SCR - defc 'B/SCR' - defw bbuf-8 -bscr: - defw docon - defw 400h/kbbuf -; -; - defb 87h ; +ORIGIN - defc '+ORIGIN' - defw bscr-8 -porig: - defw docol - defw lit - defw orig - defw plus - defw semis -; -; USER VARIABLES -; - defb 82h ; S0 - defc 'S0' - defw porig-0ah -szero: - defw douse - defw 6 -; -; - defb 82h ; R0 - defc 'R0' - defw szero-5 -rzero: - defw douse - defw 8 -; -; - defb 83h ; TIB - defc 'TIB' - defw rzero-5 -tib: - defw douse - defb 0ah -; -; - defb 85h ; WIDTH - defc 'WIDTH' - defw tib-6 -width: - defw douse - defb 0ch -; -; - defb 87h ; WARNING - defc 'WARNING' - defw width-8 -warn: - defw douse - defb 0eh -; -; - defb 85h ; FENCE - defc 'FENCE' - defw warn-0ah -fence: - defw douse - defb 10h -; -; - defb 82h ; DP - defc 'DP' - defw fence-8 -dp: - defw douse - defb 12h -; -; - defb 88h ; VOC-LINK - defc 'VOC-LINK' - defw dp-5 -vocl: - defw douse - defw 14h -; -; - defb 83h ; BLK - defc 'BLK' - defw vocl-0bh -blk: - defw douse - defb 16h -; -; - defb 82h ; IN - defc 'IN' - defw blk-6 -inn: - defw douse - defb 18h -; -; - defb 83h ; OUT - defc 'OUT' - defw inn-5 -outt: - defw douse - defb 1ah -; -; - defb 83h ; SCR - defc 'SCR' - defw outt-6 -scr: - defw douse - defb 1ch -; -; - defb 86h ; OFFSET - defc 'OFFSET' - defw scr-6 -ofset: - defw douse - defb 1eh -; -; - defb 87h ; CONTEXT - defc 'CONTEXT' - defw ofset-9 -cont: - defw douse - defb 20h -; -; - defb 87h ; CURRENT - defc 'CURRENT' - defw cont-0ah -curr: - defw douse - defb 22h -; -; - defb 85h ; STATE - defc 'STATE' - defw curr-0ah -state: - defw douse - defb 24h -; -; - defb 84h ; BASE - defc 'BASE' - defw state-8 -base: - defw douse - defb 26h -; -; - defb 83h ; DPL - defc 'DPL' - defw base-7 -dpl: - defw douse - defb 28h -; -; - defb 83h ; FLD - defc 'FLD' - defw dpl-6 -fld: - defw douse - defb 2ah -; -; - defb 83h ; CSP - defc 'CSP' - defw fld-6 -cspp: - defw douse - defb 2ch -; - - defb 82h ; R# - defc 'R#' - defw cspp-6 -rnum: - defw douse - defb 2eh -; - - defb 83h ; HLD - defc 'HLD' - defw rnum-5 -hld: - defw douse - defw 30h -; -; END OF USER VARIABLES -; - defb 82h ; 1+ - defc '1+' - defw hld-6 -onep: - defw $+2 ;/ - pop hl ;/ - inc hl ;/ - jhpush ;/ -; -; - defb 82h ; 2+ - defc '2+' - defw onep-5 -twop: - defw $+2 ;/ - pop hl ;/ - inc hl ;/ - inc hl ;/ - jhpush ;/ -; -; - defb 82h ;/ 1- - defc '1-' ;/ - defw twop-5 ;/ -onemin: - defw $+2 ;/ - pop hl ;/ - dec hl ;/ - jhpush ;/ -; -; - defb 82h ;/ 2- - defc '2-' ;/ - defw onemin-5 ;/ -twomin: - defw $+2 ;/ - pop hl ;/ - dec hl ;/ - dec hl ;/ - jhpush ;/ -; -; - defb 82h ;/ 2* - defc '2*' ;/ - defw twomin-5 ;/ -twosta: - defw $+2 ;/ - pop hl ;/ - add hl,hl ;/ asl hl - jhpush ;/ -; -; - defb 82h ;/ 2/ - defc '2/' ;/ - defw twosta-5 ;/ -twosla: - defw $+2 ;/ - pop hl ;/ - bit 7,h ;/ negative? - jr z,twosl1 ;/ no - inc hl ;/ yes, add 1 -twosl1: - sra h ;/ - rr l ;/ asr hl - jhpush ;/ -; -; - defb 84h ; HERE - defc 'HERE' - defw twosla-5 -here: - defw docol - defw dp - defw at - defw semis -; -; - defb 85h ; ALLOT - defc 'ALLOT' - defw here-7 -allot: - defw docol - defw dp - defw pstor - defw semis -; -; - defb 81h ; , - defc ',' - defw allot-8 -comma: - defw docol - defw here - defw store - defw two - defw allot - defw semis -; - - defb 82h ; C, - defc 'C,' - defw comma-4 -ccomm: - defw docol - defw here - defw cstor - defw one - defw allot - defw semis -; -; - defb 81h ; - - defc '-' - defw ccomm-5 -subb: - defw $+2 - pop de - pop hl - subw hl,de ;/ - jhpush -; -; - defb 81h ; = - defc '=' - defw subb-4 -equal: - defw $+2 ;/ - pop de ;/ - pop hl ;/ - subw hl,de ;/ - ld hl,0 ; hl <-- false - jr nz,equal1 - inc l ;/ hl <-- true -equal1: - jhpush -; -; - defb 81h ; < - defc '<' - defw equal-4 -less: - defw $+2 - pop de - pop hl ; hl de < - ld a,d - xor h ; one operand negative? - jp m,less1 ; yes, determine which - subw hl,de ;/ -less1: - bit 7,h ;/ h negative? - ld hl,0 ; hl <-- false - jr z,less2 - inc l ;/ hl <-- true -less2: - jhpush -; -; - defb 82h ; U< - defc 'U<' - defw less-4 -uless: - defw $+2 - pop de - pop hl ;/ hl de U< - subw hl,de ;/ - ld hl,0 ; hl <-- false - rl l ;/ bit 0 <-- carry -uless1: - jhpush -; -; - defb 81h ; > - defc '>' - defw uless-5 -great: - defw $+2 - pop hl ;/ - pop de ;/ hl de > (= de hl < ) - ld a,d - xor h ; one operand negative? - jp m,great1 ; yes, determine which - subw hl,de ;/ -great1: - bit 7,h ;/ h negative? - ld hl,0 ; hl <-- false - jr z,great2 - inc l ;/ hl <-- true -great2: - jhpush -; -; - defb 83h ; ROT ( n1 n2 n3 --- n2 n3 n1) - defc 'ROT' - defw great-4 -rot: - defw $+2 - pop de ; de <-- n3 - pop hl ; hl <-- n2 - ex (sp),hl ; s1 <-- n2, hl <-- n1 - jp dpush ; s2 <-- n3, s3 <-- n1 -; -; - defb 85h ; SPACE - defc 'SPACE' - defw rot-6 -space: - defw docol - defw bl - defw emit - defw semis -; -; - defb 84h ; -DUP - defc '-DUP' - defw space-8 -ddup: - defw $+2 ;/ - ldw hl,(sp+0) ;/ - ld a,h ;/ - or l ;/ hl = 0? - jr z,ddup1 ;/ yes, don't dup - push hl ;/ -ddup1: - jnext -; -; - defb 88h ; TRAVERSE - defc 'TRAVERSE' - defw ddup-7 -trav: - defw docol - defw swap -trav1: - defw over ; begin - defw plus - defw lit - defw 7fh - defw over - defw cat - defw less - defw zbran ; until - defw trav1-$ - defw swap - defw drop - defw semis -; -; - defb 86h ; LATEST - defc 'LATEST' - defw trav-0bh -lates: - defw docol - defw curr - defw at - defw at - defw semis -; -; - defb 83h ; LFA - defc 'LFA' - defw lates-9 -lfa: - defw $+2 - pop hl ;/ hl <-- pfa - subw hl,4 ;/ - jhpush ;/ s1 <-- lfa -; -; - defb 83h ; CFA - defc 'CFA' - defw lfa-6 -cfa: - defw docol - defw twomin ;/ - defw semis -; -; - defb 83h ; NFA - defc 'NFA' - defw cfa-6 -nfa: - defw docol - defw lit - defw 5 - defw subb - defw lit - defw -1 - defw trav - defw semis -; -; - defb 83h ; PFA - defc 'PFA' - defw nfa-6 -pfa: - defw docol - defw one - defw trav - defw lit - defw 5 - defw plus - defw semis -; -; - defb 84h ; !CSP - defc '!CSP' - defw pfa-6 -scsp: - defw docol - defw spat - defw cspp - defw store - defw semis -; -; - defb 86h ; ?ERROR - defc '?ERROR' - defw scsp-7 -qerr: - defw docol - defw swap - defw zbran ; if - defw qerr1-$ - defw error - defw bran ; else - defw qerr2-$ -qerr1: - defw drop ; endif -qerr2: - defw semis -; -; - defb 85h ; ?COMP - defc '?COMP' - defw qerr-9 -qcomp: - defw docol - defw state - defw at - defw zequ - defw lit - defw 11h - defw qerr - defw semis -; -; - defb 85h ; ?EXEC - defc '?EXEC' - defw qcomp-8 -qexec: - defw docol - defw state - defw at - defw lit - defw 12h - defw qerr - defw semis -; -; - defb 86h ; ?PAIRS - defc '?PAIRS' - defw qexec-8 -qpair: - defw docol - defw subb - defw lit - defw 13h - defw qerr - defw semis -; -; - defb 84h ; ?CSP - defc '?CSP' - defw qpair-9 -qcsp: - defw docol - defw spat - defw cspp - defw at - defw subb - defw lit - defw 14h - defw qerr - defw semis -; -; - defb 88h ; ?LOADING - defc '?LOADING' - defw qcsp-7 -qload: - defw docol - defw blk - defw at - defw zequ - defw lit - defw 16h - defw qerr - defw semis -; -; - defb 87h ; COMPILE - defc 'COMPILE' - defw qload-0bh -comp: - defw docol - defw qcomp - defw fromr - defw dup - defw twop - defw tor - defw at - defw comma - defw semis -; -; - defb 0c1h ; [ - defc '[' - defw comp-0ah -lbrac: - defw docol - defw zero - defw state - defw store - defw semis -; -; - defb 81h ; ] - defc ']' - defw lbrac-4 -rbrac: - defw docol - defw lit,0c0h - defw state,store - defw semis -; -; - defb 86h ; SMUDGE - defc 'SMUDGE' - defw rbrac-4 -smudg: - defw docol - defw lates - defw lit - defw 20h - defw toggl - defw semis -; -; - defb 83h ; HEX - defc 'HEX' - defw smudg-9 -hex: - defw docol - defw lit - defw 10h - defw base - defw store - defw semis -; -; - defb 87h ; DECIMAL - defc 'DECIMAL' - defw hex-6 -dec: - defw docol - defw lit - defw 0ah - defw base - defw store - defw semis -; -; - defb 87h ; (;CODE) - defc '(;CODE)' - defw dec-0ah -pscod: - defw docol - defw fromr - defw lates - defw pfa - defw cfa - defw store - defw semis -; -; - defb 0c5h ; ;CODE - defc ';CODE' - defw pscod-0ah -semic: - defw docol - defw qcsp - defw comp - defw pscod - defw lbrac -semi1: - defw noop ; assembler - defw semis -; -; - defb 87h ; - defc 'DOES>' - defw build-0ah -does: - defw docol - defw fromr - defw lates - defw pfa - defw store - defw pscod -dodoe: - ld hl,(rpp) - dec hl - dec hl - ldw (hl),bc ;/ - ld (rpp),hl - inc de - ex de,hl - ldw bc,(hl) ;/ - inc hl - inc hl - jhpush -; -; - defb 85h ; COUNT - defc 'COUNT' - defw does-8 -count: - defw docol - defw dup - defw onep - defw swap - defw cat - defw semis -; -; - defb 84h ; TYPE - defc 'TYPE' - defw count-8 -type: - defw docol - defw ddup - defw zbran ; if - defw type1-$ - defw over - defw plus - defw swap - defw xdo ; do -type2: - defw ido - defw cat - defw emit - defw xloop ; loop - defw type2-$ - defw bran ; else - defw type3-$ -type1: - defw drop ; endif -type3: - defw semis -; -; - defb 89h ; -TRAILING - defc '-TRAILING' - defw type-7 -dtrai: - defw docol - defw dup - defw zero - defw xdo ; do -dtra1: - defw tdup ;/ - defw plus - defw onemin ;/ - defw cat - defw bl - defw subb - defw zbran ; if - defw dtra2-$ - defw leave - defw bran ; else - defw dtra3-$ -dtra2: - defw onemin ;/ -dtra3: - defw xloop ; loop - defw dtra1-$ - defw semis -; -; - defb 84h ; (.") - defc '(.")' - defw dtrai-0ch -pdotq: - defw docol - defw rr - defw count - defw dup - defw onep - defw fromr - defw plus - defw tor - defw type - defw semis -; -; - defb 0c2h ; ." - defc '."' - defw pdotq-7 -dotq: - defw docol - defw lit - defw 22h - defw state - defw at - defw zbran ; if - defw dotq1-$ - defw comp - defw pdotq - defw word - defw here - defw cat - defw onep - defw allot - defw bran ; else - defw dotq2-$ -dotq1: - defw word - defw here - defw count - defw type ; endif -dotq2: - defw semis -; -; - defb 86h ; EXPECT - defc 'EXPECT' - defw dotq-5 -expec: - defw docol - defw over - defw plus - defw over - defw xdo ; do -expe1: - defw key - defw dup - defw lit - defw 0eh - defw porig - defw at - defw equal - defw zbran ; if - defw expe2-$ - defw drop - defw dup - defw ido - defw equal - defw dup - defw fromr - defw twomin ;/ - defw plus - defw tor - defw zbran ; if - defw expe6-$ - defw lit - defw bell - defw bran ; else - defw expe7-$ -expe6: - defw lit - defw bsout ; endif -expe7: - defw bran ; else - defw expe3-$ -expe2: - defw dup - defw lit - defw acr ;/ - defw equal - defw zbran ; if - defw expe4-$ - defw leave - defw drop - defw bl - defw zero - defw bran ; else - defw expe5-$ -expe4: - defw dup ; endif -expe5: - defw ido - defw cstor - defw zero - defw ido - defw onep - defw store ; endif -expe3: - defw emit - defw xloop ; loop - defw expe1-$ - defw drop - defw semis -; -; - defb 85h ; QUERY - defc 'QUERY' - defw expec-9 -query: - defw docol - defw tib - defw at - defw lit - defw 50h - defw expec - defw zero - defw inn - defw store - defw semis -; -; - defb 0c1h ; NULL - defb 80h - defw query-8 -null: - defw docol - defw blk - defw at - defw zbran ; if - defw null1-$ - defw one - defw blk - defw pstor - defw zero - defw inn - defw store - defw blk - defw at - defw bscr - defw onemin ;/ - defw andd - defw zequ - defw zbran ; if - defw null2-$ - defw qexec - defw fromr - defw drop ; endif -null2: - defw bran ; else - defw null3-$ -null1: - defw fromr - defw drop ; endif -null3: - defw semis -; - defb 84h ; FILL - defc 'FILL' - defw null-4 -fill: - defw $+2 - exx ;/ save ip - pop de ;/ e <-- byte - pop bc ; bc <-- quantity - pop hl ;/ hl <-- address -fill1: - ld a,b - or c ; qty == 0? - jr z,fill2 ; yes, nothing (more) to fill - ld (hl),e ;/ (hl) <-- byte - inc hl ; inc pointer - dec bc ; dec counter - jp fill1 ;/ -fill2: - exx ;/ restore ip - jnext -; -; - defb 85h ; ERASE - defc 'ERASE' - defw fill-7 -erasee: - defw docol - defw zero - defw fill - defw semis -; -; - defb 86h ; BLANKS - defc 'BLANKS' - defw erasee-8 -blank: - defw docol - defw bl - defw fill - defw semis -; -; - defb 84h ; HOLD - defc 'HOLD' - defw blank-9 -hold: - defw docol - defw lit - defw -1 - defw hld - defw pstor - defw hld - defw at - defw cstor - defw semis -; -; - defb 83h ; PAD - defc 'PAD' - defw hold-7 -pad: - defw docol - defw here - defw lit - defw 44h - defw plus - defw semis -; -; - defb 84h ; WORD - defc 'WORD' - defw pad-6 -word: - defw docol - defw blk - defw at - defw zbran ; if - defw word1-$ - defw blk - defw at - defw block - defw bran ; else - defw word2-$ -word1: - defw tib - defw at ; endif -word2: - defw inn - defw at - defw plus - defw swap - defw encl - defw here - defw lit - defw 22h - defw blank - defw inn - defw pstor - defw over - defw subb - defw tor - defw rr - defw here - defw cstor - defw plus - defw here - defw onep - defw fromr - defw cmove - defw semis -; -; - defb 88h ; (NUMBER) - defc '(NUMBER)' - defw word-7 -pnumb: - defw docol -pnum1: - defw onep ; begin - defw dup - defw tor - defw cat - defw base - defw at - defw digit - defw zbran ; while - defw pnum2-$ - defw swap - defw base - defw at - defw ustar - defw drop - defw rot - defw base - defw at - defw ustar - defw dplus - defw dpl - defw at - defw onep - defw zbran ; if - defw pnum3-$ - defw one - defw dpl - defw pstor ; endif -pnum3: - defw fromr - defw bran ; repeat - defw pnum1-$ -pnum2: - defw fromr - defw semis -; -; - defb 86h ; NUMBER - defc 'NUMBER' - defw pnumb-0bh -numb: - defw docol - defw zero - defw zero - defw rot - defw dup - defw onep - defw cat - defw lit - defw 2dh - defw equal - defw dup - defw tor - defw plus - defw lit - defw -1 -numb1: - defw dpl ; begin - defw store - defw pnumb - defw dup - defw cat - defw bl - defw subb - defw zbran ; while - defw numb2-$ - defw dup - defw cat - defw lit - defw 2eh - defw subb - defw zero - defw qerr - defw zero - defw bran ; repeat - defw numb1-$ -numb2: - defw drop - defw fromr - defw zbran ; if - defw numb3-$ - defw dminu ; endif -numb3: - defw semis -; -; - defb 85h ; -FIND (0-3) SUCCESS - defc '-FIND' ; (0-1) FAILURE - defw numb-9 -dfind: - defw docol - defw bl - defw word - defw here - defw cont - defw at - defw at - defw pfind - defw dup - defw zequ - defw zbran ; if - defw dfin1-$ - defw drop - defw here - defw lates - defw pfind ; endif -dfin1: - defw semis -; -; - defb 87h ; (ABORT) - defc '(ABORT)' - defw dfind-8 -pabor: - defw docol - defw abort - defw semis -; - defb 85h ; ERROR - defc 'ERROR' - defw pabor-0ah -error: - defw docol - defw warn - defw at - defw zless - defw zbran ; if - defw erro1-$ - defw pabor ; endif -erro1: - defw here - defw count - defw type - defw pdotq - defb 2 - db '? ' - defw mess - defw spsto -; CHANGE FROM fig MODEL -; defw inn,at,blk,at - defw blk,at - defw ddup - defw zbran,erro2-$ ; if - defw inn,at - defw swap ; endif -erro2: - defw quit -; -; - defb 83h ; ID. - defc 'ID.' - defw error-8 -iddot: - defw docol - defw pad - defw lit - defw 20h - defw blank ;/ - defw dup - defw pfa - defw lfa - defw over - defw subb - defw dup ;/ change frm MODEL - defw tor ;/ to suppress BIT 7 - defw pad - defw swap - defw cmove - defw pad - defw fromr ;/ for terminals - defw pad ;/ with an 8 bit - defw plus ;/ ASCII character set. - defw onemin ;/ - defw dup ;/ - defw at ;/ - defw lit ;/ - defw 7fh ;/ - defw andd ;/ - defw swap ;/ - defw store ;/ - defw count - defw lit - defw 1fh ; WIDTH - defw andd - defw type - defw space - defw semis -; - defb 86h ; CREATE - defc 'CREATE' - defw iddot-6 -creat: - defw docol - defw dfind - defw zbran ; if - defw crea1-$ - defw drop - defw nfa - defw iddot - defw lit - defw 4 - defw mess - defw space ; endif -crea1: - defw here - defw dup - defw cat - defw width - defw at - defw min - defw onep - defw allot - defw dup - defw lit - defw 0a0h - defw toggl - defw here - defw onemin - defw lit - defw 80h - defw toggl - defw lates - defw comma - defw curr - defw at - defw store - defw here - defw twop - defw comma - defw semis -; -; - defb 0c9h ; [COMPILE] - defc '[COMPILE]' - defw creat-9 -bcomp: - defw docol - defw dfind - defw zequ - defw zero - defw qerr - defw drop - defw cfa - defw comma - defw semis -; -; - defb 0c7h ; LITERAL - defc 'LITERAL' - defw bcomp-0ch -liter: - defw docol - defw state - defw at - defw zbran ; if - defw lite1-$ - defw comp - defw lit - defw comma ; endif -lite1: - defw semis -; -; - defb 0c8h ; DLITERAL - defc 'DLITERAL' - defw liter-0ah -dlite: - defw docol - defw state - defw at - defw zbran ; if - defw dlit1-$ - defw swap - defw liter - defw liter ; endif -dlit1: - defw semis -; -; - defb 86h ; ?STACK - defc '?STACK' - defw dlite-0bh -qstac: - defw docol - defw spat - defw szero - defw at - defw swap - defw uless - defw one - defw qerr - defw spat - defw here - defw lit - defw 80h - defw plus - defw uless - defw lit - defw 7 - defw qerr - defw semis -; -; - defb 89h ; INTERPRET - defc 'INTERPRET' - defw qstac-9 -inter: - defw docol -inte1: - defw dfind ; begin - defw zbran ; if - defw inte2-$ - defw state - defw at - defw less - defw zbran ; if - defw inte3-$ - defw cfa - defw comma - defw bran ; else - defw inte4-$ -inte3: - defw cfa - defw exec ; endif -inte4: - defw qstac - defw bran ; else - defw inte5-$ -inte2: - defw here - defw numb - defw dpl - defw at - defw onep - defw zbran ; if - defw inte6-$ - defw dlite - defw bran ; else - defw inte7-$ -inte6: - defw drop - defw liter ; endif -inte7: - defw qstac ; endif -inte5: - defw bran ; again - defw inte1-$ -; -; - defb 89h ; IMMEDIATE - defc 'IMMEDIATE' - defw inter-0ch -immed: - defw docol - defw lates - defw lit - defw 40h - defw toggl - defw semis -; -; - defb 8ah ; VOCABULARY - defc 'VOCABULARY' - defw immed-0ch -vocab: - defw docol - defw build - defw lit - defw 0a081h - defw comma - defw curr - defw at - defw cfa - defw comma - defw here - defw vocl - defw at - defw comma - defw vocl - defw store - defw does -dovoc: - defw twop - defw cont - defw store - defw semis -; -; - defb 0c5h ; FORTH - defc 'FORTH' - defw vocab-0dh -forth: - defw dodoe - defw dovoc - defw 0a081h - defw task-7 ; cold start value only -; changed aech time a def is appended -; to the FORTH vocabulary - defw 0 ; end of vocabulary list -; -; - defb 8bh ; DEFINITIONS - defc 'DEFINITIONS' - defw forth-8 -defin: - defw docol - defw cont - defw at - defw curr - defw store - defw semis -; -; - defb 0c1h ; ( - defc '(' - defw defin-0eh -paren: - defw docol - defw lit - defw 29h - defw word - defw semis -; -; - defb 84h ; QUIT - defc 'QUIT' - defw paren-4 -quit: - defw docol - defw zero - defw blk - defw store - defw lbrac -quit1: - defw rpsto ; begin - defw cr - defw query - defw inter - defw state - defw at - defw zequ - defw zbran ; if - defw quit2-$ - defw pdotq - defb 2 - db 'ok' ; endif -quit2: - defw bran ; again - defw quit1-$ -; -; - defb 85h ; ABORT - defc 'ABORT' - defw quit-7 -abort: - defw docol - defw spsto - defw dec - defw qstac - defw cr - defw dotcpu - defw pdotq - defb 0eh ; count of chrs to follow - db 'fig-FORTH ' - defb figrel+30h,adot,figrev+30h,usrver - defw forth - defw defin - defw quit -; -; -wrm: ld bc,wrm1 - jnext -wrm1: defw warm -; -; - defb 84h ; WARM - defc 'WARM' - defw abort-8 -warm: - defw docol - defw mtbuf - defw abort -; -; -cld: - ld hl,(bdoss+1) ;/ - ld l,0 ;/ hl <-- fbase - ld (limit+2),hl ;/ set limit - ld de,bufsiz ;/ de <-- total disc buffer size - subw hl,de ;/ hl <-- addr. of 1st disc buffer - ld (first+2),hl ;/ set FIRST - ld (use+2),hl ;/ set USE - ld (prev+2),hl ;/ set PREV - ld (buf1),hl ;/ - ld de,us ;/ de <-- user variable space - subw hl,de ;/ hl <-- initr0 - ld (upinit),hl ;/ - ld (r0init),hl ;/ - ld (up),hl ;/ - ld (rpp),hl ;/ - ld de,rts ;/ de <-- rtn stack & term. buf space - subw hl,de ;/ hl <-- inits0 - ld (s0init),hl ;/ - ld (tibini),hl ;/ - ld sp,hl ;/ - ld bc,cld1 - ld ix,next ; pointer to next - ld iy,hpush ; pointer to hpush - jnext -; -; -cld1: defw cold -; - defb 84h ; COLD - defc 'COLD' - defw warm-7 -cold: - defw docol - defw mtbuf - defw one,recadr ; AvdH - defw store - defw lit,buf1 - defw at ;/ - defw use,store - defw lit,buf1 - defw at ;/ - defw prev,store - defw drzer - defw zero ;/ - defw lit,eprint - defw cstor ;/ -; - defw lit - defw orig+12h - defw lit - defw up - defw at - defw lit - defw 6 - defw plus - defw lit - defw 10h - defw cmove - defw lit - defw orig+0ch - defw at - defw lit - defw forth+6 - defw store - defw fcb ;/A - defw lit,opnfil ;/A open mass storage - defw bdos ;/A - defw lit,0ffh ;/A - defw equal ;/A file present? - defw zbran,cld2-$ ;/A - defw zero ;/A - defw warn,store ;/A - defw cr,pdotq ;/A - defb 7 ;/A - db 'No file' ;/A -cld2: - defw abort -; -; - defb 84h ; S->D - defc 'S->D' - defw cold-7 -stod: defw $+2 - pop hl ;/ - exts hl ;/ de <-- h(7) - ex de,hl ;/ - jp dpush ; ( n1 -- d1L d1H) -; -; - defb 82h ; +- - defc '+-' - defw STOD-7 -pm: - defw docol - defw zless - defw zbran ; if - defw pm1-$ - defw minus ; endif -pm1: - defw semis -; -; - defb 83h ; D+- - defc 'D+-' - defw pm-5 -dpm: - defw docol - defw zless - defw zbran ; if - defw dpm1-$ - defw dminu ; endif -dpm1: - defw semis -; -; - defb 83h ; ABS - defc 'ABS' - defw dpm-6 -abs: - defw docol - defw dup - defw pm - defw semis -; -; - defb 84h ; DABS - defc 'DABS' - defw abs-6 -dabs: - defw docol - defw dup - defw dpm - defw semis -; -; - defb 83h ; MIN - defc 'MIN' - defw dabs-7 -min: - defw docol - defw tdup - defw great - defw zbran ; if - defw min1-$ - defw swap ; endif -min1: - defw drop - defw semis -; -; - defb 83h ; MAX - defc 'MAX' - defw min-6 -max: defw docol - defw tdup - defw less - defw zbran ; if - defw max1-$ - defw swap ; endif -max1: - defw drop - defw semis -; -; - defb 82h ; M* ( n1 n2 --- d) - defc 'M*' - defw max-6 -mstar: - defw $+2 ;/ - pop de ; de <-- multiplicator - pop hl ; hl <-- multiplicant - multw hl,de ;/ dehl <-- hl * de - ex de,hl ;/ - jp dpush ;/ ( n1 n2 --- d1l d1h) -; -; - defb 82h ;/ M/ ( d n1 --- nrem nquot) - defc 'M/' - defw mstar-5 -mslas: - defw $+2 ; ( d n1 --- n2 n3) - exx ; save ip - pop hl ; divisor - ld a,h - and 80h ; filter sign - jr z,mslas1 ; positive - neg hl ; make positive -mslas1: - ld b,h - ld c,l ; bc <-- divisor - pop hl ; dividend.hw - pop de ; dividend.lw - bit 7,h ; negative? - jr z,mslas2 ; no - inc a ; dividend sign flag - push hl - ld hl,0 - subw hl,de ; neg dividend.lw - pop de ; dividend.hw - push hl - ld hl,0 - sbc hl,de ; neg dividend.hw - pop de ; dividend.lw -mslas2: - cpw hl,bc ; dividend.hw >= divisor - jr c,mslas3 ; no overflow, continue - ld hl,0ffffh - ld d,h - ld e,l ; set rem & quot to max. - jr mslas5 -; -mslas3: - ex de,hl ; dehl <-- dividend.hw,lw - divuw dehl,bc ; de <-- remainder, hl <-- quotient - ex de,hl ; hl <-- remainder - bit 0,a ; was dividend negative - jr z,mslas4 ; no - neg hl ;/ yes, negate remainder -mslas4: - ex de,hl ; hl <-- quotient - or a - jr z,mslas5 ; neither operand negative - cp 81h ; both operands negative? - jr z,mslas5 ; yes, quotient stays positive - neg hl ;/ no, negate quotient -mslas5: - push de ; remainder - push hl ; quotient - exx ; restore ip - jnext -; -; - defb 81h ; * ( n1 n2 --- nproduct) - defc '*' - defw mslas-5 -star: - defw $+2 - pop de - pop hl - multw hl,de ;/ dehl <-- product - jhpush -; -; - defb 84h ; /MOD ( n1 n2 --- nrem nquot) - defc '/MOD' - defw star-4 -slmod: - defw $+2 - exx ;/ save ip - pop bc ;/ divisor - pop hl ; dividend - ld a,b - or c ;/ div by 0? - jr nz,slmod1 ;/ no, continue - ld de,0ffffh - ld h,d - ld l,e ;/ set remainder & quotient to max. - jr slmod3 -slmod1: - cpw hl,8000h ;/ special case -32768 -1 / - jr nz,slmod2 ;/ continue - ld a,b - cp 0ffh - jr nz,slmod2 - cp c ;/ lo byte also 0ffh? - jr nz,slmod2 ;/ no, go & divide - ld de,0 ;/ remainder - jr slmod3 ;/ exit with dividend unchanged -slmod2: - exts hl ;/ de <-- dividend.hw - divw dehl,bc ;/ de <-- remainder, hl <-- quotient -slmod3: - push de - push hl - exx ;/ restore ip - jnext -; -; - defb 81h ; / - defc '/' - defw slmod-7 -slash: - defw $+2 - exx ;/ save ip - pop bc ;/ divisor - pop hl ; dividend - ld a,b - or c ;/ division by 0? - jr nz,slash1 ;/ no, continue - ld hl,0ffffh ;/ set quotient to max. - jr slash3 -slash1: - cpw hl,8000h ;/ special case -32768 -1 / - jr nz,slash2 ;/ dividend not -32768 - ld a,b - cp 0ffh - jr nz,slash2 ;/ divisor not -1 - cp c - jr z,slash3 ;/ return with dividend unchanged -slash2: - exts hl ;/ de <-- dividend.hw - divw dehl,bc ;/ hl <-- quotient -slash3: - push hl ;/ quotient - exx ;/ restore ip - jnext -; -; - defb 83h ;/ MOD - defc 'MOD' - defw slash-4 -modd: - defw $+2 - exx ; save ip - pop bc ; divisor - pop hl ; dividend - ld a,b - or c ; division by 0? - jr nz,modd1 ; no, continue - ld de,0ffffh ; set remainder to max - jr modd3 -modd1: - cpw hl,8000h ;/ special case -32768 -1 / - jr nz,modd2 ; dividend not -32768 - ld a,b - cp 0ffh - jr nz,modd2 ; divisor not -1 - cp c - jr nz,modd2 ; go & divide - ld de,0 ; remainder - jr modd3 -modd2: - exts hl ; de <-- dividend.hw - divw dehl,bc ; de <-- remainder -modd3: - push de ; remainder - exx ; restore ip - jnext -; -; - defb 85h ;/ */MOD - defc '*/MOD' - defw modd-6 -ssmod: - defw $+2 - exx ; save ip - pop hl ; divisor - ld a,h - and 80h ; filter sign - jr z,ssmod1 ; positive - neg hl ; make positive -ssmod1: - ld b,h - ld c,l ; bc <-- divisor - pop hl ; multipicator - pop de ; multiplicant - ex af,af' ; save sign flag - multw hl,de ; dehl <-- product (= dividend) - ex af,af' ; restore sign flag - ex de,hl ; de <-- dividend.lw - bit 7,h ; dividend negative? - jr z,ssmod2 ; no - inc a ; dividend sign flag - push hl - ld hl,0 - subw hl,de ; neg dividend.lw - pop de ; dividend.hw - push hl - ld hl,0 - sbc hl,de ; neg dividend.hw - pop de ; dividend.lw -ssmod2: - cpw hl,bc ; dividend.hw >= divisor? - jr c,ssmod3 ; no overflow, continue - ld hl,0ffffh - ld d,h - ld e,l ; set rem & quot to max - jr ssmod5 -; -ssmod3: - ex de,hl ; dehl <-- dividend.hw,lw - divuw dehl,bc ; de <-- remainder, hl <-- quotient - ex de,hl ; hl <-- remainder - bit 0,a ; was dividend negative? - jr z,ssmod4 ; no - neg hl ; yes, negate remainder -ssmod4: - ex de,hl ; hl <-- quotient - or a - jr z,ssmod5 ; neither operand negative - cp 81h ; both operands negative? - jr z,ssmod5 ; yes, quotient stays positive - neg hl ; no, negate quotient -ssmod5: - push de ; remainder - push hl ; quotient - exx ; restore ip - jnext -; -; - defb 82h ; */ - defc '*/' - defw ssmod-8 -ssla: - defw $+2 ;/ - exx ; save ip - pop hl ; divisor - ld a,h - and 80h ; filter sign - jr z,ssla1 ; positive - neg hl ; make positive -ssla1: - ld b,h - ld c,l ; bc <-- divisor - pop hl ; multipicator - pop de ; multiplicant - ex af,af' ; save sign flag - multw hl,de ; dehl <-- product (= dividend) - ex af,af' ; restore sign flag - ex de,hl ; de <-- dividend.lw - bit 7,h ; dividend negative? - jr z,ssla2 ; no - inc a ; dividend sign flag - push hl - ld hl,0 - subw hl,de ; neg dividend.lw - pop de ; dividend.hw - push hl - ld hl,0 - sbc hl,de ; neg dividend.hw - pop de ; dividend.lw -ssla2: - cpw hl,bc ; dividend.hw >= divisor? - jr c,ssla3 ; no overflow, continue - ld hl,0ffffh ; set quotient to max - jr ssla4 -; -ssla3: - ex de,hl ; dehl <-- dividend.hw,lw - divuw dehl,bc ; de <-- remainder, hl <-- quotient - or a - jr z,ssla4 ; neither operand negative - cp 81h ; both operands negative? - jr z,ssla4 ; yes, quotient stays positive - neg hl ; no, negate quotient -ssla4: - push hl ; quotient - exx ; restore ip - jnext -; -; - defb 85h ; M/MOD - defc 'M/MOD' - defw ssla-5 -msmod: - defw docol - defw tor - defw zero - defw rr - defw uslas - defw fromr - defw swap - defw tor - defw uslas - defw fromr - defw semis -; -; -; Block moved down 2 pages -; - defb 86h ; (LINE) - defc '(LINE)' - defw msmod-8 -pline: - defw docol - defw tor - defw lit - defw 40h - defw bbuf - defw ssmod - defw fromr - defw bscr - defw star - defw plus - defw block - defw plus - defw lit - defw 40h - defw semis -; -; - defb 85h ; .LINE - defc '.LINE' - defw pline-9 -dline: - defw docol - defw pline - defw dtrai - defw type - defw semis -; -; - defb 87h ; MESSAGE - defc 'MESSAGE' - defw dline-8 -mess: - defw docol - defw warn - defw at - defw zbran ; if - defw mess1-$ - defw ddup - defw zbran ; if - defw mess2-$ - defw lit - defw 4 ; 1st message screen - defw ofset - defw at - defw bscr - defw slash - defw subb - defw dline - defw space ; endif -mess2: - defw bran ; else - defw mess3-$ -mess1: - defw pdotq - defb 6 - db 'MSG # ' - defw dot ; endif -mess3: defw semis -; -; - defb 82h ; P@ - defc 'P@' - defw mess-0ah -ptat: - defw $+2 - exx ;d save registers - pop bc ;d bc <-- port# - in l,(c) ;d l <-- data byte - ld h,0 - push hl - exx ;d restore registers - jnext -; -; - defb 82h ; P! - defc 'P!' - defw ptat-5 -ptsto: - defw $+2 - exx ;d save registers - pop bc ;d c <-- port# - pop hl ;d L <-- date byte - out (c),l - exx ;d restore registers - jnext -; -; - page -include DISCIO.Z80 - page -include CONPRTIO.Z80 - page -; - defb 0c1h ; ' (tick) - defb 0a7h - defw arrow-6 -tick: - defw docol - defw dfind - defw zequ - defw zero - defw qerr - defw drop - defw liter - defw semis -; -; - defb 86h ; FORGET - defc 'FORGET' - defw tick-4 -forg: - defw docol - defw curr - defw at - defw cont - defw at - defw subb - defw lit - defw 18h - defw qerr - defw tick - defw dup - defw fence - defw at - defw uless ;/ FORGET >8000h nw o.k. - defw lit - defw 15h - defw qerr - defw dup - defw nfa - defw dp - defw store - defw lfa - defw at - defw cont - defw at - defw store - defw semis -; -; - defb 84h ; BACK - defc 'BACK' - defw forg-9 -back: - defw docol - defw here - defw subb - defw comma - defw semis -; -; - defb 0c5h ; BEGIN - defc 'BEGIN' - defw back-7 -begin: - defw docol - defw qcomp - defw here - defw one - defw semis -; -; - defb 0c5h ; ENDIF - defc 'ENDIF' - defw begin-8 -endiff: - defw docol - defw qcomp - defw two - defw qpair - defw here - defw over - defw subb - defw swap - defw store - defw semis -; -; - defb 0c4h ; THEN - defc 'THEN' - defw endiff-8 -then: defw docol - defw endiff - defw semis -; -; - defb 0c2h ; DO - defc 'DO' - defw then-7 -do: - defw docol - defw comp - defw xdo - defw here - defw three - defw semis -; -; - defb 0c4h ; LOOP - defc 'LOOP' - defw do-5 -loop: - defw docol - defw three - defw qpair - defw comp - defw xloop - defw back - defw semis -; -; - defb 0c5h ; +LOOP - defc '+LOOP' - defw loop-7 -ploop: - defw docol - defw three - defw qpair - defw comp - defw xploo - defw back - defw semis -; -; - defb 0c5h ; UNTIL - defc 'UNTIL' - defw ploop-8 -until: - defw docol - defw one - defw qpair - defw comp - defw zbran - defw back - defw semis -; -; - defb 0c3h ; END - defc 'END' - defw until-8 -endd: - defw docol - defw until - defw semis -; -; - defb 0c5h ; AGAIN - defc 'AGAIN' - defw endd-6 -again: - defw docol - defw one - defw qpair - defw comp - defw bran - defw back - defw semis -; -; - defb 0c6h ; REPEAT - defc 'REPEAT' - defw again-8 -repea: - defw docol - defw tor - defw tor - defw again - defw fromr - defw fromr - defw twomin ;/ - defw endiff - defw semis -; -; - defb 0c2h ; IF - defc 'IF' - defw repea-9 -iff: - defw docol - defw comp - defw zbran - defw here - defw zero - defw comma - defw two - defw semis -; -; - defb 0c4h ; ELSE - defc 'ELSE' - defw iff-5 -elsee: - defw docol - defw two - defw qpair - defw comp - defw bran - defw here - defw zero - defw comma - defw swap - defw two - defw endiff - defw two - defw semis -; -; - defb 0c5h ; WHILE - defc 'WHILE' - defw elsee-7 -while: - defw docol - defw iff - defw twop - defw semis -; -; - defb 86h ; SPACES - defc 'SPACES' - defw while-8 -spacs: - defw docol - defw zero - defw max - defw ddup - defw zbran ; if - defw spax1-$ - defw zero - defw xdo ; do -spax2: - defw space - defw xloop ; loop endif - defw spax2-$ -spax1: - defw semis -; -; - defb 82h ; <# - defc '<#' - defw spacs-9 -bdigs: - defw docol - defw pad - defw hld - defw store - defw semis -; -; - defb 82h ; #> - defc '#>' - defw bdigs-5 -edigs: - defw docol - defw drop - defw drop - defw hld - defw at - defw pad - defw over - defw subb - defw semis -; -; - defb 84h ; SIGN - defc 'SIGN' - defw edigs-5 -sign: - defw docol - defw rot - defw zless - defw zbran ; if - defw sign1-$ - defw lit - defw 2dh - defw hold ; endif -sign1: - defw semis -; -; - defb 81h ; # - defc '#' - defw sign-7 -dig: - defw docol - defw base - defw at - defw msmod - defw rot - defw lit - defw 9 - defw over - defw less - defw zbran ; if - defw dig1-$ - defw lit - defw 7 - defw plus ; endif -dig1: defw lit - defw 30h - defw plus - defw hold - defw semis -; -; - defb 82h ; #S - defc '#S' - defw dig-4 -digs: - defw docol -digs1: - defw dig ; begin - defw tdup ;/ - defw orr - defw zequ - defw zbran ; until - defw digs1-$ - defw semis -; -; - defb 83h ; D.R - defc 'D.R' - defw digs-5 -ddotr: - defw docol - defw tor - defw swap - defw over - defw dabs - defw bdigs - defw digs - defw sign - defw edigs - defw fromr - defw over - defw subb - defw spacs - defw type - defw semis -; -; - defb 82h ; .R - defc '.R' - defw ddotr-6 -dotr: - defw docol - defw tor - defw stod - defw fromr - defw ddotr - defw semis -; -; - defb 82h ; D. - defc 'D.' - defw dotr-5 -ddot: - defw docol - defw zero - defw ddotr - defw space - defw semis -; -; - defb 81h ; . - defc '.' - defw ddot-5 -dot: - defw docol - defw stod - defw ddot - defw semis -; -; - defb 81h ; ? - defc '?' - defw dot-4 -ques: - defw docol - defw at - defw dot - defw semis -; -; - defb 82h ; U. - defc 'U.' - defw ques-4 -udot: defw docol - defw zero - defw ddot - defw semis -; - - defb 85h ; VLIST - defc 'VLIST' - defw udot-5 -vlist: - defw docol - defw lit - defw 80h - defw outt - defw store - defw cont - defw at - defw at -vlis1: - defw outt ; begin - defw at - defw csll - defw great - defw zbran ; if - defw vlis2-$ - defw cr - defw zero - defw outt - defw store ; endif -vlis2: - defw dup - defw iddot - defw space - defw space - defw pfa - defw lfa - defw at - defw dup - defw zequ - defw qterm - defw orr - defw zbran ; until - defw vlis1-$ - defw drop - defw semis -; -; - defb 83h ; BYE - defc 'BYE' - defw vlist-8 -bye: - defw docol ;/A - defw flush ;/A - defw fcb,lit ;/E - defw 10h,bdos ;/E close file - defw drop ;/E discard directory code - defw zero,zero ;/A - defw bdos ;/A return to CP/M - defw semis ;/A won't get this far, just for pretty -; -; - defb 84h ; LIST - defc 'LIST' - defw bye-6 -list: - defw docol,dec - defw cr,dup - defw scr,store - defw pdotq - defb 6 - db 'SCR # ' - defw dot - defw lit,10h - defw zero,xdo -list1: - defw cr,ido - defw three ;/ was lit,3 - defw dotr,space - defw ido,scr - defw at,dline - defw qterm - defw zbran,list2-$ ; if - defw leave -list2: - defw xloop,list1-$ ; endif - defw cr - defw semis -; -; - defb 85H ;INDEX - defc 'INDEX' - defw list-7 -index: - defw docol - defw lit,ff - defw emit - defw cr - defw onep,swap - defw xdo -inde1: - defw cr,ido - defw three ;/ was lit,3 - defw dotr,space - defw zero,ido - defw dline,qterm - defw zbran,inde2-$ ; if - defw leave ; endif -inde2: - defw xloop,inde1-$ - defw semis -; -; - defb 85h ; TRIAD - defc 'TRIAD' - defw index-8 -triad: - defw docol - defw lit,ff - defw emit - defw three ;/ was lit,3 - defw slash - defw three ;/ was lit,3 - defw star - defw three ;/ was lit,3 - defw over,plus - defw swap,xdo -tria1: - defw cr,ido - defw list - defw qterm - defw zbran,tria2-$ ; if - defw leave -tria2: - defw xloop,tria1-$ ; endif - defw cr - defw lit,15 - defw mess,cr - defw semis -; -; - defb 84h ; .CPU - defc '.CPU' - defw triad-8 -dotcpu: - defw docol - defw base,at - defw lit,36 - defw base,store - defw lit,22h - defw porig,tat - defw ddot - defw base,store - defw semis -; -; - defb 86h ; setclk - defc 'setclk' - defw dotcpu-7 -setclk: - defw $+2 - exx ; save ip - ld c,iopreg - ldctl hl,(c) ; l <-- current i/o page - ld a,l - ex af,af' ; save i/o page - ld l,0feh - ldctl (c),hl ; select i/o page 0feh - xor a - out (cntrl0),a ; disable c/t 0 - out (cntrl1),a ; disable c/t 1 - out (config1),a - ld hl,0ffffh - ld a,10h - out (config0),a ; cascade c/t 0 - c/t 1 - ld c,tcon0 - outw (c),hl ; load c/t 0 time constant - ld c,tcon1 - outw (c),hl ; load c/t 1 time constatnt - ld a,80h - out (config1),a ; continous mode - ld a,0e0h - out (cntrl1),a ; start 32bit counter - ex af,af' ; std. accu - ld l,a ; l <-- previous i/o page - ld c,iopreg - ldctl (c),hl ; restore i/o page - exx ; restore ip - jnext -; -; - defb 86h ; getclk - defc 'getclk' - defw setclk-9 -getclk: - defw $+2 - exx ; save ip - ld c,iopreg - ldctl hl,(c) ; l <-- current i/o page - ld a,l - ex af,af' ; save current i/o page - ld l,0feh - ldctl (c),hl ; select i/o page 0feh - ld a,80h - out (cntrl1),a ; halt 32bit counter - ld c,count1 - inw hl,(c) - ld d,h - ld e,l ; de <-- count1 - ld c,count0 - inw hl,(c) ; hl <-- count0 - ld c,0 - ld a,c ; a <-- 0 - sub l ; 0 - l - ld l,a ; l <-- neg(l) - ld a,c ; a <-- 0 - sbc a,h - ld h,a ; h <-- neg(h) - ld a,c ; a <-- 0 - sbc a,e - ld e,a ; e <-- neg(e) - ld a,c ; a <-- 0 - sbc a,d - ld d,a ; d <-- neg(d), dehl <-- neg(dehl) - divuw dehl,25000 ; scale to 1/100 secs - push hl ; result - ex af,af' ; std. accu - ld l,a ; l <-- previous i/o page - ld c,iopreg - ldctl (c),hl ; restore i/o page - exx ; restore ip - jnext -; -; - defb 84h ; TASK - defc 'TASK' - defw getclk-9 -; defw dotcpu-7 -task: - defw docol - defw semis -; -; -initdp: - defw 0 -; - end orig - \ No newline at end of file diff --git a/software/CPM/CPM08_Z80FORTH/280FORTH.COM b/software/CPM/CPM08_Z80FORTH/280FORTH.COM deleted file mode 100644 index cbea682..0000000 Binary files a/software/CPM/CPM08_Z80FORTH/280FORTH.COM and /dev/null differ diff --git a/software/CPM/CPM08_Z80FORTH/280FORTH.HEX b/software/CPM/CPM08_Z80FORTH/280FORTH.HEX deleted file mode 100644 index 0ed4d36..0000000 --- a/software/CPM/CPM08_Z80FORTH/280FORTH.HEX +++ /dev/null @@ -1,215 +0,0 @@ -:2001000000C3891000C375100101610E761B080000000000000000001F000000811B811BDA -:20012000F40F180000F6000000000000D5E56069ED260303ED16EB13E9834C49D4000041FB -:20014000016069ED260303FDE987455845435554C539015501E1C33401864252414E43C89F -:20016000490164016069DDEDC64D44DDE987304252414E43C859017901E17DB428E6030341 -:20018000DDE986284C4F4F50A96D018D012A2801DD03ED1623237B967A239EFA64012322A0 -:2001A00028010303DDE987282B4C4F4F50A98201B201D12A28017E83775F237E8A77231483 -:2001C0001557FACD017B967A239EC3D2017E93237E9AFA6401232228010303DDE984284434 -:2001E0004FA9A601E601D12A28012B2BDDC12B2BED1E222801DDE981C9DD01FD012A280176 -:20020000DDC5DDE98544494749D4F7010E02E1D17BD6303814FE0A3806D607FE0A380ABD4F -:2002200030075F210100C32C016CFDE9862846494E44A904023702D1E1E51AAEE63F201F4A -:2002400023131AAE87201630F721050019E31B1AB7F24E025F1600210100C32C0138061394 -:200260001AB7F25F0213EBED167AB320CBE1210000FDE987454E434C4F53C52C027F02D1C9 -:20028000E1E57B571EFF2B231CBE28FB1600D5577EA7200816001CD51DD5DDE97A231CBE99 -:2002A000280A7EA720F61600D5D5DDE91600D51CD5DDE984454D49D47302D70510175C069C -:2002C0003F075005CF03834B45D9B302CE02C3FA16893F5445524D494E41CCC602DF0221FF -:2002E0000000C3EE168243D2D102EC02C3271785434D4F56C5E502F902D9C1D1E178B128E0 -:2003000002EDB0D9DDE9862D434D4F56C5EF021103D9C1D1E178B12808092BEB092BEBED1D -:20032000B8D9DDE98255AA06032B03D1E1EDD3EBC32C018255AF24033A03D9C1E1D1EDC777 -:20034000380721FFFF545D1803EBEDCBD5E5D9DDE983414EC433035903D1E17BA56F7AA4B0 -:2003600067FDE9824FD251036A03D1E17BB56F7AB467FDE983584FD263037C03D1E17BAD45 -:200380006F7AAC67FDE9835350C074038E0321000039FDE9835350A186039C032A260111FC -:2003A000060019ED36DDE9835250C09403AF032A2801FDE9835250A1A703BC032A2601113D -:2003C000080019ED26222801DDE9823BD3B403D1032A2801ED062323222801DDE9854C450A -:2003E0004156C5CA03E7032A2801ED162323ED1EDDE9823ED2DD03F9032A28012B2BDDC1C8 -:20040000222801DDE98252BEF2030C042A2801DDC52323222801DDE981D20504FD018230DC -:20042000BD18042504D1210000EDD720012CFDE983303CBE1E043804D1210000EDD72801E7 -:200440002CFDE98230BC30044A04F117210000CB15FDE98230BE43045A04D1210000EDD7E0 -:20046000F26704EA67042CFDE981AB53046F04D1E119FDE98244AB69047B04D9C1E1F1D177 -:20048000F519EBE1ED4AD5E5D9DDE9854D494E55D374049504E1ED4CFDE986444D494E554D -:2004A000D38B04A504D9D1C1210000EDCEE5210000ED52E5D9DDE9844F5645D29A04C0047F -:2004C000ED040200FDE98444524FD0B704CF043333DDE984535741D0C604DC04E1E3FDE9BD -:2004E000834455D0D304E804ED040000FDE984545543CBE004F704E1D1E5C32C01834E49BB -:20050000D0EE040505E1ED050000DDE9842D524FD4FD041505E1D1E3EBC32C018543535753 -:2005200041D00C052605E1EDEFFDE984504943CB1C053405E12939DDC5DDE984324455D07C -:200540002B054405E1D1D5E5C32C01822BA13B055205E1D17E8377237E8A77DDE986544F26 -:2005600047474CC54B056805D1E17EAB77DDE981C05D057505E1DDC5DDE98243C06F058127 -:2005800005E16E2600FDE98232C07A058E05E1ED162323DDC5D5DDE981A187059E05E1DDFF -:2005A000C1DDE98243A19805AA05E1D173DDE98232A1A305B605E1DDC12323DDC1DDE9C175 -:2005C000BAAF05D7059F095A096E07730561079C057B0E240A780A2A28012B2BED0E2228A9 -:2005E00001134B42DDE9C1BBBF05D705C909000ACF03390A160ACF03844E4F4FD0E605D793 -:2006000005CF0388434F4E5354414ED4F805D7057B0E390A2208780A13EBDDC5DDE98856FC -:2006200041524941424CC50306D7050E06780A13D5DDE984555345D21E06D7050E06780A48 -:2006400013EB6E2600DDEDD62601FDE981B033065206FDF50000DDE981B14C065E06FDF507 -:200660000100DDE981B258066A06FDF50200DDE981B364067606FDF50300DDE98242CC7023 -:20068000061806200083432FCC7C06180640008546495253D4850618060000854C494D498F -:2006A000D48F061806000085422F4255C69B061806800085422F5343D2A706180608008769 -:2006C0002B4F52494749CEB306D7053F0100016D04CF038253B0BF06400606008252B0D3A1 -:2006E0000640060800835449C2DC0640060A8557494454C8E50640060C875741524E494E7A -:20070000C7EE0640060E8546454E43C5F9064006108244D0060740061288564F432D4C49E2 -:200720004ECB11074006140083424CCB19074006168249CE2807400618834F55D43107403D -:20074000061A835343D2390740061C864F46465345D4420740061E87434F4E544558D44BFB -:20076000074006208743555252454ED457074006228553544154C564074006248442415367 -:20078000C57107400626834450CC7C0740062883464CC4860740062A834353D08F07400641 -:2007A0002C8252A3980740062E83484CC4A107400630008231ABA907BA07E123FDE982321D -:2007C000ABB307C507E12323FDE98231ADBE07D107E12BFDE98232ADCA07DC07E12B2BFDA3 -:2007E000E98232AAD507E807E129FDE98232AFE107F307E1CB7C280123CB2CCB1DFDE984F5 -:20080000484552C5EC07D70516077305CF0385414C4C4FD4FF07D70516075005CF0381AC2A -:200820000E08D70506089C0568061608CF038243AC1E08D7050608A8055C061608CF0381B8 -:20084000AD2E084508D1E1EDDEFDE981BD3F085108D1E1EDDE21000020012CFDE981BC4BCE -:20086000086308D1E17AACFA6C08EDDECB7C21000028012CFDE98255BC5D087D08D1E1ED35 -:20088000DE210000CB15FDE981BE76088E08E1D17AACFA9708EDDECB7C21000028012CFD4A -:2008A000E983524FD48808A908D1E1E3C32C018553504143C5A108D7058106BA02CF038402 -:2008C0002D4455D0AF08C808ED0400007CB52801E5DDE98854524156455253C5BF08D705EE -:2008E000DA04BE046D043F017F00BE047F0561087701F0FFDA04CD04CF03864C4154455392 -:20090000D4D308D7056E0773057305CF03834C46C1FA081509E1FDEDFE0400FDE983434660 -:20092000C10D09D705DA07CF03834E46C11D09D7053F01050043083F01FFFFDE08CF03836E -:200940005046C12909D7055C06DE083F0105006D04CF0384214353D03F09D7058C039E07FF -:200960009C05CF03863F4552524FD25309D705DA0477010800F90D62010400CD04CF03850A -:200980003F434F4DD06409D7057907730523043F0111006D09CF03853F455845C37F09D7A0 -:2009A00005790773053F0112006D09CF03863F50414952D39709D70543083F0113006D094C -:2009C000CF03843F4353D0AD09D7058C039E07730543083F0114006D09CF03883F4C4F4154 -:2009E00044494EC7C209D7052E07730523043F0116006D09CF0387434F4D50494CC5DB0948 -:200A0000D70587090A04E604C307F70373052208CF03C1DBF609D705500679079C05CF037A -:200A200081DD120AD7053F01C00079079C05CF0386534D554447C5200AD70503093F012030 -:200A4000006605CF03834845D8300AD7053F01100083079C05CF0387444543494D41CC45D3 -:200A60000AD7053F010A0083079C05CF038728203B434F4445A9570AD7050A0403094509D6 -:200A800023099C05CF03C53B434F44C56E0AD705C909000A780A160AFF05CF03873C42551A -:200AA000494C44D3860AD70550060E06CF0385444F4553BE9C0AD7050A04030945099C05E9 -:200AC000780A2A28012B2BED0E22280113EBED062323FDE985434F554ED4AE0AD705E6047C -:200AE000B807DA047F05CF0384545950C5D40AD705C60877011800BE046D04DA04E401FBB4 -:200B0000017F05BA028B01F8FF62010400CD04CF03892D545241494C494EC7E80AD705E6C3 -:200B2000045006E40142056D04CF077F058106430877010800E50362010400CF078B01E67B -:200B4000FFCF0384282E22A9110BD7051C04DC0AE604B8070A046D04F703EF0ACF03C22E44 -:200B6000A2430BD7053F0122007907730577011400000A4A0BCB0C06087F05B807160862BC -:200B8000010A00CB0C0608DC0AEF0ACF03864558504543D45E0BD705BE046D04BE04E401C6 -:200BA000CC02E6043F010E00C90673054F0877012800CD04E604FB014F08E6040A04DA070A -:200BC0006D04F70377010A003F010700620106003F01080062012800E6043F010D004F0817 -:200BE00077010E00E503CD048106500662010400E604FB01A8055006FB01B8079C05BA0271 -:200C00008B019EFFCD04CF038551554552D98D0BD705EB0673053F015000960B50063607CC -:200C20009C05CF03C180080CD7052E077305770128005C062E075005500636079C052E076E -:200C40007305BB06CF0757032304770108009F090A04CD04620106000A04CD04CF03844619 -:200C6000494CCC240C670CD9D1C1E178B1280673230BC36B0CD9DDE98545524153C55E0C74 -:200C8000D7055006650CCF0386424C414E4BD3780CD7058106650CCF0384484F4CC4880C35 -:200CA000D7053F01FFFFAF075005AF077305A805CF03835041C4990CD70506083F01440077 -:200CC0006D04CF0384574F52C4B20CD7052E07730577010C002E077305261562010600EB8A -:200CE000067305360773056D04DA047D0206083F012200910C36075005BE044308F7031C31 -:200D0000040608A8056D040608B8070A04F702CF0388284E554D424552A9C40CD705B80770 -:200D2000E604F7037F05830773050C0277012C00DA04830773052903CD04A7088307730509 -:200D4000290379048C077305B807770108005C068C0750050A046201C6FF0A04CF03864E6C -:200D6000554D4245D2110DD70550065006A708E604B8077F053F012D004F08E604F7036DE1 -:200D8000043F01FFFF8C079C051C0DE6047F058106430877011600E6047F053F012E0043C7 -:200DA0000850066D0950066201DCFFCD040A0477010400A304CF03852D46494EC45E0DD762 -:200DC000058106CB0C06086107730573053502E604230477010A00CD04060803093502CF8F -:200DE00003872841424F5254A9B70DD7055210CF03854552524FD2E10DD705030773054829 -:200E00000477010400EB0D0608DC0AEF0A4A0B023F20AD139A032E077305C608770108005F -:200E200036077305DA042510834944AEF10DD705B80C3F012000910CE60445091309BE047B -:200E40004308E604F703B80CDA04F702B80C0A04B80C6D04CF07E60473053F017F00570370 -:200E6000DA049C05DC0A3F011F005703EF0AB708CF03864352454154C5280ED705BF0D77BB -:200E8000011000CD042F092E0E3F010400AD13B7080608E6047F05F60673059B11B80716C8 -:200EA00008E6043F01A00066050608CF073F0180006605030922086E0773059C050608C351 -:200EC000072208CF03C95B434F4D50494C45DD720ED705BF0D230450066D09CD04230922CB -:200EE00008CF03C74C4954455241CCC50ED7057907730577010800000A3F012208CF03C88F -:200F0000444C4954455241CCE30ED7057907730577010800DA04ED0EED0ECF03863F5354A9 -:200F20004143CBFF0ED7058C03D8067305DA047B085C066D098C0306083F0180006D047B12 -:200F4000083F0107006D09CF0389494E544552505245D41C0FD705BF0D77011E00790773D8 -:200F600005610877010A00230922086201060023095301250F62011C000608670D8C077307 -:200F800005B807770108000A0F62010600CD04ED0E250F6201C2FF89494D4D454449415494 -:200FA000C5490FD70503093F0140006605CF038A564F434142554C4152D9970FD705A60A3B -:200FC0003F0181A022086E07730523092208060824077305220824079C05B60AC3076107AA -:200FE0009C05CF03C5464F5254C8AF0FC20ADC0F81A0761B00008B444546494E4954494F69 -:201000004ED3E40FD705610773056E079C05CF03C1A8F60FD7053F012900CB0CCF038451E7 -:201020005549D41010D70550062E079C05160ABA03EA02100C550F7907730523047701072F -:20104000004A0B026F6B6201E7FF8541424F52D41E10D7059A03610A250FEA02DA1A4A0B1E -:201060000E6669672D464F52544820312E3161EC0F04102510017A10DDE9831084574152D5 -:20108000CD4A10D705A51452102A06002E0022A506118010EDDE22990622251422301422F7 -:2010A0002A01114000EDDE221001221401222601222801110004EDDE221201221601F901A3 -:2010C000CC10DD212E01FD212D01DDE9D51084434F4CC47C10D705A5145C0611149C053F62 -:2010E000012A01730523149C053F012A0173052E149C05B91450063F019916A8053F01129D -:20110000013F01260173053F0106006D043F011000F7023F010C0173053F01F20F9C050642 -:20112000143F010F0083153F01FF004F0877011400500603079C05EA024A0B074E6F206606 -:20114000696C65521084532D3EC4CE104E11E1ED6CEBC32C01822BAD4511D705480477014B -:2011600004009304CF0383442BAD5511D705480477010400A304CF03834142D36611D705B4 -:20118000E6045A11CF0384444142D37811D705E6046C11CF03834D49CE8611D70542058C3F -:2011A0000877010400DA04CD04CF03834D41D89511D7054205610877010400DA04CD04CF15 -:2011C00003824DAAAB11C811D1E1EDD2EBC32C01824DAFC111D711D9E17CE6802802ED4C7B -:2011E000444DE1D1CB7C280F3CE5210000EDDED1E5210000ED52D1EDC7380721FFFF545D77 -:201200001814EBEDCBEBCB472802ED4CEBB72806FE812802ED4CD5E5D9DDE981AAD0112167 -:2012200012D1E1EDD2FDE9842F4D4FC41B123012D9C1E178B1200711FFFF626B1818FDED02 -:20124000F70080200D78FEFF2008B920051100001804ED6CEDCAD5E5D9DDE981AF2712610F -:2012600012D9C1E178B1200521FFFF1813FDEDF70080200878FEFF2003B92804ED6CEDCA33 -:20128000E5D9DDE9834D4FC45B128C12D9C1E178B1200511FFFF1818FDEDF70080200D78CE -:2012A000FEFF2008B920051100001804ED6CEDCAD5D9DDE9852A2F4D4FC48412BE12D9E11C -:2012C0007CE6802802ED4C444DE1D108EDD208EBCB7C280F3CE5210000EDDED1E52100006A -:2012E000ED52D1EDC7380721FFFF545D1814EBEDCBEBCB472802ED4CEBB72806FE81280273 -:20130000ED4CD5E5D9DDE9822AAFB4120E13D9E17CE6802802ED4C444DE1D108EDD208EBFD -:20132000CB7C280F3CE5210000EDDED1E5210000ED52D1EDC7380521FFFF180CEBEDCBB7AD -:201340002806FE812802ED4CE5D9DDE9854D2F4D4FC40713D705F70350061C0438030A04E9 -:20136000DA04F70338030A04CF0386284C494E45A94C13D705F7033F014000AF06BC120AB9 -:2013800004BB061F126D0426156D043F014000CF03852E4C494EC56A13D70573131D0BEF97 -:2013A0000ACF03874D4553534147C59113D7050307730577011E00C608770114003F01040F -:2013C0000054077305BB065F1243089913B70862010D004A0B064D53472023208E19CF03C4 -:2013E0008250C0A313E713D9C1ED682600E5D9DDE98250A1E013F813D9C1E1ED69D9DDE931 -:20140000834643C2F11318065C0084524543A30014D70506143F0121006D04CF03835553A6 -:20142000C50A142F06000084505245D61D142F0600008523425546C62714180620008A445B -:2014400049534B2D4552524FD232142F060000842B4255C63E14D7053F0184006D04E6049A -:20146000A3064F0877010600CD049706E6042E1473054308CF03865550444154C54F14D7BC -:20148000052E14730573053F01008068032E1473059C05CF038D454D5054592D4255464651 -:2014A0004552D37614D7059706A306BE044308800CCF03834452B09514D705500654079C10 -:2014C00005CF03834452B1B314D7053F01400654079C05CF03864255464645D2C314D70501 -:2014E00023147305E604F70356147701FCFF23149C051C0473054804770114001C04C3074A -:201500001C0473053F01FF7F57035006A3151C049C051C042E149C050A04C307CF038542D8 -:201520004C4F43CBD514D705540773056D04F7032E147305E60473051C044308E6046D041D -:20154000770132005614230477011200CD041C04DE14E6041C045C06A315DA07E60473057C -:201560001C044308E6046D0423047701D8FFE6042E149C050A04CD04C307CF038442444F8E -:20158000D31E158515D9C1D1DDE5FDE5D9C5D9CD0500D9C1FDE1DDE16F2600FDE983522F9E -:2015A000D77C15D705F70311149C0550061114C307A8053F011A008315CD043F0122000A06 -:2015C0000443080614DA0483154B149C05CF0385464C5553C89D15D7053A14B8075006E4FE -:2015E000015006DE14CD048B01F8FFCF0386455854454EC4CF15D7050608AF06910C3F014E -:2016000008001F125006B8070608BE045C06A3154B1473057701F0FFDA04BE046D04DA0465 -:20162000E4010608FB015006A3158B01F6FF06143F0110008315CD0406143F010F00831558 -:20164000CD04CF03844C4F41C4ED15D7052E077305F70336077305F703500636079C05BBA0 -:20166000061F122E079C05550F0A0436079C050A042E079C05CF03C32D2DBE4416D705E660 -:2016800009500636079C05BB062E077305BE048A1243082E075005CF0300C5D5E5DDE5FD5C -:2016A000E5D9C5D9CD0500D9C1D9FDE1DDE1E1D1C1C9C50E061EFFCD9A16C1C9C50E061EBD -:2016C000FFCD9A16B728FAFE7F20023E08CBBFC1C9C5D50E06CD9A16D1C1C9C50E05CD9AF7 -:2016E00016C1C9CDD1163A9916B7C4DB16C9CDB216210000B728012CFDE9CDBC16FE105FC4 -:2017000020092199161E207EEE01776B2600FDE91217D17BFE08200ACDD1161E20CDD116EC -:201720001E08CDE316DDE91E0DCDE3161E0ACDE316DDE9C1A77716D705BF0D230450066DCB -:2017400009CD04ED0ECF0386464F524745D43317D7056E0773056107730543083F0118007F -:201760006D093717E6040E0773057B083F0115006D09E6042F0916079C0513097305610704 -:2017800073059C05CF0384424143CB4717D705060843082208CF03C542454749CE8617D79C -:2017A00005870906085C06CF03C5454E4449C69717D70587096806B6090608BE044308DA6B -:2017C000049C05CF03C4544845CEA917D705B117CF03C244CFC517D705000AE401060874EB -:2017E00006CF03C44C4F4FD0D217D7057406B609000A8B018D17CF03C52B4C4F4FD0E317E5 -:20180000D7057406B609000AB0018D17CF03C5554E5449CCF817D7055C06B609000A770123 -:201820008D17CF03C3454EC40E18D7051618CF03C541474149CE2418D7055C06B609000A2E -:2018400062018D17CF03C65245504541D43018D705F703F70338180A040A04DA07B117CFAC -:2018600003C249C64618D705000A77010608500622086806CF03C4454C53C56118D70568E0 -:2018800006B609000A6201060850062208DA046806B1176806CF03C55748494CC57618D711 -:2018A000056618C307CF03865350414345D39718D7055006B111C60877010C005006E40114 -:2018C000B7088B01FCFFCF03823CA3A718D705B80CAF079C05CF038223BEC818D705CD0417 -:2018E000CD04AF077305B80CBE044308CF0384534947CED718D705A7084804770108003F8C -:20190000012D00A00CCF0381A3EE18D705830773055413A7083F010900BE04610877010809 -:20192000003F0107006D043F0130006D04A00CCF038223D30719D7050B194205680323041F -:201940007701F6FFCF0383442ED23119D705F703DA04BE048D11CD183619F518DC180A04E0 -:20196000BE044308B018EF0ACF03822ED24619D705F7034C110A044C19CF038244AE6A1977 -:20198000D70550064C19B708CF0381AE7B19D7054C118019CF0381BF8A19D70573058E19DA -:2019A000CF038255AE9619D70550068019CF0385564C4953D4A219D7053F0180003F079CB4 -:2019C000056107730573053F0773058B068C0877010A00EA0250063F079C05E6042E0EB73F -:2019E00008B708450913097305E6042304DD0268037701D4FFCD04CF03834259C5AF19D773 -:201A000005D71506143F0110008315CD04500650068315CF03844C4953D4F919D705610A53 -:201A2000EA02E60448079C054A0B065343522023208E193F0110005006E401EA02FB0174AC -:201A4000066F19B708FB01480773059913DD0277010400E5038B01E4FFEA02CF0385494E3E -:201A60004445D8151AD7053F010C00BA02EA02B807DA04E401EA02FB0174066F19B708508B -:201A800006FB019913DD0277010400E5038B01E6FFCF038554524941C45D1AD7053F010CFA -:201AA00000BA0274065F1274061F127406BE046D04DA04E401EA02FB011C1ADD02770104EB -:201AC00000E5038B01F0FFEA023F010F00AD13EA02CF03842E4350D5931AD7058307730545 -:201AE0003F01240083079C053F012200C9068C05801983079C05CF0386736574636CEBD3A0 -:201B00001A031BD90E08ED667D082EFEED6EAFD3E1D3E9D3E821FFFF3E10D3E00EE2EDBFA9 -:201B20000EEAEDBF3E80D3E83EE0D3E9086F0E08ED6ED9DDE986676574636CEBF81A401B3A -:201B4000D90E08ED667D082EFEED6E3E80D3E90EEBEDB7545D0EE3EDB70E0079956F799C3A -:201B600067799B5F799A57FDEDFBA861E5086F0E08ED6ED9DDE984544153CB351BD705CF95 -:031B80000300005F -:00010001FE -8B708450913097305E6042304DD \ No newline at end of file diff --git a/software/CPM/CPM08_Z80FORTH/280FORTH.MAC b/software/CPM/CPM08_Z80FORTH/280FORTH.MAC deleted file mode 100644 index 02af6ba..0000000 --- a/software/CPM/CPM08_Z80FORTH/280FORTH.MAC +++ /dev/null @@ -1,4210 +0,0 @@ - title - subttl Adaptive version -; -; -; Modified from Z80 fig-FORTH 1.1h by EHR 880830 -; Modified frm FIG document keyed by Dennis L. Wilson 800907 -; Converted frm "8080 FIG-FORTH VERSION A0 15SEP79" -; -; fig-FORTH release 1.1 for the 8080 processor. -; -; ALL PUBLICATIONS OF THE FORTH INTEREST GROUP -; ARE PUBLIC DOMAIN. THEY MAY BE FURTHER -; DISTRIBUTED BY THE INCLUSION OF THIS CREDIT NOTICE: -; -; This publication has been made available by the -; Forth Interest Group -; P.O.Box 1105 -; San Carlos, CA 94070 -; U.S.A. -; -; Implementation on 8080 by: -; John Cassady -; 339 15th Street -; Oakland, CA 94612 -; U.S.A -; on 790528 -; Modified by: -; Kim Harris -; Acknowledgements: -; George Flammer -; Robt. D. Villwock -; ---------------------------------------------------------------------- -; Z80 Version for Cromemco CDOS & Digital Research CP/M by: -; Dennis Lee Wilson c/o -; Aristotelian Logicians -; 2631 East Pinchot Avenue -; Phoenix, AZ 85016 -; U.S.A. -; ---------------------------------------------------------------------- -; The 2 byte Z80 code for Jump Relative (JR) has been substituted for -; the 3 byte Jump (JP) wherever practical. The port I/O words P@ & P! -; have been made ROMable by use of Z80 instructions. -; ---------------------------------------------------------------------- -; Further modifications (marked ;/) by: -; Edmund Ramm -; P.O.Box 38 -; 2358 Kaltenkirchen -; Fed. Rep. of Germany 840418 -; -; 850419 changed * (star) -; 850507 added 0<>, 0>, TUCK, NIP, -ROT, CSWAP, PICK -; 850511 added -CMOVE -; -; ----------------------------------------------------------------------------- -; Disc I/O has been modified a la Albert van der Horst (HCCH) to employ -; CP/M 2.x's random access feature. -; ----------------------------------------------------------------------------- -; ----------------------------------------------------------------------------- -; -; Z280 specifics -; -; -iopreg equ 08h ; i/o page register -; -config0 equ 0e0h ; c/t 0 configuration register -cntrl0 equ 0e1h ; c/t 0 command/status register -tcon0 equ 0e2h ; c/t 0 time constatnt register -count0 equ 0e3h ; c/t 0 count-time register -config1 equ 0e8h ; c/t 1 configuration register -cntrl1 equ 0e9h ; c/t 1 command/status register -tcon1 equ 0eah ; c/t 1 time constant register -count1 equ 0ebh ; c/t 1 count-time register -; -; ----------------------------------------------------------------------------- -; -; Release & Version numbers -; -figrel equ 1 ;FIG RELEASE # -figrev equ 1 ;FIG REVISION # -usrver equ 61h ;USER VERSION # a by EHR -; -;Console & printer drivers are in external source named -;CONPRTIO.FTH & disc drivers in DISCIO.FTH. It has 4 screen -;buffers & end of memory is set to FBASE from locn. 0007H. - page -; ASCII characters used -; -abl equ 20h ;BLANK -acr equ 0dh ;CR -adot equ 2eh ;. -bell equ 07h ;^G -bsin equ 08h ;backspace chr = ^H -bsout equ 08h -dle equ 10h ;^P -lf equ 0ah ;^J -ff equ 0ch ;^L -; -; Memory allocation -; -bdoss equ 0005h ;/ system entry -nscr equ 4 ; # of 1024 byte screens -kbbuf equ 128 ; bytes/disc buffer -us equ 40h ; user variables space -rts equ 400h ; Return Stack & term buff space -co equ kbbuf+4 ; Disc buff + 2 header + 2 tail -nbuf equ nscr*400h/kbbuf ; # of buffers -bufsiz equ co*nbuf ;/ total disc buffer size - page - aseg - ;.z280 - ; PRE280 V1.12 11-Feb-91 Copyright (c) 1988-91 by A.Zinser (fifi@hiss.han.de) - .Z80 -; - org 0100h -; -orig: - nop - jp cld ; vector to cold start - nop - jp wrm ; vector to warm start - defb figrel ; fig release # - defb figrev ; fig revision # - defb usrver ; user version # - defb 0eh ; implementation attributes -; -; -; -; 0eh = 0000:1110 -; --------- -; B +ORIGIN ...W:IEBA -; -; W: 0=above sufficient -; 1=other differences exist -; I: Interpreter is 0=pre- -; 1=post incrementing -; E: Addr must be even: 0 yes -; 1 no -; B: High byte @ 0=low addr. -; 1=high addr. -; A: CPU Addr. 0=BYTE -; 1=WORD -; -; -; - defw task-7 ; topmost word in FORTH vocabulary - defw bsin ; backspace chr -upinit: defw 0 ;/ init (up) -; -; * Following used by COLD; must be in same order as user variables * -; -s0init: defw 0 ;/ init (s0) -r0init: defw 0 ;/ init (r0) -tibini: defw 0 ;/ init (TIB) - defw 1fh ; init (WIDTH) - defw 0 ; init (WARNING) - defw initdp ; init (FENCE) - defw initdp ; init (dp) - defw forth+8 ; init (VOC-LINK) -; -; * END DATA USED BY COLD * -; - defw 0018h,0f600h ; Z280 CPU name (hw,lw) - ; (32 bit base 36 integer) - page -; REGISTERS -; -; FORTH Z80 FORTH PRESERVATION RULES -; ----- --- ----------------------- -; IP BC should be preserved -; accross FORTH words. -; W DE sometimes output from -; NEXT, may be altered -; b4 JP'ing to NEXT, -; input only when -; "DPUSH" called. -; SP SP should be used only as -; Data Stack accross -; FORTH words, may be -; used within FORTH -; words if restored -; b4 "NEXT" -; HL Never output frm NEXT -; input only when -; "HPUSH" called -; -; -up: defw 0 ;/ user area ptr -rpp: defw 0 ;/ return stack ptr -buf1: defw 0 ;/ address of 1st disc buffer -; -; -; COMMENT CONVENTIONS: -; -; == means "is equal to" -; <-- means assignment -; #NAME = value of name -; NAME = contents @ name -; (NAME) = contents of cell addressed by name -; cfa = code field address -; lfa = link field address -; nfa = name field address -; pfa = parameter field address -; s1 = 1st word of parameter stack -; s2 = 2nd -"- of -"- -"- -; r1 = 1st -"- of return stack -; r2 = 2nd -"- of -"- -"- -; ( above Stack posn. valid b4 & after execution of any word, not during) -; -; lsb = least significant bit -; msb = most significant bit -; lb = low byte -; hb = high byte -; lw = low word -; hw = high word -; (May be used as suffix to above names) - page -; FORTH ADDRESS INTERPRETER -; POST INCREMENTING VERSION -; -; -; -dpush: - push de -hpush: - push hl ; iy points here -next: - ld h,b ;/ w <-- (ip) ix points here - ld l,c ;/ - ;ldw hl,(hl) ;/ (hl) --> cfa - DEFB 0EDh,26h - inc bc - inc bc ;/ ip += 2 -next1: - ;ldw de,(hl) ;/ pc <-- (w) - DEFB 0EDh,16h - ex de,hl - inc de - jp (hl) ; note: de <-- cfa + 1 -; -; -jnext macro - jp (ix) - endm -; -jhpush macro - jp (iy) - endm -; - page -; FORTH DICTIONARY -; DICTIONARY FORMAT: -; -; BYTE -; ADDRESS NAME CONTENTS -; ------- ---- -------- -; (MSB=1 -; (P=PRECEDENCE BIT -; (S=SMUDGE BIT -; NFA NAME FIELD 1PS MSB=0, NAME'S 1st CHAR -; 0<2CHAR> -; ... -; 1 MSB=1, NAME'S LAST CHAR -; LFA LINK FIELD =PREVIOUS WORD'S NFA -; -;LABEL: CFA CODE FIELD =ADDR CPU CODE -; -; PFA PARAMETER <1PARAM> 1st PARAMETER BYTE -; FIELD <2PARAM> -; ... -; -; -; -dp0: - defb 83h ; LIT - defc 'LIT' - defw 0 ; lfa == 0 marks end of dictionary -lit: - defw $+2 ; s1 <-- (ip) - ld h,b - ld l,c - ;ldw hl,(hl) ; hl <-- (ip) = literal - DEFB 0EDh,26h - inc bc ;/ - inc bc ;/ ip += 2 - jhpush ; s1 <-- hl -; -; - defb 87h ; EXECUTE - defc 'EXECUTE' - defw lit-6 -exec: - defw $+2 - pop hl - jp next1 -; -; - defb 86h ; BRANCH - defc 'BRANCH' - defw exec-0ah -bran: - defw $+2 ; ip += (ip) -bran1: - ld h,b - ld l,c ; hl <-- ip - ;addw hl,(hl) ; hl <-- ip + branch offset - DEFB 0DDH - DEFB 0EDH,0C6h - ld c,l - ld b,h ; ip += branch offset - jnext -; -; - defb 87h ; 0BRANCH - defc '0BRANCH' - defw bran-9 -zbran: - defw $+2 - pop hl - ld a,l - or h - jr z,bran1 ; branch if if s1 == 0 - inc bc ; else skip branch offset - inc bc - jnext -; -; - defb 86h ; (LOOP) - defc '(LOOP)' - defw zbran-0ah -xloop: - defw $+2 - ld hl,(rpp) ; (hl) --> index = r1 - ;incw (hl) ;/ index += 1 - DEFB 0DDH - inc BC - ;ldw de,(hl) ;/ de <-- new index - DEFB 0EDh,16h - inc hl ;/ - inc hl ;/ hl --> limit(lb) - ld a,e - sub (hl) - ld a,d - inc hl ; hl --> limit(hb) - sbc a,(hl) ; index < limit? - jp m,bran1 ; yes, loop again - inc hl ; no, done - ld (rpp),hl ; discard r1 & r2 - inc bc - inc bc ; skip branch offset - jnext -; -; - defb 87h ; (+LOOP) - defc '(+LOOP)' - defw xloop-9 -xploo: - defw $+2 - pop de ; de <-- increment - ld hl,(rpp) ; hl --> index - ld a,(hl) ; index += increment - add a,e - ld (hl),a - ld e,a - inc hl - ld a,(hl) - adc a,d - ld (hl),a - inc hl ; (hl) --> limit - inc d - dec d - ld d,a ; de <-- new index - jp m,xloo2 ; if incr > 0 - ld a,e - sub (hl) ; then a <-- index - limit - ld a,d - inc hl - sbc a,(hl) - jp xloo3 - -xloo2: - ld a,(hl) ; else a <-- limit - index - sub e - inc hl - ld a,(hl) - sbc a,d -; ; if a < 0 -xloo3: - jp m,bran1 ; then loop again - inc hl ; else done - ld (rpp),hl ; discard r1 & r2 - inc bc ; skip branch offset - inc bc - jnext -; -; - defb 84h ; (DO) - defc '(DO)' - defw xploo-0ah -xdo: - defw $+2 - pop de ; de <-- initial index - ld hl,(rpp) ; hl <-- rp - dec hl - dec hl - ;pop (hl) ;/ r2 <-- limit - DEFB 0DDH - pop BC - dec hl - dec hl - ;ldw (hl),de ;/ r1 <-- initial index - DEFB 0EDh,1Eh - ld (rpp),hl ; rp -= 4 - jnext -; -; - defb 81h ; I - defc 'I' - defw xdo-7 -ido: - defw $+2 - ld hl,(rpp) - ;push (hl) ;/ s1 <-- r1, r1 unchanged - DEFB 0DDH - push BC - jnext -; -; - defb 85h ; DIGIT - defc 'DIGIT' - defw ido-4 -digit: - defw $+2 - pop hl ; l <-- s1.lb = base value - pop de ; e <-- s2.lb = chr to be converted - ld a,e ; a <-- chr - sub '0' ; >= 0? - jr c,digi2 ;/ < 0 is invalid - cp 0ah ; > 9? - jr c,digi1 ;/ no, test base value - sub 07h ; gap between '9' & 'A', nw 'A'=0ah - cp 0ah ; >= 'A'? - jr c,digi2 ;/ chrs btwn '9' & 'A' are invalid -digi1: - cp l ; < base value? - jr nc,digi2 ;/ no, invalid - ld e,a ; s2 <-- de = converted digit - ld hl,0001h ; s1 <-- true - jp dpush -; -digi2: - ld l,h ; hl <-- false - jhpush ; s1 <-- false -; -; - defb 86h ; (FIND) (2-1)FAILURE - defc '(FIND)' ; (2-3)SUCCESS - defw digit-8 -pfind: - defw $+2 - pop de ; de <-- nfa -pfin1: - pop hl ; hl <-- string addr - push hl ; save for next iteration - ld a,(de) - xor (hl) ; filter differences - and 3fh ; mask msb & precedence bit - jr nz,pfin4 ; lengths differ -pfin2: - inc hl ; hl --> next string chr - inc de ; de --> next name field chr - ld a,(de) - xor (hl) ; filter differences - add a,a ; shift msbit into carry - jr nz,pfin3 ; no match - jr nc,pfin2 ; match so far, loop agn - ld hl,0005h ; string matches - add hl,de ; (sp) <-- pfa - ex (sp),hl -pfin6: - dec de ; de --> nfa - ld a,(de) - or a ; msb=1? =length byte - jp p,pfin6 ; no, try next chr - ld e,a ; e <-- length byte - ld d,00h - ld hl,0001h ; hl <-- true - jp dpush ; name field found, return -; -; above name field not a match, try next one -; -pfin3: - jr c,pfin5 ; carry=end of name field -pfin4: - inc de ; find name field end - ld a,(de) - or a ; msb=1? - jp p,pfin4 ; no, loop -pfin5: - inc de ; de <-- lfa - ex de,hl - ;ldw de,(hl) ;/ de <-- lfa - DEFB 0EDh,16h - ld a,d - or e ; end of dictionary (lfa = 0)? - jr nz,pfin1 ; no, try previous definition - pop hl ; drop string address - ld hl,0 ; hl <-- false - jhpush ; no match found, return -; -; - defb 87h ; ENCLOSE - defc 'ENCLOSE' - defw pfind-9 -encl: - defw $+2 - pop de ; de <-- s1 = delimiter chr - pop hl ; hl <-- s2 = addr of text to scan - push hl ; s4 <-- addr - ld a,e - ld d,a ; d <-- delim chr - ld e,-1 ; init chr offset counter - dec hl ; hl <-- addr - 1 -encl1: - inc hl ; skip over leading delim chrs - inc e - cp (hl) ; delim chr? - jr z,encl1 ; yes, loop - ld d,0 - push de ; s3 <-- e = offset to 1st non delim - ld d,a ; d <-- delim chr - ld a,(hl) - and a ; 1st non-delim=null? - jr nz,encl2 ; no - ld d,0 ; yes - inc e - push de ; s2 <-- offset to byte following null - dec e - push de ; s1 <-- offset to null - jnext -; -encl2: - ld a,d ; A <-- delim chr - inc hl ; hl <-- next chr's address - inc e ; e <-- offset to next chr - cp (hl) ; delim chr? - jr z,encl4 ; yes - ld a,(hl) - and a ; null? - jr nz,encl2 ; no, continue scan -encl3: - ld d,0 - push de ; s2 <-- offset to null - push de ; s1 <-- offset to null - jnext -; -encl4: - ld d,0 - push de ; s2 <-- offset to byte following text - inc e - push de ; s1 <-- offset 2 bytes aft end of word - jnext -; -; - defb 84h ; EMIT - defc 'EMIT' - defw encl-0ah -emit: - defw docol - defw pemit - defw one,outt - defw pstor,semis -; -; - defb 83h ; KEY - defc 'KEY' - defw emit-7 -key: - defw $+2 - jp pkey -; -; - defb 89h ; ?TERMINAL - defc '?TERMINAL' - defw key-6 -qterm: - defw $+2 - ld hl,0 - jp pqter -; -; - defb 82h ; CR - defc 'CR' - defw qterm-0ch -cr: - defw $+2 - jp pcr -; -; - defb 85h ; CMOVE - defc 'CMOVE' - defw cr-5 -cmove: - defw $+2 - exx ;/ save ip - pop bc ; bc <-- s1 = # of chrs - pop de ; de <-- s2 = dest addr - pop hl ;/ hl <-- s3 = source addr - ld a,b - or c ; bc=0? - jr z,cmove1 ; yes, nothing to move - ldir ;/ xfer string -cmove1: - exx ;/ restore ip - jnext -; -; - defb 86h ;/ -CMOVE ( from to count --- ) - defc '-CMOVE' - defw cmove-8 -bcmov: - defw $+2 - exx ; save ip - pop bc ; bc <-- count - pop de ; de <-- destination - pop hl ; hl <-- source - ld a,b - or c ; bc =0? - jr z,bcmov1 ; yes, nothing to move - add hl,bc - dec hl ; hl --> hi end of source block - ex de,hl - add hl,bc - dec hl - ex de,hl ; de --> hi end of dest. block - lddr ; (de) <-- (hl), --hl,bc until bc=0 -bcmov1: - exx ; restore ip - jnext -; -; - defb 82h ; U* 16*16 unsigned multiply - defc 'U*' ; with 32 bit result - defw bcmov-9 -ustar: - defw $+2 - pop de ; de <-- multiplier - pop hl ; hl <-- multiplicant - ;multuw hl,de ;/ - DEFB 0EDH,0D3h - ex de,hl ;/ de <-- product.lw, hl <-- product.hw - jp dpush ; s2,s1 <-- product.lw,hw -; -; - defb 82h ; U/ ( ud u1 -- urem uq ) - defc 'U/' - defw ustar-5 -uslas: - defw $+2 - exx ;/ save ip - pop bc ; bc <-- divisor - pop hl ; hl <-- dividend.hw - pop de ; de <-- dividend.lw - ;cpw hl,bc ;/ dividend.hw >= divisor? - DEFB 0EDH,0C7h - jr c,usla1 ; no, go ahead - ld hl,0ffffh ; yes, overflow - ld d,h - ld e,l ;/ set rem & quot to max - jr usla2 -usla1: - ex de,hl ;/ de,hl <-- dividend.hw,lw - ;divuw dehl,bc ;/ de <-- remainder, hl <-- quotient - DEFB 0EDH,0CBh -usla2: - push de ;/ s2 <-- remainder - push hl ;/ s1 <-- quotient - exx ;/ restore ip - jnext -; -; - defb 83h ; AND - defc 'AND' - defw uslas-5 -andd: - defw $+2 ; s1 <-- s1 AND s2 - pop de - pop hl - ld a,e - and l - ld l,a - ld a,d - and h - ld h,a - jhpush -; -; - defb 82h ; OR - defc 'OR' - defw andd-6 -orr: - defw $+2 ; s1 <-- s1 OR s2 - pop de - pop hl - ld a,e - or l - ld l,a - ld a,d - or h - ld h,a - jhpush -; -; - defb 83h ; XOR - defc 'XOR' - defw orr-5 -xorr: - defw $+2 ; s1 <-- s1 XOR s2 - pop de - pop hl - ld a,e - xor l - ld l,a - ld a,d - xor h - ld h,a - jhpush -; -; - defb 83h ; SP@ - defc 'SP@' - defw xorr-6 -spat: - defw $+2 - ld hl,0 - add hl,sp ; hl <-- sp - jhpush ; s1 <-- sp -; -; - defb 83h ; SP! - defc 'SP!' - defw spat-6 -spsto: - defw $+2 ; sp <-- s0 (user variable) - ld hl,(up) ; hl <-- user variables base address - ld de,6 - add hl,de ; hl --> s0 - ;ldw sp,(hl) ;/ sp <-- s0 - DEFB 0EDh,36h - jnext -; -; - defb 83h ; RP@ - defc 'RP@' - defw spsto-6 -rpat: - defw $+2 - ld hl,(rpp) - jhpush ; s1 <-- rp -; -; - defb 83h ; RP! - defc 'RP!' - defw rpat-6 -rpsto: - defw $+2 ; rp <-- r0 (user variable) - ld hl,(up) ; hl <-- user variables base address - ld de,0008h - add hl,de ; hl --> r0 - ;ldw hl,(hl) ;/ hl <-- r0 - DEFB 0EDh,26h - ld (rpp),hl ;/ rp <-- r0 - jnext -; -; - defb 82h ; ;S - defc ';S' - defw rpsto-6 -semis: - defw $+2 ; ip <-- r1 - ld hl,(rpp) - ;ldw bc,(hl) ;/ bc <-- r1 - DEFB 0EDh,06h - inc hl - inc hl - ld (rpp),hl ; rp += 2 - jnext -; -; - defb 85h ; LEAVE - defc 'LEAVE' - defw semis-5 -leave: - defw $+2 ; limit <-- index - ld hl,(rpp) - ;ldw de,(hl) ;/ de <-- r1 (= index) - DEFB 0EDh,16h - inc hl - inc hl - ;ldw (hl),de ;/ r2 (= limit) <-- index - DEFB 0EDh,1Eh - jnext -; -; - defb 82h ; >R - defc '>R' - defw leave-8 -tor: - defw $+2 - ld hl,(rpp) - dec hl - dec hl - ;pop (hl) ;/ r1 <-- s1 - DEFB 0DDH - pop BC - ld (rpp),hl ; rp -= 2 - jnext -; -; - defb 82h ; R> - defc 'R>' - defw tor-5 -fromr: - defw $+2 - ld hl,(rpp) - ;push (hl) ;/ s1 <-- r1 - DEFB 0DDH - push BC - inc hl - inc hl - ld (rpp),hl ; rp += 2 - jnext -; -; - defb 81h ; R - defc 'R' - defw fromr-5 -rr: - defw ido+2 -; -; - defb 82h ; 0= - defc '0=' - defw rr-4 -zequ: - defw $+2 - pop de - ld hl,0 - ;cpw hl,de ;/ - DEFB 0EDH,0D7h - jr nz,zequ1 - inc l ; hl <-- true -zequ1: - jhpush -; -; - defb 83h ;/ 0<> - defc '0<>' - defw zequ-5 -znequ: - defw $+2 - pop de - ld hl,0 - ;cpw hl,de ;/ - DEFB 0EDH,0D7h - jr z,znequ1 - inc l ; hl <-- true -znequ1: - jhpush -; -; - defb 82h ; 0< - defc '0<' - defw znequ-6 -zless: - defw $+2 - pop af ;/ a <-- s1.hb - rla ;/ carry <-- bit 7 - ld hl,0 ; hl <-- false - rl l ;/ bit 0 <-- carry - jhpush -; -; - defb 82h ;/ 0> - defc '0>' - defw zless-5 -zgt: - defw $+2 - pop de - ld hl,0 - ;cpw hl,de ;/ - DEFB 0EDH,0D7h - jp p,zgt1 ;/ <= 0 - jp pe,zgt1 ;/ 8000h special case - inc l ;/ hl <-- true -zgt1: - jhpush -; -; - defb 81h ;+ - defc '+' - defw zgt-5 -plus: - defw $+2 - pop de - pop hl - add hl,de - jhpush -; -; - defb 82h ; D+ ( d1l d1h d2l d2h -- d3l d3h) - defc 'D+' - defw plus-4 -dplus: - defw $+2 - exx ;/ save ip - pop bc ; bc <-- d2.hw - pop hl ; hl <-- d2.lw - pop af ;d af <-- d1.hw - pop de ; de <-- d1.lw - push af ;/ s1 <-- d1.hw - add hl,de ; hl <-- d2.lw + d1.lw (= d3.lw) - ex de,hl ; de <-- d3.lw - pop hl ; hl <-- d1.hw - adc hl,bc ;/ hl <-- d1.hw + d2.hw +carry (=d3.hw) - push de ; s2 <-- d3.lw - push hl ;/ s1 <-- d3.hw - exx ;/ restore ip - jnext -; -; - defb 85h ; MINUS - defc 'MINUS' - defw dplus-5 -minus: - defw $+2 - pop hl ;/ - ;neg hl ;/ - DEFB 0EDH,4Ch - jhpush -; -; - defb 86h ; DMINUS - defc 'DMINUS' - defw minus-8 -dminu: - defw $+2 - exx ;/ save ip - pop de ;/ de <-- d1.hw - pop bc ;/ bc <-- d1.lw - ld hl,0 ;/ - ;subw hl,bc ;/ - DEFB 0EDH,0CEh - push hl ; s2 <-- d2.lw - ld hl,0 ;/ - sbc hl,de ;/ - push hl ; s1 <-- d2.hw - exx ;/ - jnext -; -; - defb 84h ; OVER - defc 'OVER' - defw dminu-9 -over: - defw $+2 - ;ldw hl,(sp+2) ;/ - DEFB 0EDh,04h - DEFW +2 - jhpush ;/ -; -; - defb 84h ; DROP - defc 'DROP' - defw over-7 -drop: - defw $+2 - inc sp - inc sp ;/ faster on z280 than dummy pop - jnext -; -; - defb 84h ; SWAP - defc 'SWAP' - defw drop-7 -swap: - defw $+2 - pop hl - ex (sp),hl - jhpush -; -; - defb 83h ; DUP - defc 'DUP' - defw swap-7 -dup: - defw $+2 - ;ldw hl,(sp+0) ;/ - DEFB 0EDh,04h - DEFW +0 - jhpush -; -; - defb 84h ;/ TUCK ( n1 n2 --- n2 n1 n2) - defc 'TUCK' - defw dup-6 -tuck: - defw $+2 - pop hl ;/ hl <-- s1 - pop de ;/ de <-- s2 - push hl ;/ s3 <-- hl - jp dpush -; -; - defb 83h ;/ NIP ( n1 n2 --- n2) - defc 'NIP' - defw tuck-7 -nip: - defw $+2 - pop hl ; hl <-- s1 - ;ldw (sp+0),hl ;/ s1 <-- hl - DEFB 0EDh,05h - DEFW +0 - jnext -; -; - defb 84h ;/ -ROT ( n1 n2 n3 --- n3 n1 n2) - defc '-ROT' - defw nip-6 -mrot: - defw $+2 - pop hl - pop de - ex (sp),hl - ex de,hl - jp dpush -; -; - defb 85h ;/ CSWAP ( n1 --- n1, bytes swapped) - defc 'CSWAP' - defw mrot-7 -cswap: - defw $+2 - pop hl - ;ex h,l ;/ - DEFB 0EDH,0EFh - jhpush -; -; - defb 84h ;/ PICK ( nn...n0 k --- nn..n0 nk) - defc 'PICK' - defw cswap-8 -pick: - defw $+2 - pop hl ; hl <-- depth - add hl,hl ; adjust to word size - add hl,sp ; offset into stack - ;push (hl) ;/ - DEFB 0DDH - push BC - jnext -; -; - defb 84h ; 2DUP - defc '2DUP' - defw pick-7 -tdup: - defw $+2 - pop hl - pop de - push de - push hl - jp dpush -; -; - defb 82h ; +! - defc '+!' - defw tdup-7 -pstor: - defw $+2 - pop hl ; hl --> variable - pop de ; de <-- number - ld a,(hl) - add a,e - ld (hl),a - inc hl - ld a,(hl) - adc a,d - ld (hl),a ; (hl) += number - jnext -; -; - defb 86h ; TOGGLE - defc 'TOGGLE' - defw pstor-5 -toggl: - defw $+2 - pop de ; e <-- bit pattern - pop hl ; hl --> address - ld a,(hl) - xor e - ld (hl),a - jnext -; -; - defb 81h ; @ - defc '@' - defw toggl-9 -at: - defw $+2 - pop hl - ;push (hl) ;/ - DEFB 0DDH - push BC - jnext -; -; - defb 82h ; C@ - defc 'C@' - defw at-4 -cat: - defw $+2 - pop hl - ld l,(hl) - ld h,0 - jhpush -; -; - defb 82h ; 2@ - defc '2@' - defw cat-5 -tat: - defw $+2 - pop hl ; hl --> address - ;ldw de,(hl) ;/ de <-- d.hw - DEFB 0EDh,16h - inc hl - inc hl ; hl --> d.lw - ;push (hl) ;/ s2 <-- d.lw - DEFB 0DDH - push BC - push de ;/ s1 <-- d.hw - jnext -; -; - defb 81h ; ! - defc '!' - defw tat-5 -store: - defw $+2 - pop hl ; hl --> address - ;pop (hl) ;/ - DEFB 0DDH - pop BC - jnext -; -; - defb 82h ; C! - defc 'C!' - defw store-4 -cstor: - defw $+2 - pop hl ; hl --> address - pop de ; e <-- char - ld (hl),e - jnext -; -; - defb 82h ; 2! - defc '2!' - defw cstor-5 -tstor: - defw $+2 - pop hl ; hl --> address - ;pop (hl) ;/ store d.hw - DEFB 0DDH - pop BC - inc hl - inc hl - ;pop (hl) ;/ store d.lw - DEFB 0DDH - pop BC - jnext -; -; - defb 0c1h ; : - defc ':' - defw tstor-5 -colon: - defw docol - defw qexec - defw scsp - defw curr - defw at - defw cont - defw store - defw creat - defw rbrac - defw pscod -docol: - ld hl,(rpp) - dec hl - dec hl - ;ldw (hl),bc ;/ save return address - DEFB 0EDh,0Eh - ld (rpp),hl - inc de - ld c,e - ld b,d - jnext -; -; - defb 0c1h ; ; - defc ';' - defw colon-4 -semi: - defw docol - defw qcsp - defw comp - defw semis - defw smudg - defw lbrac - defw semis -; -; - defb 84h ; NOOP - defc 'NOOP' - defw semi-4 -noop: - defw docol - defw semis -; -; - defb 88h ; CONSTANT - defc 'CONSTANT' - defw noop-7 -con: - defw docol - defw creat - defw smudg - defw comma - defw pscod -docon: - inc de - ex de,hl - ;push (hl) ;/ - DEFB 0DDH - push BC - jnext -; -; - defb 88h ; VARIABLE - defc 'VARIABLE' - defw con-0bh -var: - defw docol - defw con - defw pscod -dovar: - inc de - push de - jnext -; -; - defb 84h ; USER - defc 'USER' - defw var-0bh -user: - defw docol - defw con - defw pscod -douse: - inc de - ex de,hl - ld l,(hl) ;/ - ld h,0 ;/ - ;addw hl,(up) ;/ - DEFB 0DDH - DEFB 0EDH,0D6h - DEFW UP - jhpush -; -; - defb 81h ; 0 - defc '0' - defw user-7 -zero: - defw $+2 ;/ - ;push 0000h ;/ - DEFB 0FDH - push AF - DEFW 0000H - jnext -; -; - defb 81h ; 1 - defc '1' - defw zero-4 -one: - defw $+2 ;/ - ;push 0001h ;/ - DEFB 0FDH - push AF - DEFW 0001H - jnext -; -; - defb 81h ; 2 - defc '2' - defw one-4 -two: - defw $+2 ;/ - ;push 0002h ;/ - DEFB 0FDH - push AF - DEFW 0002H - jnext -; -; - defb 81h ; 3 - defc '3' - defw two-4 -three: - defw $+2 ;/ - ;push 0003h ;/ - DEFB 0FDH - push AF - DEFW 0003H - jnext -; -; - defb 82h ; BL - defc 'BL' - defw three-4 -bl: - defw docon - defw 20h -; -; - defb 83h ; C/L - defc 'C/L' - defw bl-5 -csll: - defw docon - defw 64 -; -; - defb 85h ; FIRST - defc 'FIRST' - defw csll-6 -first: - defw docon - defw 0 ;/ set by CLD -; -; - defb 85h ; LIMIT - defc 'LIMIT' - defw first-8 -limit: - defw docon - defw 0 ;/ set by CLD -; -; - defb 85h ; B/BUF - defc 'B/BUF' - defw limit-8 -bbuf: - defw docon - defw kbbuf -; -; - defb 85h ; B/SCR - defc 'B/SCR' - defw bbuf-8 -bscr: - defw docon - defw 400h/kbbuf -; -; - defb 87h ; +ORIGIN - defc '+ORIGIN' - defw bscr-8 -porig: - defw docol - defw lit - defw orig - defw plus - defw semis -; -; USER VARIABLES -; - defb 82h ; S0 - defc 'S0' - defw porig-0ah -szero: - defw douse - defw 6 -; -; - defb 82h ; R0 - defc 'R0' - defw szero-5 -rzero: - defw douse - defw 8 -; -; - defb 83h ; TIB - defc 'TIB' - defw rzero-5 -tib: - defw douse - defb 0ah -; -; - defb 85h ; WIDTH - defc 'WIDTH' - defw tib-6 -width: - defw douse - defb 0ch -; -; - defb 87h ; WARNING - defc 'WARNING' - defw width-8 -warn: - defw douse - defb 0eh -; -; - defb 85h ; FENCE - defc 'FENCE' - defw warn-0ah -fence: - defw douse - defb 10h -; -; - defb 82h ; DP - defc 'DP' - defw fence-8 -dp: - defw douse - defb 12h -; -; - defb 88h ; VOC-LINK - defc 'VOC-LINK' - defw dp-5 -vocl: - defw douse - defw 14h -; -; - defb 83h ; BLK - defc 'BLK' - defw vocl-0bh -blk: - defw douse - defb 16h -; -; - defb 82h ; IN - defc 'IN' - defw blk-6 -inn: - defw douse - defb 18h -; -; - defb 83h ; OUT - defc 'OUT' - defw inn-5 -outt: - defw douse - defb 1ah -; -; - defb 83h ; SCR - defc 'SCR' - defw outt-6 -scr: - defw douse - defb 1ch -; -; - defb 86h ; OFFSET - defc 'OFFSET' - defw scr-6 -ofset: - defw douse - defb 1eh -; -; - defb 87h ; CONTEXT - defc 'CONTEXT' - defw ofset-9 -cont: - defw douse - defb 20h -; -; - defb 87h ; CURRENT - defc 'CURRENT' - defw cont-0ah -curr: - defw douse - defb 22h -; -; - defb 85h ; STATE - defc 'STATE' - defw curr-0ah -state: - defw douse - defb 24h -; -; - defb 84h ; BASE - defc 'BASE' - defw state-8 -base: - defw douse - defb 26h -; -; - defb 83h ; DPL - defc 'DPL' - defw base-7 -dpl: - defw douse - defb 28h -; -; - defb 83h ; FLD - defc 'FLD' - defw dpl-6 -fld: - defw douse - defb 2ah -; -; - defb 83h ; CSP - defc 'CSP' - defw fld-6 -cspp: - defw douse - defb 2ch -; - - defb 82h ; R# - defc 'R#' - defw cspp-6 -rnum: - defw douse - defb 2eh -; - - defb 83h ; HLD - defc 'HLD' - defw rnum-5 -hld: - defw douse - defw 30h -; -; END OF USER VARIABLES -; - defb 82h ; 1+ - defc '1+' - defw hld-6 -onep: - defw $+2 ;/ - pop hl ;/ - inc hl ;/ - jhpush ;/ -; -; - defb 82h ; 2+ - defc '2+' - defw onep-5 -twop: - defw $+2 ;/ - pop hl ;/ - inc hl ;/ - inc hl ;/ - jhpush ;/ -; -; - defb 82h ;/ 1- - defc '1-' ;/ - defw twop-5 ;/ -onemin: - defw $+2 ;/ - pop hl ;/ - dec hl ;/ - jhpush ;/ -; -; - defb 82h ;/ 2- - defc '2-' ;/ - defw onemin-5 ;/ -twomin: - defw $+2 ;/ - pop hl ;/ - dec hl ;/ - dec hl ;/ - jhpush ;/ -; -; - defb 82h ;/ 2* - defc '2*' ;/ - defw twomin-5 ;/ -twosta: - defw $+2 ;/ - pop hl ;/ - add hl,hl ;/ asl hl - jhpush ;/ -; -; - defb 82h ;/ 2/ - defc '2/' ;/ - defw twosta-5 ;/ -twosla: - defw $+2 ;/ - pop hl ;/ - bit 7,h ;/ negative? - jr z,twosl1 ;/ no - inc hl ;/ yes, add 1 -twosl1: - sra h ;/ - rr l ;/ asr hl - jhpush ;/ -; -; - defb 84h ; HERE - defc 'HERE' - defw twosla-5 -here: - defw docol - defw dp - defw at - defw semis -; -; - defb 85h ; ALLOT - defc 'ALLOT' - defw here-7 -allot: - defw docol - defw dp - defw pstor - defw semis -; -; - defb 81h ; , - defc ',' - defw allot-8 -comma: - defw docol - defw here - defw store - defw two - defw allot - defw semis -; - - defb 82h ; C, - defc 'C,' - defw comma-4 -ccomm: - defw docol - defw here - defw cstor - defw one - defw allot - defw semis -; -; - defb 81h ; - - defc '-' - defw ccomm-5 -subb: - defw $+2 - pop de - pop hl - ;subw hl,de ;/ - DEFB 0EDH,0DEh - jhpush -; -; - defb 81h ; = - defc '=' - defw subb-4 -equal: - defw $+2 ;/ - pop de ;/ - pop hl ;/ - ;subw hl,de ;/ - DEFB 0EDH,0DEh - ld hl,0 ; hl <-- false - jr nz,equal1 - inc l ;/ hl <-- true -equal1: - jhpush -; -; - defb 81h ; < - defc '<' - defw equal-4 -less: - defw $+2 - pop de - pop hl ; hl de < - ld a,d - xor h ; one operand negative? - jp m,less1 ; yes, determine which - ;subw hl,de ;/ - DEFB 0EDH,0DEh -less1: - bit 7,h ;/ h negative? - ld hl,0 ; hl <-- false - jr z,less2 - inc l ;/ hl <-- true -less2: - jhpush -; -; - defb 82h ; U< - defc 'U<' - defw less-4 -uless: - defw $+2 - pop de - pop hl ;/ hl de U< - ;subw hl,de ;/ - DEFB 0EDH,0DEh - ld hl,0 ; hl <-- false - rl l ;/ bit 0 <-- carry -uless1: - jhpush -; -; - defb 81h ; > - defc '>' - defw uless-5 -great: - defw $+2 - pop hl ;/ - pop de ;/ hl de > (= de hl < ) - ld a,d - xor h ; one operand negative? - jp m,great1 ; yes, determine which - ;subw hl,de ;/ - DEFB 0EDH,0DEh -great1: - bit 7,h ;/ h negative? - ld hl,0 ; hl <-- false - jr z,great2 - inc l ;/ hl <-- true -great2: - jhpush -; -; - defb 83h ; ROT ( n1 n2 n3 --- n2 n3 n1) - defc 'ROT' - defw great-4 -rot: - defw $+2 - pop de ; de <-- n3 - pop hl ; hl <-- n2 - ex (sp),hl ; s1 <-- n2, hl <-- n1 - jp dpush ; s2 <-- n3, s3 <-- n1 -; -; - defb 85h ; SPACE - defc 'SPACE' - defw rot-6 -space: - defw docol - defw bl - defw emit - defw semis -; -; - defb 84h ; -DUP - defc '-DUP' - defw space-8 -ddup: - defw $+2 ;/ - ;ldw hl,(sp+0) ;/ - DEFB 0EDh,04h - DEFW +0 - ld a,h ;/ - or l ;/ hl = 0? - jr z,ddup1 ;/ yes, don't dup - push hl ;/ -ddup1: - jnext -; -; - defb 88h ; TRAVERSE - defc 'TRAVERSE' - defw ddup-7 -trav: - defw docol - defw swap -trav1: - defw over ; begin - defw plus - defw lit - defw 7fh - defw over - defw cat - defw less - defw zbran ; until - defw trav1-$ - defw swap - defw drop - defw semis -; -; - defb 86h ; LATEST - defc 'LATEST' - defw trav-0bh -lates: - defw docol - defw curr - defw at - defw at - defw semis -; -; - defb 83h ; LFA - defc 'LFA' - defw lates-9 -lfa: - defw $+2 - pop hl ;/ hl <-- pfa - ;subw hl,4 ;/ - DEFB 0FDH - DEFB 0EDH,0FEh - DEFW 4 - jhpush ;/ s1 <-- lfa -; -; - defb 83h ; CFA - defc 'CFA' - defw lfa-6 -cfa: - defw docol - defw twomin ;/ - defw semis -; -; - defb 83h ; NFA - defc 'NFA' - defw cfa-6 -nfa: - defw docol - defw lit - defw 5 - defw subb - defw lit - defw -1 - defw trav - defw semis -; -; - defb 83h ; PFA - defc 'PFA' - defw nfa-6 -pfa: - defw docol - defw one - defw trav - defw lit - defw 5 - defw plus - defw semis -; -; - defb 84h ; !CSP - defc '!CSP' - defw pfa-6 -scsp: - defw docol - defw spat - defw cspp - defw store - defw semis -; -; - defb 86h ; ?ERROR - defc '?ERROR' - defw scsp-7 -qerr: - defw docol - defw swap - defw zbran ; if - defw qerr1-$ - defw error - defw bran ; else - defw qerr2-$ -qerr1: - defw drop ; endif -qerr2: - defw semis -; -; - defb 85h ; ?COMP - defc '?COMP' - defw qerr-9 -qcomp: - defw docol - defw state - defw at - defw zequ - defw lit - defw 11h - defw qerr - defw semis -; -; - defb 85h ; ?EXEC - defc '?EXEC' - defw qcomp-8 -qexec: - defw docol - defw state - defw at - defw lit - defw 12h - defw qerr - defw semis -; -; - defb 86h ; ?PAIRS - defc '?PAIRS' - defw qexec-8 -qpair: - defw docol - defw subb - defw lit - defw 13h - defw qerr - defw semis -; -; - defb 84h ; ?CSP - defc '?CSP' - defw qpair-9 -qcsp: - defw docol - defw spat - defw cspp - defw at - defw subb - defw lit - defw 14h - defw qerr - defw semis -; -; - defb 88h ; ?LOADING - defc '?LOADING' - defw qcsp-7 -qload: - defw docol - defw blk - defw at - defw zequ - defw lit - defw 16h - defw qerr - defw semis -; -; - defb 87h ; COMPILE - defc 'COMPILE' - defw qload-0bh -comp: - defw docol - defw qcomp - defw fromr - defw dup - defw twop - defw tor - defw at - defw comma - defw semis -; -; - defb 0c1h ; [ - defc '[' - defw comp-0ah -lbrac: - defw docol - defw zero - defw state - defw store - defw semis -; -; - defb 81h ; ] - defc ']' - defw lbrac-4 -rbrac: - defw docol - defw lit,0c0h - defw state,store - defw semis -; -; - defb 86h ; SMUDGE - defc 'SMUDGE' - defw rbrac-4 -smudg: - defw docol - defw lates - defw lit - defw 20h - defw toggl - defw semis -; -; - defb 83h ; HEX - defc 'HEX' - defw smudg-9 -hex: - defw docol - defw lit - defw 10h - defw base - defw store - defw semis -; -; - defb 87h ; DECIMAL - defc 'DECIMAL' - defw hex-6 -dec: - defw docol - defw lit - defw 0ah - defw base - defw store - defw semis -; -; - defb 87h ; (;CODE) - defc '(;CODE)' - defw dec-0ah -pscod: - defw docol - defw fromr - defw lates - defw pfa - defw cfa - defw store - defw semis -; -; - defb 0c5h ; ;CODE - defc ';CODE' - defw pscod-0ah -semic: - defw docol - defw qcsp - defw comp - defw pscod - defw lbrac -semi1: - defw noop ; assembler - defw semis -; -; - defb 87h ; - defc 'DOES>' - defw build-0ah -does: - defw docol - defw fromr - defw lates - defw pfa - defw store - defw pscod -dodoe: - ld hl,(rpp) - dec hl - dec hl - ;ldw (hl),bc ;/ - DEFB 0EDh,0Eh - ld (rpp),hl - inc de - ex de,hl - ;ldw bc,(hl) ;/ - DEFB 0EDh,06h - inc hl - inc hl - jhpush -; -; - defb 85h ; COUNT - defc 'COUNT' - defw does-8 -count: - defw docol - defw dup - defw onep - defw swap - defw cat - defw semis -; -; - defb 84h ; TYPE - defc 'TYPE' - defw count-8 -type: - defw docol - defw ddup - defw zbran ; if - defw type1-$ - defw over - defw plus - defw swap - defw xdo ; do -type2: - defw ido - defw cat - defw emit - defw xloop ; loop - defw type2-$ - defw bran ; else - defw type3-$ -type1: - defw drop ; endif -type3: - defw semis -; -; - defb 89h ; -TRAILING - defc '-TRAILING' - defw type-7 -dtrai: - defw docol - defw dup - defw zero - defw xdo ; do -dtra1: - defw tdup ;/ - defw plus - defw onemin ;/ - defw cat - defw bl - defw subb - defw zbran ; if - defw dtra2-$ - defw leave - defw bran ; else - defw dtra3-$ -dtra2: - defw onemin ;/ -dtra3: - defw xloop ; loop - defw dtra1-$ - defw semis -; -; - defb 84h ; (.") - defc '(.")' - defw dtrai-0ch -pdotq: - defw docol - defw rr - defw count - defw dup - defw onep - defw fromr - defw plus - defw tor - defw type - defw semis -; -; - defb 0c2h ; ." - defc '."' - defw pdotq-7 -dotq: - defw docol - defw lit - defw 22h - defw state - defw at - defw zbran ; if - defw dotq1-$ - defw comp - defw pdotq - defw word - defw here - defw cat - defw onep - defw allot - defw bran ; else - defw dotq2-$ -dotq1: - defw word - defw here - defw count - defw type ; endif -dotq2: - defw semis -; -; - defb 86h ; EXPECT - defc 'EXPECT' - defw dotq-5 -expec: - defw docol - defw over - defw plus - defw over - defw xdo ; do -expe1: - defw key - defw dup - defw lit - defw 0eh - defw porig - defw at - defw equal - defw zbran ; if - defw expe2-$ - defw drop - defw dup - defw ido - defw equal - defw dup - defw fromr - defw twomin ;/ - defw plus - defw tor - defw zbran ; if - defw expe6-$ - defw lit - defw bell - defw bran ; else - defw expe7-$ -expe6: - defw lit - defw bsout ; endif -expe7: - defw bran ; else - defw expe3-$ -expe2: - defw dup - defw lit - defw acr ;/ - defw equal - defw zbran ; if - defw expe4-$ - defw leave - defw drop - defw bl - defw zero - defw bran ; else - defw expe5-$ -expe4: - defw dup ; endif -expe5: - defw ido - defw cstor - defw zero - defw ido - defw onep - defw store ; endif -expe3: - defw emit - defw xloop ; loop - defw expe1-$ - defw drop - defw semis -; -; - defb 85h ; QUERY - defc 'QUERY' - defw expec-9 -query: - defw docol - defw tib - defw at - defw lit - defw 50h - defw expec - defw zero - defw inn - defw store - defw semis -; -; - defb 0c1h ; NULL - defb 80h - defw query-8 -null: - defw docol - defw blk - defw at - defw zbran ; if - defw null1-$ - defw one - defw blk - defw pstor - defw zero - defw inn - defw store - defw blk - defw at - defw bscr - defw onemin ;/ - defw andd - defw zequ - defw zbran ; if - defw null2-$ - defw qexec - defw fromr - defw drop ; endif -null2: - defw bran ; else - defw null3-$ -null1: - defw fromr - defw drop ; endif -null3: - defw semis -; - defb 84h ; FILL - defc 'FILL' - defw null-4 -fill: - defw $+2 - exx ;/ save ip - pop de ;/ e <-- byte - pop bc ; bc <-- quantity - pop hl ;/ hl <-- address -fill1: - ld a,b - or c ; qty == 0? - jr z,fill2 ; yes, nothing (more) to fill - ld (hl),e ;/ (hl) <-- byte - inc hl ; inc pointer - dec bc ; dec counter - jp fill1 ;/ -fill2: - exx ;/ restore ip - jnext -; -; - defb 85h ; ERASE - defc 'ERASE' - defw fill-7 -erasee: - defw docol - defw zero - defw fill - defw semis -; -; - defb 86h ; BLANKS - defc 'BLANKS' - defw erasee-8 -blank: - defw docol - defw bl - defw fill - defw semis -; -; - defb 84h ; HOLD - defc 'HOLD' - defw blank-9 -hold: - defw docol - defw lit - defw -1 - defw hld - defw pstor - defw hld - defw at - defw cstor - defw semis -; -; - defb 83h ; PAD - defc 'PAD' - defw hold-7 -pad: - defw docol - defw here - defw lit - defw 44h - defw plus - defw semis -; -; - defb 84h ; WORD - defc 'WORD' - defw pad-6 -word: - defw docol - defw blk - defw at - defw zbran ; if - defw word1-$ - defw blk - defw at - defw block - defw bran ; else - defw word2-$ -word1: - defw tib - defw at ; endif -word2: - defw inn - defw at - defw plus - defw swap - defw encl - defw here - defw lit - defw 22h - defw blank - defw inn - defw pstor - defw over - defw subb - defw tor - defw rr - defw here - defw cstor - defw plus - defw here - defw onep - defw fromr - defw cmove - defw semis -; -; - defb 88h ; (NUMBER) - defc '(NUMBER)' - defw word-7 -pnumb: - defw docol -pnum1: - defw onep ; begin - defw dup - defw tor - defw cat - defw base - defw at - defw digit - defw zbran ; while - defw pnum2-$ - defw swap - defw base - defw at - defw ustar - defw drop - defw rot - defw base - defw at - defw ustar - defw dplus - defw dpl - defw at - defw onep - defw zbran ; if - defw pnum3-$ - defw one - defw dpl - defw pstor ; endif -pnum3: - defw fromr - defw bran ; repeat - defw pnum1-$ -pnum2: - defw fromr - defw semis -; -; - defb 86h ; NUMBER - defc 'NUMBER' - defw pnumb-0bh -numb: - defw docol - defw zero - defw zero - defw rot - defw dup - defw onep - defw cat - defw lit - defw 2dh - defw equal - defw dup - defw tor - defw plus - defw lit - defw -1 -numb1: - defw dpl ; begin - defw store - defw pnumb - defw dup - defw cat - defw bl - defw subb - defw zbran ; while - defw numb2-$ - defw dup - defw cat - defw lit - defw 2eh - defw subb - defw zero - defw qerr - defw zero - defw bran ; repeat - defw numb1-$ -numb2: - defw drop - defw fromr - defw zbran ; if - defw numb3-$ - defw dminu ; endif -numb3: - defw semis -; -; - defb 85h ; -FIND (0-3) SUCCESS - defc '-FIND' ; (0-1) FAILURE - defw numb-9 -dfind: - defw docol - defw bl - defw word - defw here - defw cont - defw at - defw at - defw pfind - defw dup - defw zequ - defw zbran ; if - defw dfin1-$ - defw drop - defw here - defw lates - defw pfind ; endif -dfin1: - defw semis -; -; - defb 87h ; (ABORT) - defc '(ABORT)' - defw dfind-8 -pabor: - defw docol - defw abort - defw semis -; - defb 85h ; ERROR - defc 'ERROR' - defw pabor-0ah -error: - defw docol - defw warn - defw at - defw zless - defw zbran ; if - defw erro1-$ - defw pabor ; endif -erro1: - defw here - defw count - defw type - defw pdotq - defb 2 - db '? ' - defw mess - defw spsto -; CHANGE FROM fig MODEL -; defw inn,at,blk,at - defw blk,at - defw ddup - defw zbran,erro2-$ ; if - defw inn,at - defw swap ; endif -erro2: - defw quit -; -; - defb 83h ; ID. - defc 'ID.' - defw error-8 -iddot: - defw docol - defw pad - defw lit - defw 20h - defw blank ;/ - defw dup - defw pfa - defw lfa - defw over - defw subb - defw dup ;/ change frm MODEL - defw tor ;/ to suppress BIT 7 - defw pad - defw swap - defw cmove - defw pad - defw fromr ;/ for terminals - defw pad ;/ with an 8 bit - defw plus ;/ ASCII character set. - defw onemin ;/ - defw dup ;/ - defw at ;/ - defw lit ;/ - defw 7fh ;/ - defw andd ;/ - defw swap ;/ - defw store ;/ - defw count - defw lit - defw 1fh ; WIDTH - defw andd - defw type - defw space - defw semis -; - defb 86h ; CREATE - defc 'CREATE' - defw iddot-6 -creat: - defw docol - defw dfind - defw zbran ; if - defw crea1-$ - defw drop - defw nfa - defw iddot - defw lit - defw 4 - defw mess - defw space ; endif -crea1: - defw here - defw dup - defw cat - defw width - defw at - defw min - defw onep - defw allot - defw dup - defw lit - defw 0a0h - defw toggl - defw here - defw onemin - defw lit - defw 80h - defw toggl - defw lates - defw comma - defw curr - defw at - defw store - defw here - defw twop - defw comma - defw semis -; -; - defb 0c9h ; [COMPILE] - defc '[COMPILE]' - defw creat-9 -bcomp: - defw docol - defw dfind - defw zequ - defw zero - defw qerr - defw drop - defw cfa - defw comma - defw semis -; -; - defb 0c7h ; LITERAL - defc 'LITERAL' - defw bcomp-0ch -liter: - defw docol - defw state - defw at - defw zbran ; if - defw lite1-$ - defw comp - defw lit - defw comma ; endif -lite1: - defw semis -; -; - defb 0c8h ; DLITERAL - defc 'DLITERAL' - defw liter-0ah -dlite: - defw docol - defw state - defw at - defw zbran ; if - defw dlit1-$ - defw swap - defw liter - defw liter ; endif -dlit1: - defw semis -; -; - defb 86h ; ?STACK - defc '?STACK' - defw dlite-0bh -qstac: - defw docol - defw spat - defw szero - defw at - defw swap - defw uless - defw one - defw qerr - defw spat - defw here - defw lit - defw 80h - defw plus - defw uless - defw lit - defw 7 - defw qerr - defw semis -; -; - defb 89h ; INTERPRET - defc 'INTERPRET' - defw qstac-9 -inter: - defw docol -inte1: - defw dfind ; begin - defw zbran ; if - defw inte2-$ - defw state - defw at - defw less - defw zbran ; if - defw inte3-$ - defw cfa - defw comma - defw bran ; else - defw inte4-$ -inte3: - defw cfa - defw exec ; endif -inte4: - defw qstac - defw bran ; else - defw inte5-$ -inte2: - defw here - defw numb - defw dpl - defw at - defw onep - defw zbran ; if - defw inte6-$ - defw dlite - defw bran ; else - defw inte7-$ -inte6: - defw drop - defw liter ; endif -inte7: - defw qstac ; endif -inte5: - defw bran ; again - defw inte1-$ -; -; - defb 89h ; IMMEDIATE - defc 'IMMEDIATE' - defw inter-0ch -immed: - defw docol - defw lates - defw lit - defw 40h - defw toggl - defw semis -; -; - defb 8ah ; VOCABULARY - defc 'VOCABULARY' - defw immed-0ch -vocab: - defw docol - defw build - defw lit - defw 0a081h - defw comma - defw curr - defw at - defw cfa - defw comma - defw here - defw vocl - defw at - defw comma - defw vocl - defw store - defw does -dovoc: - defw twop - defw cont - defw store - defw semis -; -; - defb 0c5h ; FORTH - defc 'FORTH' - defw vocab-0dh -forth: - defw dodoe - defw dovoc - defw 0a081h - defw task-7 ; cold start value only -; changed aech time a def is appended -; to the FORTH vocabulary - defw 0 ; end of vocabulary list -; -; - defb 8bh ; DEFINITIONS - defc 'DEFINITIONS' - defw forth-8 -defin: - defw docol - defw cont - defw at - defw curr - defw store - defw semis -; -; - defb 0c1h ; ( - defc '(' - defw defin-0eh -paren: - defw docol - defw lit - defw 29h - defw word - defw semis -; -; - defb 84h ; QUIT - defc 'QUIT' - defw paren-4 -quit: - defw docol - defw zero - defw blk - defw store - defw lbrac -quit1: - defw rpsto ; begin - defw cr - defw query - defw inter - defw state - defw at - defw zequ - defw zbran ; if - defw quit2-$ - defw pdotq - defb 2 - db 'ok' ; endif -quit2: - defw bran ; again - defw quit1-$ -; -; - defb 85h ; ABORT - defc 'ABORT' - defw quit-7 -abort: - defw docol - defw spsto - defw dec - defw qstac - defw cr - defw dotcpu - defw pdotq - defb 0eh ; count of chrs to follow - db 'fig-FORTH ' - defb figrel+30h,adot,figrev+30h,usrver - defw forth - defw defin - defw quit -; -; -wrm: ld bc,wrm1 - jnext -wrm1: defw warm -; -; - defb 84h ; WARM - defc 'WARM' - defw abort-8 -warm: - defw docol - defw mtbuf - defw abort -; -; -cld: - ld hl,(bdoss+1) ;/ - ld l,0 ;/ hl <-- fbase - ld (limit+2),hl ;/ set limit - ld de,bufsiz ;/ de <-- total disc buffer size - ;subw hl,de ;/ hl <-- addr. of 1st disc buffer - DEFB 0EDH,0DEh - ld (first+2),hl ;/ set FIRST - ld (use+2),hl ;/ set USE - ld (prev+2),hl ;/ set PREV - ld (buf1),hl ;/ - ld de,us ;/ de <-- user variable space - ;subw hl,de ;/ hl <-- initr0 - DEFB 0EDH,0DEh - ld (upinit),hl ;/ - ld (r0init),hl ;/ - ld (up),hl ;/ - ld (rpp),hl ;/ - ld de,rts ;/ de <-- rtn stack & term. buf space - ;subw hl,de ;/ hl <-- inits0 - DEFB 0EDH,0DEh - ld (s0init),hl ;/ - ld (tibini),hl ;/ - ld sp,hl ;/ - ld bc,cld1 - ld ix,next ; pointer to next - ld iy,hpush ; pointer to hpush - jnext -; -; -cld1: defw cold -; - defb 84h ; COLD - defc 'COLD' - defw warm-7 -cold: - defw docol - defw mtbuf - defw one,recadr ; AvdH - defw store - defw lit,buf1 - defw at ;/ - defw use,store - defw lit,buf1 - defw at ;/ - defw prev,store - defw drzer - defw zero ;/ - defw lit,eprint - defw cstor ;/ -; - defw lit - defw orig+12h - defw lit - defw up - defw at - defw lit - defw 6 - defw plus - defw lit - defw 10h - defw cmove - defw lit - defw orig+0ch - defw at - defw lit - defw forth+6 - defw store - defw fcb ;/A - defw lit,opnfil ;/A open mass storage - defw bdos ;/A - defw lit,0ffh ;/A - defw equal ;/A file present? - defw zbran,cld2-$ ;/A - defw zero ;/A - defw warn,store ;/A - defw cr,pdotq ;/A - defb 7 ;/A - db 'No file' ;/A -cld2: - defw abort -; -; - defb 84h ; S->D - defc 'S->D' - defw cold-7 -stod: defw $+2 - pop hl ;/ - ;exts hl ;/ de <-- h(7) - DEFB 0EDH,6Ch - ex de,hl ;/ - jp dpush ; ( n1 -- d1L d1H) -; -; - defb 82h ; +- - defc '+-' - defw STOD-7 -pm: - defw docol - defw zless - defw zbran ; if - defw pm1-$ - defw minus ; endif -pm1: - defw semis -; -; - defb 83h ; D+- - defc 'D+-' - defw pm-5 -dpm: - defw docol - defw zless - defw zbran ; if - defw dpm1-$ - defw dminu ; endif -dpm1: - defw semis -; -; - defb 83h ; ABS - defc 'ABS' - defw dpm-6 -abs: - defw docol - defw dup - defw pm - defw semis -; -; - defb 84h ; DABS - defc 'DABS' - defw abs-6 -dabs: - defw docol - defw dup - defw dpm - defw semis -; -; - defb 83h ; MIN - defc 'MIN' - defw dabs-7 -min: - defw docol - defw tdup - defw great - defw zbran ; if - defw min1-$ - defw swap ; endif -min1: - defw drop - defw semis -; -; - defb 83h ; MAX - defc 'MAX' - defw min-6 -max: defw docol - defw tdup - defw less - defw zbran ; if - defw max1-$ - defw swap ; endif -max1: - defw drop - defw semis -; -; - defb 82h ; M* ( n1 n2 --- d) - defc 'M*' - defw max-6 -mstar: - defw $+2 ;/ - pop de ; de <-- multiplicator - pop hl ; hl <-- multiplicant - ;multw hl,de ;/ dehl <-- hl * de - DEFB 0EDH,0D2h - ex de,hl ;/ - jp dpush ;/ ( n1 n2 --- d1l d1h) -; -; - defb 82h ;/ M/ ( d n1 --- nrem nquot) - defc 'M/' - defw mstar-5 -mslas: - defw $+2 ; ( d n1 --- n2 n3) - exx ; save ip - pop hl ; divisor - ld a,h - and 80h ; filter sign - jr z,mslas1 ; positive - ;neg hl ; make positive - DEFB 0EDH,4Ch -mslas1: - ld b,h - ld c,l ; bc <-- divisor - pop hl ; dividend.hw - pop de ; dividend.lw - bit 7,h ; negative? - jr z,mslas2 ; no - inc a ; dividend sign flag - push hl - ld hl,0 - ;subw hl,de ; neg dividend.lw - DEFB 0EDH,0DEh - pop de ; dividend.hw - push hl - ld hl,0 - sbc hl,de ; neg dividend.hw - pop de ; dividend.lw -mslas2: - ;cpw hl,bc ; dividend.hw >= divisor - DEFB 0EDH,0C7h - jr c,mslas3 ; no overflow, continue - ld hl,0ffffh - ld d,h - ld e,l ; set rem & quot to max. - jr mslas5 -; -mslas3: - ex de,hl ; dehl <-- dividend.hw,lw - ;divuw dehl,bc ; de <-- remainder, hl <-- quotient - DEFB 0EDH,0CBh - ex de,hl ; hl <-- remainder - bit 0,a ; was dividend negative - jr z,mslas4 ; no - ;neg hl ;/ yes, negate remainder - DEFB 0EDH,4Ch -mslas4: - ex de,hl ; hl <-- quotient - or a - jr z,mslas5 ; neither operand negative - cp 81h ; both operands negative? - jr z,mslas5 ; yes, quotient stays positive - ;neg hl ;/ no, negate quotient - DEFB 0EDH,4Ch -mslas5: - push de ; remainder - push hl ; quotient - exx ; restore ip - jnext -; -; - defb 81h ; * ( n1 n2 --- nproduct) - defc '*' - defw mslas-5 -star: - defw $+2 - pop de - pop hl - ;multw hl,de ;/ dehl <-- product - DEFB 0EDH,0D2h - jhpush -; -; - defb 84h ; /MOD ( n1 n2 --- nrem nquot) - defc '/MOD' - defw star-4 -slmod: - defw $+2 - exx ;/ save ip - pop bc ;/ divisor - pop hl ; dividend - ld a,b - or c ;/ div by 0? - jr nz,slmod1 ;/ no, continue - ld de,0ffffh - ld h,d - ld l,e ;/ set remainder & quotient to max. - jr slmod3 -slmod1: - ;cpw hl,8000h ;/ special case -32768 -1 / - DEFB 0FDH - DEFB 0EDH,0F7h - DEFW 8000H - jr nz,slmod2 ;/ continue - ld a,b - cp 0ffh - jr nz,slmod2 - cp c ;/ lo byte also 0ffh? - jr nz,slmod2 ;/ no, go & divide - ld de,0 ;/ remainder - jr slmod3 ;/ exit with dividend unchanged -slmod2: - ;exts hl ;/ de <-- dividend.hw - DEFB 0EDH,6Ch - ;divw dehl,bc ;/ de <-- remainder, hl <-- quotient - DEFB 0EDH,0CAh -slmod3: - push de - push hl - exx ;/ restore ip - jnext -; -; - defb 81h ; / - defc '/' - defw slmod-7 -slash: - defw $+2 - exx ;/ save ip - pop bc ;/ divisor - pop hl ; dividend - ld a,b - or c ;/ division by 0? - jr nz,slash1 ;/ no, continue - ld hl,0ffffh ;/ set quotient to max. - jr slash3 -slash1: - ;cpw hl,8000h ;/ special case -32768 -1 / - DEFB 0FDH - DEFB 0EDH,0F7h - DEFW 8000H - jr nz,slash2 ;/ dividend not -32768 - ld a,b - cp 0ffh - jr nz,slash2 ;/ divisor not -1 - cp c - jr z,slash3 ;/ return with dividend unchanged -slash2: - ;exts hl ;/ de <-- dividend.hw - DEFB 0EDH,6Ch - ;divw dehl,bc ;/ hl <-- quotient - DEFB 0EDH,0CAh -slash3: - push hl ;/ quotient - exx ;/ restore ip - jnext -; -; - defb 83h ;/ MOD - defc 'MOD' - defw slash-4 -modd: - defw $+2 - exx ; save ip - pop bc ; divisor - pop hl ; dividend - ld a,b - or c ; division by 0? - jr nz,modd1 ; no, continue - ld de,0ffffh ; set remainder to max - jr modd3 -modd1: - ;cpw hl,8000h ;/ special case -32768 -1 / - DEFB 0FDH - DEFB 0EDH,0F7h - DEFW 8000H - jr nz,modd2 ; dividend not -32768 - ld a,b - cp 0ffh - jr nz,modd2 ; divisor not -1 - cp c - jr nz,modd2 ; go & divide - ld de,0 ; remainder - jr modd3 -modd2: - ;exts hl ; de <-- dividend.hw - DEFB 0EDH,6Ch - ;divw dehl,bc ; de <-- remainder - DEFB 0EDH,0CAh -modd3: - push de ; remainder - exx ; restore ip - jnext -; -; - defb 85h ;/ */MOD - defc '*/MOD' - defw modd-6 -ssmod: - defw $+2 - exx ; save ip - pop hl ; divisor - ld a,h - and 80h ; filter sign - jr z,ssmod1 ; positive - ;neg hl ; make positive - DEFB 0EDH,4Ch -ssmod1: - ld b,h - ld c,l ; bc <-- divisor - pop hl ; multipicator - pop de ; multiplicant - ex af,af' ; save sign flag - ;multw hl,de ; dehl <-- product (= dividend) - DEFB 0EDH,0D2h - ex af,af' ; restore sign flag - ex de,hl ; de <-- dividend.lw - bit 7,h ; dividend negative? - jr z,ssmod2 ; no - inc a ; dividend sign flag - push hl - ld hl,0 - ;subw hl,de ; neg dividend.lw - DEFB 0EDH,0DEh - pop de ; dividend.hw - push hl - ld hl,0 - sbc hl,de ; neg dividend.hw - pop de ; dividend.lw -ssmod2: - ;cpw hl,bc ; dividend.hw >= divisor? - DEFB 0EDH,0C7h - jr c,ssmod3 ; no overflow, continue - ld hl,0ffffh - ld d,h - ld e,l ; set rem & quot to max - jr ssmod5 -; -ssmod3: - ex de,hl ; dehl <-- dividend.hw,lw - ;divuw dehl,bc ; de <-- remainder, hl <-- quotient - DEFB 0EDH,0CBh - ex de,hl ; hl <-- remainder - bit 0,a ; was dividend negative? - jr z,ssmod4 ; no - ;neg hl ; yes, negate remainder - DEFB 0EDH,4Ch -ssmod4: - ex de,hl ; hl <-- quotient - or a - jr z,ssmod5 ; neither operand negative - cp 81h ; both operands negative? - jr z,ssmod5 ; yes, quotient stays positive - ;neg hl ; no, negate quotient - DEFB 0EDH,4Ch -ssmod5: - push de ; remainder - push hl ; quotient - exx ; restore ip - jnext -; -; - defb 82h ; */ - defc '*/' - defw ssmod-8 -ssla: - defw $+2 ;/ - exx ; save ip - pop hl ; divisor - ld a,h - and 80h ; filter sign - jr z,ssla1 ; positive - ;neg hl ; make positive - DEFB 0EDH,4Ch -ssla1: - ld b,h - ld c,l ; bc <-- divisor - pop hl ; multipicator - pop de ; multiplicant - ex af,af' ; save sign flag - ;multw hl,de ; dehl <-- product (= dividend) - DEFB 0EDH,0D2h - ex af,af' ; restore sign flag - ex de,hl ; de <-- dividend.lw - bit 7,h ; dividend negative? - jr z,ssla2 ; no - inc a ; dividend sign flag - push hl - ld hl,0 - ;subw hl,de ; neg dividend.lw - DEFB 0EDH,0DEh - pop de ; dividend.hw - push hl - ld hl,0 - sbc hl,de ; neg dividend.hw - pop de ; dividend.lw -ssla2: - ;cpw hl,bc ; dividend.hw >= divisor? - DEFB 0EDH,0C7h - jr c,ssla3 ; no overflow, continue - ld hl,0ffffh ; set quotient to max - jr ssla4 -; -ssla3: - ex de,hl ; dehl <-- dividend.hw,lw - ;divuw dehl,bc ; de <-- remainder, hl <-- quotient - DEFB 0EDH,0CBh - or a - jr z,ssla4 ; neither operand negative - cp 81h ; both operands negative? - jr z,ssla4 ; yes, quotient stays positive - ;neg hl ; no, negate quotient - DEFB 0EDH,4Ch -ssla4: - push hl ; quotient - exx ; restore ip - jnext -; -; - defb 85h ; M/MOD - defc 'M/MOD' - defw ssla-5 -msmod: - defw docol - defw tor - defw zero - defw rr - defw uslas - defw fromr - defw swap - defw tor - defw uslas - defw fromr - defw semis -; -; -; Block moved down 2 pages -; - defb 86h ; (LINE) - defc '(LINE)' - defw msmod-8 -pline: - defw docol - defw tor - defw lit - defw 40h - defw bbuf - defw ssmod - defw fromr - defw bscr - defw star - defw plus - defw block - defw plus - defw lit - defw 40h - defw semis -; -; - defb 85h ; .LINE - defc '.LINE' - defw pline-9 -dline: - defw docol - defw pline - defw dtrai - defw type - defw semis -; -; - defb 87h ; MESSAGE - defc 'MESSAGE' - defw dline-8 -mess: - defw docol - defw warn - defw at - defw zbran ; if - defw mess1-$ - defw ddup - defw zbran ; if - defw mess2-$ - defw lit - defw 4 ; 1st message screen - defw ofset - defw at - defw bscr - defw slash - defw subb - defw dline - defw space ; endif -mess2: - defw bran ; else - defw mess3-$ -mess1: - defw pdotq - defb 6 - db 'MSG # ' - defw dot ; endif -mess3: defw semis -; -; - defb 82h ; P@ - defc 'P@' - defw mess-0ah -ptat: - defw $+2 - exx ;d save registers - pop bc ;d bc <-- port# - in l,(c) ;d l <-- data byte - ld h,0 - push hl - exx ;d restore registers - jnext -; -; - defb 82h ; P! - defc 'P!' - defw ptat-5 -ptsto: - defw $+2 - exx ;d save registers - pop bc ;d c <-- port# - pop hl ;d L <-- date byte - out (c),l - exx ;d restore registers - jnext -; -; - page -include DISCIO.Z80 - page -include CONPRTIO.Z80 - page -; - defb 0c1h ; ' (tick) - defb 0a7h - defw arrow-6 -tick: - defw docol - defw dfind - defw zequ - defw zero - defw qerr - defw drop - defw liter - defw semis -; -; - defb 86h ; FORGET - defc 'FORGET' - defw tick-4 -forg: - defw docol - defw curr - defw at - defw cont - defw at - defw subb - defw lit - defw 18h - defw qerr - defw tick - defw dup - defw fence - defw at - defw uless ;/ FORGET >8000h nw o.k. - defw lit - defw 15h - defw qerr - defw dup - defw nfa - defw dp - defw store - defw lfa - defw at - defw cont - defw at - defw store - defw semis -; -; - defb 84h ; BACK - defc 'BACK' - defw forg-9 -back: - defw docol - defw here - defw subb - defw comma - defw semis -; -; - defb 0c5h ; BEGIN - defc 'BEGIN' - defw back-7 -begin: - defw docol - defw qcomp - defw here - defw one - defw semis -; -; - defb 0c5h ; ENDIF - defc 'ENDIF' - defw begin-8 -endiff: - defw docol - defw qcomp - defw two - defw qpair - defw here - defw over - defw subb - defw swap - defw store - defw semis -; -; - defb 0c4h ; THEN - defc 'THEN' - defw endiff-8 -then: defw docol - defw endiff - defw semis -; -; - defb 0c2h ; DO - defc 'DO' - defw then-7 -do: - defw docol - defw comp - defw xdo - defw here - defw three - defw semis -; -; - defb 0c4h ; LOOP - defc 'LOOP' - defw do-5 -loop: - defw docol - defw three - defw qpair - defw comp - defw xloop - defw back - defw semis -; -; - defb 0c5h ; +LOOP - defc '+LOOP' - defw loop-7 -ploop: - defw docol - defw three - defw qpair - defw comp - defw xploo - defw back - defw semis -; -; - defb 0c5h ; UNTIL - defc 'UNTIL' - defw ploop-8 -until: - defw docol - defw one - defw qpair - defw comp - defw zbran - defw back - defw semis -; -; - defb 0c3h ; END - defc 'END' - defw until-8 -endd: - defw docol - defw until - defw semis -; -; - defb 0c5h ; AGAIN - defc 'AGAIN' - defw endd-6 -again: - defw docol - defw one - defw qpair - defw comp - defw bran - defw back - defw semis -; -; - defb 0c6h ; REPEAT - defc 'REPEAT' - defw again-8 -repea: - defw docol - defw tor - defw tor - defw again - defw fromr - defw fromr - defw twomin ;/ - defw endiff - defw semis -; -; - defb 0c2h ; IF - defc 'IF' - defw repea-9 -iff: - defw docol - defw comp - defw zbran - defw here - defw zero - defw comma - defw two - defw semis -; -; - defb 0c4h ; ELSE - defc 'ELSE' - defw iff-5 -elsee: - defw docol - defw two - defw qpair - defw comp - defw bran - defw here - defw zero - defw comma - defw swap - defw two - defw endiff - defw two - defw semis -; -; - defb 0c5h ; WHILE - defc 'WHILE' - defw elsee-7 -while: - defw docol - defw iff - defw twop - defw semis -; -; - defb 86h ; SPACES - defc 'SPACES' - defw while-8 -spacs: - defw docol - defw zero - defw max - defw ddup - defw zbran ; if - defw spax1-$ - defw zero - defw xdo ; do -spax2: - defw space - defw xloop ; loop endif - defw spax2-$ -spax1: - defw semis -; -; - defb 82h ; <# - defc '<#' - defw spacs-9 -bdigs: - defw docol - defw pad - defw hld - defw store - defw semis -; -; - defb 82h ; #> - defc '#>' - defw bdigs-5 -edigs: - defw docol - defw drop - defw drop - defw hld - defw at - defw pad - defw over - defw subb - defw semis -; -; - defb 84h ; SIGN - defc 'SIGN' - defw edigs-5 -sign: - defw docol - defw rot - defw zless - defw zbran ; if - defw sign1-$ - defw lit - defw 2dh - defw hold ; endif -sign1: - defw semis -; -; - defb 81h ; # - defc '#' - defw sign-7 -dig: - defw docol - defw base - defw at - defw msmod - defw rot - defw lit - defw 9 - defw over - defw less - defw zbran ; if - defw dig1-$ - defw lit - defw 7 - defw plus ; endif -dig1: defw lit - defw 30h - defw plus - defw hold - defw semis -; -; - defb 82h ; #S - defc '#S' - defw dig-4 -digs: - defw docol -digs1: - defw dig ; begin - defw tdup ;/ - defw orr - defw zequ - defw zbran ; until - defw digs1-$ - defw semis -; -; - defb 83h ; D.R - defc 'D.R' - defw digs-5 -ddotr: - defw docol - defw tor - defw swap - defw over - defw dabs - defw bdigs - defw digs - defw sign - defw edigs - defw fromr - defw over - defw subb - defw spacs - defw type - defw semis -; -; - defb 82h ; .R - defc '.R' - defw ddotr-6 -dotr: - defw docol - defw tor - defw stod - defw fromr - defw ddotr - defw semis -; -; - defb 82h ; D. - defc 'D.' - defw dotr-5 -ddot: - defw docol - defw zero - defw ddotr - defw space - defw semis -; -; - defb 81h ; . - defc '.' - defw ddot-5 -dot: - defw docol - defw stod - defw ddot - defw semis -; -; - defb 81h ; ? - defc '?' - defw dot-4 -ques: - defw docol - defw at - defw dot - defw semis -; -; - defb 82h ; U. - defc 'U.' - defw ques-4 -udot: defw docol - defw zero - defw ddot - defw semis -; - - defb 85h ; VLIST - defc 'VLIST' - defw udot-5 -vlist: - defw docol - defw lit - defw 80h - defw outt - defw store - defw cont - defw at - defw at -vlis1: - defw outt ; begin - defw at - defw csll - defw great - defw zbran ; if - defw vlis2-$ - defw cr - defw zero - defw outt - defw store ; endif -vlis2: - defw dup - defw iddot - defw space - defw space - defw pfa - defw lfa - defw at - defw dup - defw zequ - defw qterm - defw orr - defw zbran ; until - defw vlis1-$ - defw drop - defw semis -; -; - defb 83h ; BYE - defc 'BYE' - defw vlist-8 -bye: - defw docol ;/A - defw flush ;/A - defw fcb,lit ;/E - defw 10h,bdos ;/E close file - defw drop ;/E discard directory code - defw zero,zero ;/A - defw bdos ;/A return to CP/M - defw semis ;/A won't get this far, just for pretty -; -; - defb 84h ; LIST - defc 'LIST' - defw bye-6 -list: - defw docol,dec - defw cr,dup - defw scr,store - defw pdotq - defb 6 - db 'SCR # ' - defw dot - defw lit,10h - defw zero,xdo -list1: - defw cr,ido - defw three ;/ was lit,3 - defw dotr,space - defw ido,scr - defw at,dline - defw qterm - defw zbran,list2-$ ; if - defw leave -list2: - defw xloop,list1-$ ; endif - defw cr - defw semis -; -; - defb 85H ;INDEX - defc 'INDEX' - defw list-7 -index: - defw docol - defw lit,ff - defw emit - defw cr - defw onep,swap - defw xdo -inde1: - defw cr,ido - defw three ;/ was lit,3 - defw dotr,space - defw zero,ido - defw dline,qterm - defw zbran,inde2-$ ; if - defw leave ; endif -inde2: - defw xloop,inde1-$ - defw semis -; -; - defb 85h ; TRIAD - defc 'TRIAD' - defw index-8 -triad: - defw docol - defw lit,ff - defw emit - defw three ;/ was lit,3 - defw slash - defw three ;/ was lit,3 - defw star - defw three ;/ was lit,3 - defw over,plus - defw swap,xdo -tria1: - defw cr,ido - defw list - defw qterm - defw zbran,tria2-$ ; if - defw leave -tria2: - defw xloop,tria1-$ ; endif - defw cr - defw lit,15 - defw mess,cr - defw semis -; -; - defb 84h ; .CPU - defc '.CPU' - defw triad-8 -dotcpu: - defw docol - defw base,at - defw lit,36 - defw base,store - defw lit,22h - defw porig,tat - defw ddot - defw base,store - defw semis -; -; - defb 86h ; setclk - defc 'setclk' - defw dotcpu-7 -setclk: - defw $+2 - exx ; save ip - ld c,iopreg - ;ldctl hl,(c) ; l <-- current i/o page - DEFB 0EDh,66h - ld a,l - ex af,af' ; save i/o page - ld l,0feh - ;ldctl (c),hl ; select i/o page 0feh - DEFB 0EDh,6Eh - xor a - out (cntrl0),a ; disable c/t 0 - out (cntrl1),a ; disable c/t 1 - out (config1),a - ld hl,0ffffh - ld a,10h - out (config0),a ; cascade c/t 0 - c/t 1 - ld c,tcon0 - ;outw (c),hl ; load c/t 0 time constant - DEFB 0EDH,0BFh - ld c,tcon1 - ;outw (c),hl ; load c/t 1 time constatnt - DEFB 0EDH,0BFh - ld a,80h - out (config1),a ; continous mode - ld a,0e0h - out (cntrl1),a ; start 32bit counter - ex af,af' ; std. accu - ld l,a ; l <-- previous i/o page - ld c,iopreg - ;ldctl (c),hl ; restore i/o page - DEFB 0EDh,6Eh - exx ; restore ip - jnext -; -; - defb 86h ; getclk - defc 'getclk' - defw setclk-9 -getclk: - defw $+2 - exx ; save ip - ld c,iopreg - ;ldctl hl,(c) ; l <-- current i/o page - DEFB 0EDh,66h - ld a,l - ex af,af' ; save current i/o page - ld l,0feh - ;ldctl (c),hl ; select i/o page 0feh - DEFB 0EDh,6Eh - ld a,80h - out (cntrl1),a ; halt 32bit counter - ld c,count1 - ;inw hl,(c) - DEFB 0EDH,0B7h - ld d,h - ld e,l ; de <-- count1 - ld c,count0 - ;inw hl,(c) ; hl <-- count0 - DEFB 0EDH,0B7h - ld c,0 - ld a,c ; a <-- 0 - sub l ; 0 - l - ld l,a ; l <-- neg(l) - ld a,c ; a <-- 0 - sbc a,h - ld h,a ; h <-- neg(h) - ld a,c ; a <-- 0 - sbc a,e - ld e,a ; e <-- neg(e) - ld a,c ; a <-- 0 - sbc a,d - ld d,a ; d <-- neg(d), dehl <-- neg(dehl) - ;divuw dehl,25000 ; scale to 1/100 secs - DEFB 0FDH - DEFB 0EDH,0FBh - DEFW 25000 - push hl ; result - ex af,af' ; std. accu - ld l,a ; l <-- previous i/o page - ld c,iopreg - ;ldctl (c),hl ; restore i/o page - DEFB 0EDh,6Eh - exx ; restore ip - jnext -; -; - defb 84h ; TASK - defc 'TASK' - defw getclk-9 -; defw dotcpu-7 -task: - defw docol - defw semis -; -; -initdp: - defw 0 -; - end orig -defw getclk-9 -; defw dotcpu-7 -task: - defw docol \ No newline at end of file diff --git a/software/CPM/CPM08_Z80FORTH/280FORTH.OCM b/software/CPM/CPM08_Z80FORTH/280FORTH.OCM deleted file mode 100644 index 811e0e8..0000000 Binary files a/software/CPM/CPM08_Z80FORTH/280FORTH.OCM and /dev/null differ diff --git a/software/CPM/CPM08_Z80FORTH/280FORTH.OZ8 b/software/CPM/CPM08_Z80FORTH/280FORTH.OZ8 deleted file mode 100644 index b6af435..0000000 --- a/software/CPM/CPM08_Z80FORTH/280FORTH.OZ8 +++ /dev/null @@ -1,4162 +0,0 @@ - title < Z280 fig-FORTH 1.1 a > - subttl Adaptive version -; -; -; Modified from Z80 fig-FORTH 1.1h by EHR 880830 -; Modified frm FIG document keyed by Dennis L. Wilson 800907 -; Converted frm "8080 FIG-FORTH VERSION A0 15SEP79" -; -; fig-FORTH release 1.1 for the 8080 processor. -; -; ALL PUBLICATIONS OF THE FORTH INTEREST GROUP -; ARE PUBLIC DOMAIN. THEY MAY BE FURTHER -; DISTRIBUTED BY THE INCLUSION OF THIS CREDIT NOTICE: -; -; This publication has been made available by the -; Forth Interest Group -; P.O.Box 1105 -; San Carlos, CA 94070 -; U.S.A. -; -; Implementation on 8080 by: -; John Cassady -; 339 15th Street -; Oakland, CA 94612 -; U.S.A -; on 790528 -; Modified by: -; Kim Harris -; Acknowledgements: -; George Flammer -; Robt. D. Villwock -; ---------------------------------------------------------------------- -; Z80 Version for Cromemco CDOS & Digital Research CP/M by: -; Dennis Lee Wilson c/o -; Aristotelian Logicians -; 2631 East Pinchot Avenue -; Phoenix, AZ 85016 -; U.S.A. -; ---------------------------------------------------------------------- -; The 2 byte Z80 code for Jump Relative (JR) has been substituted for -; the 3 byte Jump (JP) wherever practical. The port I/O words P@ & P! -; have been made ROMable by use of Z80 instructions. -; ---------------------------------------------------------------------- -; Further modifications (marked ;/) by: -; Edmund Ramm -; P.O.Box 38 -; 2358 Kaltenkirchen -; Fed. Rep. of Germany 840418 -; -; 850419 changed * (star) -; 850507 added 0<>, 0>, TUCK, NIP, -ROT, CSWAP, PICK -; 850511 added -CMOVE -; -; ----------------------------------------------------------------------------- -; Disc I/O has been modified a la Albert van der Horst (HCCH) to employ -; CP/M 2.x's random access feature. -; ----------------------------------------------------------------------------- -; ----------------------------------------------------------------------------- -; -; Z280 specifics -; -maclib z280.mac -; -iopreg equ 08h ; i/o page register -; -config0 equ 0e0h ; c/t 0 configuration register -cntrl0 equ 0e1h ; c/t 0 command/status register -tcon0 equ 0e2h ; c/t 0 time constatnt register -count0 equ 0e3h ; c/t 0 count-time register -config1 equ 0e8h ; c/t 1 configuration register -cntrl1 equ 0e9h ; c/t 1 command/status register -tcon1 equ 0eah ; c/t 1 time constant register -count1 equ 0ebh ; c/t 1 count-time register -; -; ----------------------------------------------------------------------------- -; -; Release & Version numbers -; -figrel equ 1 ;FIG RELEASE # -figrev equ 1 ;FIG REVISION # -usrver equ 61h ;USER VERSION # a by EHR -; -;Console & printer drivers are in external source named -;CONPRTIO.FTH & disc drivers in DISCIO.FTH. It has 4 screen -;buffers & end of memory is set to FBASE from locn. 0007H. - page -; ASCII characters used -; -abl equ 20h ;BLANK -acr equ 0dh ;CR -adot equ 2eh ;. -bell equ 07h ;^G -bsin equ 08h ;backspace chr = ^H -bsout equ 08h -dle equ 10h ;^P -lf equ 0ah ;^J -ff equ 0ch ;^L -; -; Memory allocation -; -bdoss equ 0005h ;/ system entry -nscr equ 4 ; # of 1024 byte screens -kbbuf equ 128 ; bytes/disc buffer -us equ 40h ; user variables space -rts equ 400h ; Return Stack & term buff space -co equ kbbuf+4 ; Disc buff + 2 header + 2 tail -nbuf equ nscr*400h/kbbuf ; # of buffers -bufsiz equ co*nbuf ;/ total disc buffer size - page - aseg -; - org 0100h -; -orig: - nop - jp cld ; vector to cold start - nop - jp wrm ; vector to warm start - defb figrel ; fig release # - defb figrev ; fig revision # - defb usrver ; user version # - defb 0eh ; implementation attributes -; -; -; -; 0eh = 0000:1110 -; --------- -; B +ORIGIN ...W:IEBA -; -; W: 0=above sufficient -; 1=other differences exist -; I: Interpreter is 0=pre- -; 1=post incrementing -; E: Addr must be even: 0 yes -; 1 no -; B: High byte @ 0=low addr. -; 1=high addr. -; A: CPU Addr. 0=BYTE -; 1=WORD -; -; -; - defw task-7 ; topmost word in FORTH vocabulary - defw bsin ; backspace chr -upinit: defw 0 ;/ init (up) -; -; * Following used by COLD; must be in same order as user variables * -; -s0init: defw 0 ;/ init (s0) -r0init: defw 0 ;/ init (r0) -tibini: defw 0 ;/ init (TIB) - defw 1fh ; init (WIDTH) - defw 0 ; init (WARNING) - defw initdp ; init (FENCE) - defw initdp ; init (dp) - defw forth+8 ; init (VOC-LINK) -; -; * END DATA USED BY COLD * -; - defw 0018h,0f600h ; Z280 CPU name (hw,lw) - ; (32 bit base 36 integer) - page -; REGISTERS -; -; FORTH Z80 FORTH PRESERVATION RULES -; ----- --- ----------------------- -; IP BC should be preserved -; accross FORTH words. -; W DE sometimes output from -; NEXT, may be altered -; b4 JP'ing to NEXT, -; input only when -; "DPUSH" called. -; SP SP should be used only as -; Data Stack accross -; FORTH words, may be -; used within FORTH -; words if restored -; b4 "NEXT" -; HL Never output frm NEXT -; input only when -; "HPUSH" called -; -; -up: defw 0 ;/ user area ptr -rpp: defw 0 ;/ return stack ptr -buf1: defw 0 ;/ address of 1st disc buffer -; -; -; COMMENT CONVENTIONS: -; -; == means "is equal to" -; <-- means assignment -; #NAME = value of name -; NAME = contents @ name -; (NAME) = contents of cell addressed by name -; cfa = code field address -; lfa = link field address -; nfa = name field address -; pfa = parameter field address -; s1 = 1st word of parameter stack -; s2 = 2nd -"- of -"- -"- -; r1 = 1st -"- of return stack -; r2 = 2nd -"- of -"- -"- -; ( above Stack posn. valid b4 & after execution of any word, not during) -; -; lsb = least significant bit -; msb = most significant bit -; lb = low byte -; hb = high byte -; lw = low word -; hw = high word -; (May be used as suffix to above names) - page -; FORTH ADDRESS INTERPRETER -; POST INCREMENTING VERSION -; -; -; -dpush: - push de -hpush: - push hl ; iy points here -next: - ld h,b ;/ w <-- (ip) ix points here - ld l,c ;/ -; ldw hl,(hl) ;/ (hl) --> cfa - defb 0edh,26h - inc bc - inc bc ;/ ip += 2 -next1: -; ldw de,(hl) ;/ pc <-- (w) - defb 0edh,16h - ex de,hl - inc de - jp (hl) ; note: de <-- cfa + 1 -; -; -jnext macro - jp (ix) - endm -; -jhpush macro - jp (iy) - endm -; - page -; FORTH DICTIONARY -; DICTIONARY FORMAT: -; -; BYTE -; ADDRESS NAME CONTENTS -; ------- ---- -------- -; (MSB=1 -; (P=PRECEDENCE BIT -; (S=SMUDGE BIT -; NFA NAME FIELD 1PS MSB=0, NAME'S 1st CHAR -; 0<2CHAR> -; ... -; 1 MSB=1, NAME'S LAST CHAR -; LFA LINK FIELD =PREVIOUS WORD'S NFA -; -;LABEL: CFA CODE FIELD =ADDR CPU CODE -; -; PFA PARAMETER <1PARAM> 1st PARAMETER BYTE -; FIELD <2PARAM> -; ... -; -; -; -dp0: - defb 83h ; LIT - defc 'LIT' - defw 0 ; lfa == 0 marks end of dictionary -lit: - defw $+2 ; s1 <-- (ip) - ld h,b - ld l,c - defb 0edh,26h ;/ ldw hl,(hl) hl <-- (ip) = literal - inc bc ;/ - inc bc ;/ ip += 2 - jhpush ; s1 <-- hl -; -; - defb 87h ; EXECUTE - defc 'EXECUTE' - defw lit-6 -exec: - defw $+2 - pop hl - jp next1 -; -; - defb 86h ; BRANCH - defc 'BRANCH' - defw exec-0ah -bran: - defw $+2 ; ip += (ip) -bran1: - ld h,b - ld l,c ; hl <-- ip - defb 0ddh,0edh,0c6h ;/ addw hl,(hl) hl <-- ip + branch offset - ld c,l - ld b,h ; ip += branch offset - jnext -; -; - defb 87h ; 0BRANCH - defc '0BRANCH' - defw bran-9 -zbran: - defw $+2 - pop hl - ld a,l - or h - jr z,bran1 ; branch if if s1 == 0 - inc bc ; else skip branch offset - inc bc - jnext -; -; - defb 86h ; (LOOP) - defc '(LOOP)' - defw zbran-0ah -xloop: - defw $+2 - ld hl,(rpp) ; (hl) --> index = r1 -; incw (hl) ;/ index += 1 - defb 0ddh,03h -; ldw de,(hl) ;/ de <-- new index - defb 0edh,16h - inc hl ;/ - inc hl ;/ hl --> limit(lb) - ld a,e - sub (hl) - ld a,d - inc hl ; hl --> limit(hb) - sbc a,(hl) ; index < limit? - jp m,bran1 ; yes, loop again - inc hl ; no, done - ld (rpp),hl ; discard r1 & r2 - inc bc - inc bc ; skip branch offset - jnext -; -; - defb 87h ; (+LOOP) - defc '(+LOOP)' - defw xloop-9 -xploo: - defw $+2 - pop de ; de <-- increment - ld hl,(rpp) ; hl --> index - ld a,(hl) ; index += increment - add a,e - ld (hl),a - ld e,a - inc hl - ld a,(hl) - adc a,d - ld (hl),a - inc hl ; (hl) --> limit - inc d - dec d - ld d,a ; de <-- new index - jp m,xloo2 ; if incr > 0 - ld a,e - sub (hl) ; then a <-- index - limit - ld a,d - inc hl - sbc a,(hl) - jp xloo3 - -xloo2: - ld a,(hl) ; else a <-- limit - index - sub e - inc hl - ld a,(hl) - sbc a,d -; ; if a < 0 -xloo3: - jp m,bran1 ; then loop again - inc hl ; else done - ld (rpp),hl ; discard r1 & r2 - inc bc ; skip branch offset - inc bc - jnext -; -; - defb 84h ; (DO) - defc '(DO)' - defw xploo-0ah -xdo: - defw $+2 - pop de ; de <-- initial index - ld hl,(rpp) ; hl <-- rp - dec hl - dec hl -; pop (hl) ;/ r2 <-- limit - defb 0ddh,0c1h - dec hl - dec hl -; ldw (hl),de ;/ r1 <-- initial index - defb 0edh,1eh - ld (rpp),hl ; rp -= 4 - jnext -; -; - defb 81h ; I - defc 'I' - defw xdo-7 -ido: - defw $+2 - ld hl,(rpp) -; push (hl) ;/ s1 <-- r1, r1 unchanged - defb 0ddh,0c5h - jnext -; -; - defb 85h ; DIGIT - defc 'DIGIT' - defw ido-4 -digit: - defw $+2 - pop hl ; l <-- s1.lb = base value - pop de ; e <-- s2.lb = chr to be converted - ld a,e ; a <-- chr - sub '0' ; >= 0? - jr c,digi2 ;/ < 0 is invalid - cp 0ah ; > 9? - jr c,digi1 ;/ no, test base value - sub 07h ; gap between '9' & 'A', nw 'A'=0ah - cp 0ah ; >= 'A'? - jr c,digi2 ;/ chrs btwn '9' & 'A' are invalid -digi1: - cp l ; < base value? - jr nc,digi2 ;/ no, invalid - ld e,a ; s2 <-- de = converted digit - ld hl,0001h ; s1 <-- true - jp dpush -; -digi2: - ld l,h ; hl <-- false - jhpush ; s1 <-- false -; -; - defb 86h ; (FIND) (2-1)FAILURE - defc '(FIND)' ; (2-3)SUCCESS - defw digit-8 -pfind: - defw $+2 - pop de ; de <-- nfa -pfin1: - pop hl ; hl <-- string addr - push hl ; save for next iteration - ld a,(de) - xor (hl) ; filter differences - and 3fh ; mask msb & precedence bit - jr nz,pfin4 ; lengths differ -pfin2: - inc hl ; hl --> next string chr - inc de ; de --> next name field chr - ld a,(de) - xor (hl) ; filter differences - add a,a ; shift msbit into carry - jr nz,pfin3 ; no match - jr nc,pfin2 ; match so far, loop agn - ld hl,0005h ; string matches - add hl,de ; (sp) <-- pfa - ex (sp),hl -pfin6: - dec de ; de --> nfa - ld a,(de) - or a ; msb=1? =length byte - jp p,pfin6 ; no, try next chr - ld e,a ; e <-- length byte - ld d,00h - ld hl,0001h ; hl <-- true - jp dpush ; name field found, return -; -; above name field not a match, try next one -; -pfin3: - jr c,pfin5 ; carry=end of name field -pfin4: - inc de ; find name field end - ld a,(de) - or a ; msb=1? - jp p,pfin4 ; no, loop -pfin5: - inc de ; de <-- lfa - ex de,hl -; ldw de,(hl) ;/ de <-- lfa - defb 0edh,16h - ld a,d - or e ; end of dictionary (lfa = 0)? - jr nz,pfin1 ; no, try previous definition - pop hl ; drop string address - ld hl,0 ; hl <-- false - jhpush ; no match found, return -; -; - defb 87h ; ENCLOSE - defc 'ENCLOSE' - defw pfind-9 -encl: - defw $+2 - pop de ; de <-- s1 = delimiter chr - pop hl ; hl <-- s2 = addr of text to scan - push hl ; s4 <-- addr - ld a,e - ld d,a ; d <-- delim chr - ld e,-1 ; init chr offset counter - dec hl ; hl <-- addr - 1 -encl1: - inc hl ; skip over leading delim chrs - inc e - cp (hl) ; delim chr? - jr z,encl1 ; yes, loop - ld d,0 - push de ; s3 <-- e = offset to 1st non delim - ld d,a ; d <-- delim chr - ld a,(hl) - and a ; 1st non-delim=null? - jr nz,encl2 ; no - ld d,0 ; yes - inc e - push de ; s2 <-- offset to byte following null - dec e - push de ; s1 <-- offset to null - jnext -; -encl2: - ld a,d ; A <-- delim chr - inc hl ; hl <-- next chr's address - inc e ; e <-- offset to next chr - cp (hl) ; delim chr? - jr z,encl4 ; yes - ld a,(hl) - and a ; null? - jr nz,encl2 ; no, continue scan -encl3: - ld d,0 - push de ; s2 <-- offset to null - push de ; s1 <-- offset to null - jnext -; -encl4: - ld d,0 - push de ; s2 <-- offset to byte following text - inc e - push de ; s1 <-- offset 2 bytes aft end of word - jnext -; -; - defb 84h ; EMIT - defc 'EMIT' - defw encl-0ah -emit: - defw docol - defw pemit - defw one,outt - defw pstor,semis -; -; - defb 83h ; KEY - defc 'KEY' - defw emit-7 -key: - defw $+2 - jp pkey -; -; - defb 89h ; ?TERMINAL - defc '?TERMINAL' - defw key-6 -qterm: - defw $+2 - ld hl,0 - jp pqter -; -; - defb 82h ; CR - defc 'CR' - defw qterm-0ch -cr: - defw $+2 - jp pcr -; -; - defb 85h ; CMOVE - defc 'CMOVE' - defw cr-5 -cmove: - defw $+2 - exx ;/ save ip - pop bc ; bc <-- s1 = # of chrs - pop de ; de <-- s2 = dest addr - pop hl ;/ hl <-- s3 = source addr - ld a,b - or c ; bc=0? - jr z,cmove1 ; yes, nothing to move - ldir ;/ xfer string -cmove1: - exx ;/ restore ip - jnext -; -; - defb 86h ;/ -CMOVE ( from to count --- ) - defc '-CMOVE' - defw cmove-8 -bcmov: - defw $+2 - exx ; save ip - pop bc ; bc <-- count - pop de ; de <-- destination - pop hl ; hl <-- source - ld a,b - or c ; bc =0? - jr z,bcmov1 ; yes, nothing to move - add hl,bc - dec hl ; hl --> hi end of source block - ex de,hl - add hl,bc - dec hl - ex de,hl ; de --> hi end of dest. block - lddr ; (de) <-- (hl), --hl,bc until bc=0 -bcmov1: - exx ; restore ip - jnext -; -; - defb 82h ; U* 16*16 unsigned multiply - defc 'U*' ; with 32 bit result - defw bcmov-9 -ustar: - defw $+2 - pop de ; de <-- multiplier - pop hl ; hl <-- multiplicant -; multuw hl,de ;/ - defb 0edh,0d3h - ex de,hl ;/ de <-- product.lw, hl <-- product.hw - jp dpush ; s2,s1 <-- product.lw,hw -; -; - defb 82h ; U/ ( ud u1 -- urem uq ) - defc 'U/' - defw ustar-5 -uslas: - defw $+2 - exx ;/ save ip - pop bc ; bc <-- divisor - pop hl ; hl <-- dividend.hw - pop de ; de <-- dividend.lw -; cpw hl,bc ;/ dividend.hw >= divisor? - defb 0edh,0c7h - jr c,usla1 ; no, go ahead - ld hl,0ffffh ; yes, overflow - ld d,h - ld e,l ;/ set rem & quot to max - jr usla2 -usla1: - ex de,hl ;/ de,hl <-- dividend.hw,lw -; divuw dehl,bc ;/ de <-- remainder, hl <-- quotient - defb 0edh,0cbh -usla2: - push de ;/ s2 <-- remainder - push hl ;/ s1 <-- quotient - exx ;/ restore ip - jnext -; -; - defb 83h ; AND - defc 'AND' - defw uslas-5 -andd: - defw $+2 ; s1 <-- s1 AND s2 - pop de - pop hl - ld a,e - and l - ld l,a - ld a,d - and h - ld h,a - jhpush -; -; - defb 82h ; OR - defc 'OR' - defw andd-6 -orr: - defw $+2 ; s1 <-- s1 OR s2 - pop de - pop hl - ld a,e - or l - ld l,a - ld a,d - or h - ld h,a - jhpush -; -; - defb 83h ; XOR - defc 'XOR' - defw orr-5 -xorr: - defw $+2 ; s1 <-- s1 XOR s2 - pop de - pop hl - ld a,e - xor l - ld l,a - ld a,d - xor h - ld h,a - jhpush -; -; - defb 83h ; SP@ - defc 'SP@' - defw xorr-6 -spat: - defw $+2 - ld hl,0 - add hl,sp ; hl <-- sp - jhpush ; s1 <-- sp -; -; - defb 83h ; SP! - defc 'SP!' - defw spat-6 -spsto: - defw $+2 ; sp <-- s0 (user variable) - ld hl,(up) ; hl <-- user variables base address - ld de,0006h - add hl,de ; hl --> s0 -; ldw hl,(hl) ;/ hl <-- s0 - defb 0edh,26h - ld sp,hl ; sp <-- s0 - jnext -; -; - defb 83h ; RP@ - defc 'RP@' - defw spsto-6 -rpat: - defw $+2 - ld hl,(rpp) - jhpush ; s1 <-- rp -; -; - defb 83h ; RP! - defc 'RP!' - defw rpat-6 -rpsto: - defw $+2 ; rp <-- r0 (user variable) - ld hl,(up) ; hl <-- user variables base address - ld de,0008h - add hl,de ; hl --> r0 -; ldw hl,(hl) ;/ hl <-- r0 - defb 0edh,26h - ld (rpp),hl ;/ rp <-- r0 - jnext -; -; - defb 82h ; ;S - defc ';S' - defw rpsto-6 -semis: - defw $+2 ; ip <-- r1 - ld hl,(rpp) -; ldw bc,(hl) ;/ bc <-- r1 - defb 0edh,06h - inc hl - inc hl - ld (rpp),hl ; rp += 2 - jnext -; -; - defb 85h ; LEAVE - defc 'LEAVE' - defw semis-5 -leave: - defw $+2 ; limit <-- index - ld hl,(rpp) -; ldw de,(hl) ;/ de <-- r1 (= index) - defb 0edh,16h - inc hl - inc hl -; ldw (hl),de ;/ r2 (= limit) <-- index - defb 0edh,1eh - jnext -; -; - defb 82h ; >R - defc '>R' - defw leave-8 -tor: - defw $+2 - ld hl,(rpp) - dec hl - dec hl -; pop (hl) ;/ r1 <-- s1 - defb 0ddh,0c1h - ld (rpp),hl ; rp -= 2 - jnext -; -; - defb 82h ; R> - defc 'R>' - defw tor-5 -fromr: - defw $+2 - ld hl,(rpp) -; push (hl) ;/ s1 <-- r1 - defb 0ddh,0c5h - inc hl - inc hl - ld (rpp),hl ; rp += 2 - jnext -; -; - defb 81h ; R - defc 'R' - defw fromr-5 -rr: - defw ido+2 -; -; - defb 82h ; 0= - defc '0=' - defw rr-4 -zequ: - defw $+2 - pop de - ld hl,0 -; cpw hl,de ;/ - defb 0edh,0d7h - jr nz,zequ1 - inc l ; hl <-- true -zequ1: - jhpush -; -; - defb 83h ;/ 0<> - defc '0<>' - defw zequ-5 -znequ: - defw $+2 - pop de - ld hl,0 -; cpw hl,de ;/ - defb 0edh,0d7h - jr z,znequ1 - inc l ; hl <-- true -znequ1: - jhpush -; -; - defb 82h ; 0< - defc '0<' - defw znequ-6 -zless: - defw $+2 - pop af ;/ a <-- s1.hb - rla ;/ carry <-- bit 7 - ld hl,0 ; hl <-- false - rl l ;/ bit 0 <-- carry - jhpush -; -; - defb 82h ;/ 0> - defc '0>' - defw zless-5 -zgt: - defw $+2 - pop de - ld hl,0 -; cpw hl,de ;/ - defb 0edh,0d7h - jp p,zgt1 ;/ <= 0 - jp pe,zgt1 ;/ 8000h special case - inc l ;/ hl <-- true -zgt1: - jhpush -; -; - defb 81h ;+ - defc '+' - defw zgt-5 -plus: - defw $+2 - pop de - pop hl - add hl,de - jhpush -; -; - defb 82h ; D+ ( d1l d1h d2l d2h -- d3l d3h) - defc 'D+' - defw plus-4 -dplus: - defw $+2 - exx ;/ save ip - pop bc ; bc <-- d2.hw - pop hl ; hl <-- d2.lw - pop af ;d af <-- d1.hw - pop de ; de <-- d1.lw - push af ;/ s1 <-- d1.hw - add hl,de ; hl <-- d2.lw + d1.lw (= d3.lw) - ex de,hl ; de <-- d3.lw - pop hl ; hl <-- d1.hw - adc hl,bc ;/ hl <-- d1.hw + d2.hw +carry (=d3.hw) - push de ; s2 <-- d3.lw - push hl ;/ s1 <-- d3.hw - exx ;/ restore ip - jnext -; -; - defb 85h ; MINUS - defc 'MINUS' - defw dplus-5 -minus: - defw $+2 - pop hl ;/ -; neg hl ;/ - defb 0edh,4ch - jhpush -; -; - defb 86h ; DMINUS - defc 'DMINUS' - defw minus-8 -dminu: - defw $+2 - exx ;/ save ip - pop de ;/ de <-- d1.hw - pop bc ;/ bc <-- d1.lw - ld hl,0 ;/ -; subw hl,bc ;/ - defb 0edh,0ceh - push hl ; s2 <-- d2.lw - ld hl,0 ;/ - sbc hl,de ;/ - push hl ; s1 <-- d2.hw - exx ;/ - jnext -; -; - defb 84h ; OVER - defc 'OVER' - defw dminu-9 -over: - defw $+2 -; ldw hl,(sp+2) ;/ - defb 0edh,04h,02h,00h - jhpush ;/ -; -; - defb 84h ; DROP - defc 'DROP' - defw over-7 -drop: - defw $+2 - inc sp - inc sp ;/ faster on z280 than dummy pop - jnext -; -; - defb 84h ; SWAP - defc 'SWAP' - defw drop-7 -swap: - defw $+2 - pop hl - ex (sp),hl - jhpush -; -; - defb 83h ; DUP - defc 'DUP' - defw swap-7 -dup: - defw $+2 -; ldw hl,(sp+0) ;/ - defb 0edh,04h,0,0 - jhpush -; -; - defb 84h ;/ TUCK ( n1 n2 --- n2 n1 n2) - defc 'TUCK' - defw dup-6 -tuck: - defw $+2 - pop hl ;/ hl <-- s1 - pop de ;/ de <-- s2 - push hl ;/ s3 <-- hl - jp dpush -; -; - defb 83h ;/ NIP ( n1 n2 --- n2) - defc 'NIP' - defw tuck-7 -nip: - defw $+2 - pop hl ; hl <-- s1 -; ldw (sp+0),hl ;/ s1 <-- hl - defb 0edh,05h,0,0 - jnext -; -; - defb 84h ;/ -ROT ( n1 n2 n3 --- n3 n1 n2) - defc '-ROT' - defw nip-6 -mrot: - defw $+2 - pop hl - pop de - ex (sp),hl - ex de,hl - jp dpush -; -; - defb 85h ;/ CSWAP ( n1 --- n1, bytes swapped) - defc 'CSWAP' - defw mrot-7 -cswap: - defw $+2 - pop hl -; ex h,l ;/ - defb 0edh,0efh - jhpush -; -; - defb 84h ;/ PICK ( nn...n0 k --- nn..n0 nk) - defc 'PICK' - defw cswap-8 -pick: - defw $+2 - pop hl ; hl <-- depth - add hl,hl ; adjust to word size - add hl,sp ; offset into stack -; push (hl) ;/ - defb 0ddh,0c5h - jnext -; -; - defb 84h ; 2DUP - defc '2DUP' - defw pick-7 -tdup: - defw $+2 - pop hl - pop de - push de - push hl - jp dpush -; -; - defb 82h ; +! - defc '+!' - defw tdup-7 -pstor: - defw $+2 - pop hl ; hl --> variable - pop de ; de <-- number - ld a,(hl) - add a,e - ld (hl),a - inc hl - ld a,(hl) - adc a,d - ld (hl),a ; (hl) += number - jnext -; -; - defb 86h ; TOGGLE - defc 'TOGGLE' - defw pstor-5 -toggl: - defw $+2 - pop de ; e <-- bit pattern - pop hl ; hl --> address - ld a,(hl) - xor e - ld (hl),a - jnext -; -; - defb 81h ; @ - defc '@' - defw toggl-9 -at: - defw $+2 - pop hl -; push (hl) ;/ - defb 0ddh,0c5h - jnext -; -; - defb 82h ; C@ - defc 'C@' - defw at-4 -cat: - defw $+2 - pop hl - ld l,(hl) - ld h,0 - jhpush -; -; - defb 82h ; 2@ - defc '2@' - defw cat-5 -tat: - defw $+2 - pop hl ; hl --> address -; ldw de,(hl) ;/ de <-- d.hw - defb 0edh,16h - inc hl - inc hl ; hl --> d.lw -; push (hl) ;/ s2 <-- d.lw - defb 0ddh,0c5h - push de ;/ s1 <-- d.hw - jnext -; -; - defb 81h ; ! - defc '!' - defw tat-5 -store: - defw $+2 - pop hl ; hl --> address -; pop (hl) ;/ - defb 0ddh,0c1h - jnext -; -; - defb 82h ; C! - defc 'C!' - defw store-4 -cstor: - defw $+2 - pop hl ; hl --> address - pop de ; e <-- char - ld (hl),e - jnext -; -; - defb 82h ; 2! - defc '2!' - defw cstor-5 -tstor: - defw $+2 - pop hl ; hl --> address -; pop (hl) ;/ store d.hw - defb 0ddh,0c1h - inc hl - inc hl -; pop (hl) ;/ store d.lw - defb 0ddh,0c1h - jnext -; -; - defb 0c1h ; : - defc ':' - defw tstor-5 -colon: - defw docol - defw qexec - defw scsp - defw curr - defw at - defw cont - defw store - defw creat - defw rbrac - defw pscod -docol: - ld hl,(rpp) - dec hl - dec hl -; ldw (hl),bc ;/ save return address - defb 0edh,0eh - ld (rpp),hl - inc de - ld c,e - ld b,d - jnext -; -; - defb 0c1h ; ; - defc ';' - defw colon-4 -semi: - defw docol - defw qcsp - defw comp - defw semis - defw smudg - defw lbrac - defw semis -; -; - defb 84h ; NOOP - defc 'NOOP' - defw semi-4 -noop: - defw docol - defw semis -; -; - defb 88h ; CONSTANT - defc 'CONSTANT' - defw noop-7 -con: - defw docol - defw creat - defw smudg - defw comma - defw pscod -docon: - inc de - ex de,hl -; push (hl) ;/ - defb 0ddh,0c5h - jnext -; -; - defb 88h ; VARIABLE - defc 'VARIABLE' - defw con-0bh -var: - defw docol - defw con - defw pscod -dovar: - inc de - push de - jnext -; -; - defb 84h ; USER - defc 'USER' - defw var-0bh -user: - defw docol - defw con - defw pscod -douse: - inc de - ex de,hl - ld l,(hl) ;/ - ld h,0 ;/ -; addw hl,(up) ;/ - defb 0ddh,0edh,0d6h - defw up - jhpush -; -; - defb 81h ; 0 - defc '0' - defw user-7 -zero: - defw $+2 ;/ -; push 0000h ;/ - defb 0fdh,0f5h,0,0 - jnext -; -; - defb 81h ; 1 - defc '1' - defw zero-4 -one: - defw $+2 ;/ -; push 0001h ;/ - defb 0fdh,0f5h,1,0 - jnext -; -; - defb 81h ; 2 - defc '2' - defw one-4 -two: - defw $+2 ;/ -; push 0002h ;/ - defb 0fdh,0f5h,2,0 - jnext -; -; - defb 81h ; 3 - defc '3' - defw two-4 -three: - defw $+2 ;/ -; push 0003h ;/ - defb 0fdh,0f5h,3,0 - jnext -; -; - defb 82h ; BL - defc 'BL' - defw three-4 -bl: - defw docon - defw 20h -; -; - defb 83h ; C/L - defc 'C/L' - defw bl-5 -csll: - defw docon - defw 64 -; -; - defb 85h ; FIRST - defc 'FIRST' - defw csll-6 -first: - defw docon - defw 0 ;/ set by CLD -; -; - defb 85h ; LIMIT - defc 'LIMIT' - defw first-8 -limit: - defw docon - defw 0 ;/ set by CLD -; -; - defb 85h ; B/BUF - defc 'B/BUF' - defw limit-8 -bbuf: - defw docon - defw kbbuf -; -; - defb 85h ; B/SCR - defc 'B/SCR' - defw bbuf-8 -bscr: - defw docon - defw 400h/kbbuf -; -; - defb 87h ; +ORIGIN - defc '+ORIGIN' - defw bscr-8 -porig: - defw docol - defw lit - defw orig - defw plus - defw semis -; -; USER VARIABLES -; - defb 82h ; S0 - defc 'S0' - defw porig-0ah -szero: - defw douse - defw 6 -; -; - defb 82h ; R0 - defc 'R0' - defw szero-5 -rzero: - defw douse - defw 8 -; -; - defb 83h ; TIB - defc 'TIB' - defw rzero-5 -tib: - defw douse - defb 0ah -; -; - defb 85h ; WIDTH - defc 'WIDTH' - defw tib-6 -width: - defw douse - defb 0ch -; -; - defb 87h ; WARNING - defc 'WARNING' - defw width-8 -warn: - defw douse - defb 0eh -; -; - defb 85h ; FENCE - defc 'FENCE' - defw warn-0ah -fence: - defw douse - defb 10h -; -; - defb 82h ; DP - defc 'DP' - defw fence-8 -dp: - defw douse - defb 12h -; -; - defb 88h ; VOC-LINK - defc 'VOC-LINK' - defw dp-5 -vocl: - defw douse - defw 14h -; -; - defb 83h ; BLK - defc 'BLK' - defw vocl-0bh -blk: - defw douse - defb 16h -; -; - defb 82h ; IN - defc 'IN' - defw blk-6 -inn: - defw douse - defb 18h -; -; - defb 83h ; OUT - defc 'OUT' - defw inn-5 -outt: - defw douse - defb 1ah -; -; - defb 83h ; SCR - defc 'SCR' - defw outt-6 -scr: - defw douse - defb 1ch -; -; - defb 86h ; OFFSET - defc 'OFFSET' - defw scr-6 -ofset: - defw douse - defb 1eh -; -; - defb 87h ; CONTEXT - defc 'CONTEXT' - defw ofset-9 -cont: - defw douse - defb 20h -; -; - defb 87h ; CURRENT - defc 'CURRENT' - defw cont-0ah -curr: - defw douse - defb 22h -; -; - defb 85h ; STATE - defc 'STATE' - defw curr-0ah -state: - defw douse - defb 24h -; -; - defb 84h ; BASE - defc 'BASE' - defw state-8 -base: - defw douse - defb 26h -; -; - defb 83h ; DPL - defc 'DPL' - defw base-7 -dpl: - defw douse - defb 28h -; -; - defb 83h ; FLD - defc 'FLD' - defw dpl-6 -fld: - defw douse - defb 2ah -; -; - defb 83h ; CSP - defc 'CSP' - defw fld-6 -cspp: - defw douse - defb 2ch -; - - defb 82h ; R# - defc 'R#' - defw cspp-6 -rnum: - defw douse - defb 2eh -; - - defb 83h ; HLD - defc 'HLD' - defw rnum-5 -hld: - defw douse - defw 30h -; -; END OF USER VARIABLES -; - defb 82h ; 1+ - defc '1+' - defw hld-6 -onep: - defw $+2 ;/ - pop hl ;/ - inc hl ;/ - jhpush ;/ -; -; - defb 82h ; 2+ - defc '2+' - defw onep-5 -twop: - defw $+2 ;/ - pop hl ;/ - inc hl ;/ - inc hl ;/ - jhpush ;/ -; -; - defb 82h ;/ 1- - defc '1-' ;/ - defw twop-5 ;/ -onemin: - defw $+2 ;/ - pop hl ;/ - dec hl ;/ - jhpush ;/ -; -; - defb 82h ;/ 2- - defc '2-' ;/ - defw onemin-5 ;/ -twomin: - defw $+2 ;/ - pop hl ;/ - dec hl ;/ - dec hl ;/ - jhpush ;/ -; -; - defb 82h ;/ 2* - defc '2*' ;/ - defw twomin-5 ;/ -twosta: - defw $+2 ;/ - pop hl ;/ - add hl,hl ;/ asl hl - jhpush ;/ -; -; - defb 82h ;/ 2/ - defc '2/' ;/ - defw twosta-5 ;/ -twosla: - defw $+2 ;/ - pop hl ;/ - bit 7,h ;/ negative? - jr z,twosl1 ;/ no - inc hl ;/ yes, add 1 -twosl1: - sra h ;/ - rr l ;/ asr hl - jhpush ;/ -; -; - defb 84h ; HERE - defc 'HERE' - defw twosla-5 -here: - defw docol - defw dp - defw at - defw semis -; -; - defb 85h ; ALLOT - defc 'ALLOT' - defw here-7 -allot: - defw docol - defw dp - defw pstor - defw semis -; -; - defb 81h ; , - defc ',' - defw allot-8 -comma: - defw docol - defw here - defw store - defw two - defw allot - defw semis -; - - defb 82h ; C, - defc 'C,' - defw comma-4 -ccomm: - defw docol - defw here - defw cstor - defw one - defw allot - defw semis -; -; - defb 81h ; - - defc '-' - defw ccomm-5 -subb: - defw $+2 - pop de - pop hl -; subw hl,de ;/ - defb 0edh,0deh - jhpush -; -; - defb 81h ; = - defc '=' - defw subb-4 -equal: - defw $+2 ;/ - pop de ;/ - pop hl ;/ -; subw hl,de ;/ - defb 0edh,0deh - ld hl,0 ; hl <-- false - jr nz,equal1 - inc l ;/ hl <-- true -equal1: - jhpush -; -; - defb 81h ; < - defc '<' - defw equal-4 -less: - defw $+2 - pop de - pop hl ; hl de < - ld a,d - xor h ; one operand negative? - jp m,less1 ; yes, determine which -; subw hl,de ;/ - defb 0edh,0deh -less1: - bit 7,h ;/ h negative? - ld hl,0 ; hl <-- false - jr z,less2 - inc l ;/ hl <-- true -less2: - jhpush -; -; - defb 82h ; U< - defc 'U<' - defw less-4 -uless: - defw $+2 - pop de - pop hl ;/ hl de U< -; subw hl,de ;/ - defb 0edh,0deh - ld hl,0 ; hl <-- false - rl l ;/ bit 0 <-- carry -uless1: - jhpush -; -; - defb 81h ; > - defc '>' - defw uless-5 -great: - defw $+2 - pop hl ;/ - pop de ;/ hl de > (= de hl < ) - ld a,d - xor h ; one operand negative? - jp m,great1 ; yes, determine which -; subw hl,de ;/ - defb 0edh,0deh -great1: - bit 7,h ;/ h negative? - ld hl,0 ; hl <-- false - jr z,great2 - inc l ;/ hl <-- true -great2: - jhpush -; -; - defb 83h ; ROT ( n1 n2 n3 --- n2 n3 n1) - defc 'ROT' - defw great-4 -rot: - defw $+2 - pop de ; de <-- n3 - pop hl ; hl <-- n2 - ex (sp),hl ; s1 <-- n2, hl <-- n1 - jp dpush ; s2 <-- n3, s3 <-- n1 -; -; - defb 85h ; SPACE - defc 'SPACE' - defw rot-6 -space: - defw docol - defw bl - defw emit - defw semis -; -; - defb 84h ; -DUP - defc '-DUP' - defw space-8 -ddup: - defw $+2 ;/ -; ldw hl,(sp+0) ;/ - defb 0edh,04h,0,0 - ld a,h ;/ - or l ;/ hl = 0? - jr z,ddup1 ;/ yes, don't dup - push hl ;/ -ddup1: - jnext -; -; - defb 88h ; TRAVERSE - defc 'TRAVERSE' - defw ddup-7 -trav: - defw docol - defw swap -trav1: - defw over ; begin - defw plus - defw lit - defw 7fh - defw over - defw cat - defw less - defw zbran ; until - defw trav1-$ - defw swap - defw drop - defw semis -; -; - defb 86h ; LATEST - defc 'LATEST' - defw trav-0bh -lates: - defw docol - defw curr - defw at - defw at - defw semis -; -; - defb 83h ; LFA - defc 'LFA' - defw lates-9 -lfa: - defw $+2 - pop hl ;/ hl <-- pfa -; subw hl,4 ;/ - defb 0fdh,0edh,0feh,4,0 - jhpush ;/ s1 <-- lfa -; -; - defb 83h ; CFA - defc 'CFA' - defw lfa-6 -cfa: - defw docol - defw twomin ;/ - defw semis -; -; - defb 83h ; NFA - defc 'NFA' - defw cfa-6 -nfa: - defw docol - defw lit - defw 5 - defw subb - defw lit - defw -1 - defw trav - defw semis -; -; - defb 83h ; PFA - defc 'PFA' - defw nfa-6 -pfa: - defw docol - defw one - defw trav - defw lit - defw 5 - defw plus - defw semis -; -; - defb 84h ; !CSP - defc '!CSP' - defw pfa-6 -scsp: - defw docol - defw spat - defw cspp - defw store - defw semis -; -; - defb 86h ; ?ERROR - defc '?ERROR' - defw scsp-7 -qerr: - defw docol - defw swap - defw zbran ; if - defw qerr1-$ - defw error - defw bran ; else - defw qerr2-$ -qerr1: - defw drop ; endif -qerr2: - defw semis -; -; - defb 85h ; ?COMP - defc '?COMP' - defw qerr-9 -qcomp: - defw docol - defw state - defw at - defw zequ - defw lit - defw 11h - defw qerr - defw semis -; -; - defb 85h ; ?EXEC - defc '?EXEC' - defw qcomp-8 -qexec: - defw docol - defw state - defw at - defw lit - defw 12h - defw qerr - defw semis -; -; - defb 86h ; ?PAIRS - defc '?PAIRS' - defw qexec-8 -qpair: - defw docol - defw subb - defw lit - defw 13h - defw qerr - defw semis -; -; - defb 84h ; ?CSP - defc '?CSP' - defw qpair-9 -qcsp: - defw docol - defw spat - defw cspp - defw at - defw subb - defw lit - defw 14h - defw qerr - defw semis -; -; - defb 88h ; ?LOADING - defc '?LOADING' - defw qcsp-7 -qload: - defw docol - defw blk - defw at - defw zequ - defw lit - defw 16h - defw qerr - defw semis -; -; - defb 87h ; COMPILE - defc 'COMPILE' - defw qload-0bh -comp: - defw docol - defw qcomp - defw fromr - defw dup - defw twop - defw tor - defw at - defw comma - defw semis -; -; - defb 0c1h ; [ - defc '[' - defw comp-0ah -lbrac: - defw docol - defw zero - defw state - defw store - defw semis -; -; - defb 81h ; ] - defc ']' - defw lbrac-4 -rbrac: - defw docol - defw lit,0c0h - defw state,store - defw semis -; -; - defb 86h ; SMUDGE - defc 'SMUDGE' - defw rbrac-4 -smudg: - defw docol - defw lates - defw lit - defw 20h - defw toggl - defw semis -; -; - defb 83h ; HEX - defc 'HEX' - defw smudg-9 -hex: - defw docol - defw lit - defw 10h - defw base - defw store - defw semis -; -; - defb 87h ; DECIMAL - defc 'DECIMAL' - defw hex-6 -dec: - defw docol - defw lit - defw 0ah - defw base - defw store - defw semis -; -; - defb 87h ; (;CODE) - defc '(;CODE)' - defw dec-0ah -pscod: - defw docol - defw fromr - defw lates - defw pfa - defw cfa - defw store - defw semis -; -; - defb 0c5h ; ;CODE - defc ';CODE' - defw pscod-0ah -semic: - defw docol - defw qcsp - defw comp - defw pscod - defw lbrac -semi1: - defw noop ; assembler - defw semis -; -; - defb 87h ; - defc 'DOES>' - defw build-0ah -does: - defw docol - defw fromr - defw lates - defw pfa - defw store - defw pscod -dodoe: - ld hl,(rpp) - dec hl - dec hl -; ldw (hl),bc ;/ - defb 0edh,0eh - ld (rpp),hl - inc de - ex de,hl -; ldw bc,(hl) ;/ - defb 0edh,06h - inc hl - inc hl - jhpush -; -; - defb 85h ; COUNT - defc 'COUNT' - defw does-8 -count: - defw docol - defw dup - defw onep - defw swap - defw cat - defw semis -; -; - defb 84h ; TYPE - defc 'TYPE' - defw count-8 -type: - defw docol - defw ddup - defw zbran ; if - defw type1-$ - defw over - defw plus - defw swap - defw xdo ; do -type2: - defw ido - defw cat - defw emit - defw xloop ; loop - defw type2-$ - defw bran ; else - defw type3-$ -type1: - defw drop ; endif -type3: - defw semis -; -; - defb 89h ; -TRAILING - defc '-TRAILING' - defw type-7 -dtrai: - defw docol - defw dup - defw zero - defw xdo ; do -dtra1: - defw tdup ;/ - defw plus - defw onemin ;/ - defw cat - defw bl - defw subb - defw zbran ; if - defw dtra2-$ - defw leave - defw bran ; else - defw dtra3-$ -dtra2: - defw onemin ;/ -dtra3: - defw xloop ; loop - defw dtra1-$ - defw semis -; -; - defb 84h ; (.") - defc '(.")' - defw dtrai-0ch -pdotq: - defw docol - defw rr - defw count - defw dup - defw onep - defw fromr - defw plus - defw tor - defw type - defw semis -; -; - defb 0c2h ; ." - defc '."' - defw pdotq-7 -dotq: - defw docol - defw lit - defw 22h - defw state - defw at - defw zbran ; if - defw dotq1-$ - defw comp - defw pdotq - defw word - defw here - defw cat - defw onep - defw allot - defw bran ; else - defw dotq2-$ -dotq1: - defw word - defw here - defw count - defw type ; endif -dotq2: - defw semis -; -; - defb 86h ; EXPECT - defc 'EXPECT' - defw dotq-5 -expec: - defw docol - defw over - defw plus - defw over - defw xdo ; do -expe1: - defw key - defw dup - defw lit - defw 0eh - defw porig - defw at - defw equal - defw zbran ; if - defw expe2-$ - defw drop - defw dup - defw ido - defw equal - defw dup - defw fromr - defw twomin ;/ - defw plus - defw tor - defw zbran ; if - defw expe6-$ - defw lit - defw bell - defw bran ; else - defw expe7-$ -expe6: - defw lit - defw bsout ; endif -expe7: - defw bran ; else - defw expe3-$ -expe2: - defw dup - defw lit - defw acr ;/ - defw equal - defw zbran ; if - defw expe4-$ - defw leave - defw drop - defw bl - defw zero - defw bran ; else - defw expe5-$ -expe4: - defw dup ; endif -expe5: - defw ido - defw cstor - defw zero - defw ido - defw onep - defw store ; endif -expe3: - defw emit - defw xloop ; loop - defw expe1-$ - defw drop - defw semis -; -; - defb 85h ; QUERY - defc 'QUERY' - defw expec-9 -query: - defw docol - defw tib - defw at - defw lit - defw 50h - defw expec - defw zero - defw inn - defw store - defw semis -; -; - defb 0c1h ; NULL - defb 80h - defw query-8 -null: - defw docol - defw blk - defw at - defw zbran ; if - defw null1-$ - defw one - defw blk - defw pstor - defw zero - defw inn - defw store - defw blk - defw at - defw bscr - defw onemin ;/ - defw andd - defw zequ - defw zbran ; if - defw null2-$ - defw qexec - defw fromr - defw drop ; endif -null2: - defw bran ; else - defw null3-$ -null1: - defw fromr - defw drop ; endif -null3: - defw semis -; - defb 84h ; FILL - defc 'FILL' - defw null-4 -fill: - defw $+2 - exx ;/ save ip - pop de ;/ e <-- byte - pop bc ; bc <-- quantity - pop hl ;/ hl <-- address -fill1: - ld a,b - or c ; qty == 0? - jr z,fill2 ; yes, nothing (more) to fill - ld (hl),e ;/ (hl) <-- byte - inc hl ; inc pointer - dec bc ; dec counter - jp fill1 ;/ -fill2: - exx ;/ restore ip - jnext -; -; - defb 85h ; ERASE - defc 'ERASE' - defw fill-7 -erasee: - defw docol - defw zero - defw fill - defw semis -; -; - defb 86h ; BLANKS - defc 'BLANKS' - defw erasee-8 -blank: - defw docol - defw bl - defw fill - defw semis -; -; - defb 84h ; HOLD - defc 'HOLD' - defw blank-9 -hold: - defw docol - defw lit - defw -1 - defw hld - defw pstor - defw hld - defw at - defw cstor - defw semis -; -; - defb 83h ; PAD - defc 'PAD' - defw hold-7 -pad: - defw docol - defw here - defw lit - defw 44h - defw plus - defw semis -; -; - defb 84h ; WORD - defc 'WORD' - defw pad-6 -word: - defw docol - defw blk - defw at - defw zbran ; if - defw word1-$ - defw blk - defw at - defw block - defw bran ; else - defw word2-$ -word1: - defw tib - defw at ; endif -word2: - defw inn - defw at - defw plus - defw swap - defw encl - defw here - defw lit - defw 22h - defw blank - defw inn - defw pstor - defw over - defw subb - defw tor - defw rr - defw here - defw cstor - defw plus - defw here - defw onep - defw fromr - defw cmove - defw semis -; -; - defb 88h ; (NUMBER) - defc '(NUMBER)' - defw word-7 -pnumb: - defw docol -pnum1: - defw onep ; begin - defw dup - defw tor - defw cat - defw base - defw at - defw digit - defw zbran ; while - defw pnum2-$ - defw swap - defw base - defw at - defw ustar - defw drop - defw rot - defw base - defw at - defw ustar - defw dplus - defw dpl - defw at - defw onep - defw zbran ; if - defw pnum3-$ - defw one - defw dpl - defw pstor ; endif -pnum3: - defw fromr - defw bran ; repeat - defw pnum1-$ -pnum2: - defw fromr - defw semis -; -; - defb 86h ; NUMBER - defc 'NUMBER' - defw pnumb-0bh -numb: - defw docol - defw zero - defw zero - defw rot - defw dup - defw onep - defw cat - defw lit - defw 2dh - defw equal - defw dup - defw tor - defw plus - defw lit - defw -1 -numb1: - defw dpl ; begin - defw store - defw pnumb - defw dup - defw cat - defw bl - defw subb - defw zbran ; while - defw numb2-$ - defw dup - defw cat - defw lit - defw 2eh - defw subb - defw zero - defw qerr - defw zero - defw bran ; repeat - defw numb1-$ -numb2: - defw drop - defw fromr - defw zbran ; if - defw numb3-$ - defw dminu ; endif -numb3: - defw semis -; -; - defb 85h ; -FIND (0-3) SUCCESS - defc '-FIND' ; (0-1) FAILURE - defw numb-9 -dfind: - defw docol - defw bl - defw word - defw here - defw cont - defw at - defw at - defw pfind - defw dup - defw zequ - defw zbran ; if - defw dfin1-$ - defw drop - defw here - defw lates - defw pfind ; endif -dfin1: - defw semis -; -; - defb 87h ; (ABORT) - defc '(ABORT)' - defw dfind-8 -pabor: - defw docol - defw abort - defw semis -; - defb 85h ; ERROR - defc 'ERROR' - defw pabor-0ah -error: - defw docol - defw warn - defw at - defw zless - defw zbran ; if - defw erro1-$ - defw pabor ; endif -erro1: - defw here - defw count - defw type - defw pdotq - defb 2 - db '? ' - defw mess - defw spsto -; CHANGE FROM fig MODEL -; defw inn,at,blk,at - defw blk,at - defw ddup - defw zbran,erro2-$ ; if - defw inn,at - defw swap ; endif -erro2: - defw quit -; -; - defb 83h ; ID. - defc 'ID.' - defw error-8 -iddot: - defw docol - defw pad - defw lit - defw 20h - defw blank ;/ - defw dup - defw pfa - defw lfa - defw over - defw subb - defw dup ;/ change frm MODEL - defw tor ;/ to suppress BIT 7 - defw pad - defw swap - defw cmove - defw pad - defw fromr ;/ for terminals - defw pad ;/ with an 8 bit - defw plus ;/ ASCCI character set. - defw onemin ;/ - defw dup ;/ - defw at ;/ - defw lit ;/ - defw 7fh ;/ - defw andd ;/ - defw swap ;/ - defw store ;/ - defw count - defw lit - defw 1fh ; WIDTH - defw andd - defw type - defw space - defw semis -; - defb 86h ; CREATE - defc 'CREATE' - defw iddot-6 -creat: - defw docol - defw dfind - defw zbran ; if - defw crea1-$ - defw drop - defw nfa - defw iddot - defw lit - defw 4 - defw mess - defw space ; endif -crea1: - defw here - defw dup - defw cat - defw width - defw at - defw min - defw onep - defw allot - defw dup - defw lit - defw 0a0h - defw toggl - defw here - defw onemin - defw lit - defw 80h - defw toggl - defw lates - defw comma - defw curr - defw at - defw store - defw here - defw twop - defw comma - defw semis -; -; - defb 0c9h ; [COMPILE] - defc '[COMPILE]' - defw creat-9 -bcomp: - defw docol - defw dfind - defw zequ - defw zero - defw qerr - defw drop - defw cfa - defw comma - defw semis -; -; - defb 0c7h ; LITERAL - defc 'LITERAL' - defw bcomp-0ch -liter: - defw docol - defw state - defw at - defw zbran ; if - defw lite1-$ - defw comp - defw lit - defw comma ; endif -lite1: - defw semis -; -; - defb 0c8h ; DLITERAL - defc 'DLITERAL' - defw liter-0ah -dlite: - defw docol - defw state - defw at - defw zbran ; if - defw dlit1-$ - defw swap - defw liter - defw liter ; endif -dlit1: - defw semis -; -; - defb 86h ; ?STACK - defc '?STACK' - defw dlite-0bh -qstac: - defw docol - defw spat - defw szero - defw at - defw swap - defw uless - defw one - defw qerr - defw spat - defw here - defw lit - defw 80h - defw plus - defw uless - defw lit - defw 7 - defw qerr - defw semis -; -; - defb 89h ; INTERPRET - defc 'INTERPRET' - defw qstac-9 -inter: - defw docol -inte1: - defw dfind ; begin - defw zbran ; if - defw inte2-$ - defw state - defw at - defw less - defw zbran ; if - defw inte3-$ - defw cfa - defw comma - defw bran ; else - defw inte4-$ -inte3: - defw cfa - defw exec ; endif -inte4: - defw qstac - defw bran ; else - defw inte5-$ -inte2: - defw here - defw numb - defw dpl - defw at - defw onep - defw zbran ; if - defw inte6-$ - defw dlite - defw bran ; else - defw inte7-$ -inte6: - defw drop - defw liter ; endif -inte7: - defw qstac ; endif -inte5: - defw bran ; again - defw inte1-$ -; -; - defb 89h ; IMMEDIATE - defc 'IMMEDIATE' - defw inter-0ch -immed: - defw docol - defw lates - defw lit - defw 40h - defw toggl - defw semis -; -; - defb 8ah ; VOCABULARY - defc 'VOCABULARY' - defw immed-0ch -vocab: - defw docol - defw build - defw lit - defw 0a081h - defw comma - defw curr - defw at - defw cfa - defw comma - defw here - defw vocl - defw at - defw comma - defw vocl - defw store - defw does -dovoc: - defw twop - defw cont - defw store - defw semis -; -; - defb 0c5h ; FORTH - defc 'FORTH' - defw vocab-0dh -forth: - defw dodoe - defw dovoc - defw 0a081h - defw task-7 ; cold start value only -; changed aech time a def is appended -; to the FORTH vocabulary - defw 0 ; end of vocabulary list -; -; - defb 8bh ; DEFINITIONS - defc 'DEFINITIONS' - defw forth-8 -defin: - defw docol - defw cont - defw at - defw curr - defw store - defw semis -; -; - defb 0c1h ; ( - defc '(' - defw defin-0eh -paren: - defw docol - defw lit - defw 29h - defw word - defw semis -; -; - defb 84h ; QUIT - defc 'QUIT' - defw paren-4 -quit: - defw docol - defw zero - defw blk - defw store - defw lbrac -quit1: - defw rpsto ; begin - defw cr - defw query - defw inter - defw state - defw at - defw zequ - defw zbran ; if - defw quit2-$ - defw pdotq - defb 2 - db 'ok' ; endif -quit2: - defw bran ; again - defw quit1-$ -; -; - defb 85h ; ABORT - defc 'ABORT' - defw quit-7 -abort: - defw docol - defw spsto - defw dec - defw qstac - defw cr - defw dotcpu - defw pdotq - defb 0eh ; count of chrs to follow - db 'fig-FORTH ' - defb figrel+30h,adot,figrev+30h,usrver - defw forth - defw defin - defw quit -; -; -wrm: ld bc,wrm1 - jnext -wrm1: defw warm -; -; - defb 84h ; WARM - defc 'WARM' - defw abort-8 -warm: - defw docol - defw mtbuf - defw abort -; -; -cld: - ld hl,(bdoss+1) ;/ - ld l,0 ;/ hl <-- fbase - ld (limit+2),hl ;/ set limit - ld de,bufsiz ;/ de <-- total disc buffer size -; subw hl,de ;/ hl <-- addr. of 1st disc buffer - defb 0edh,0deh - ld (first+2),hl ;/ set FIRST - ld (use+2),hl ;/ set USE - ld (prev+2),hl ;/ set PREV - ld (buf1),hl ;/ - ld de,us ;/ de <-- user variable space -; subw hl,de ;/ hl <-- initr0 - defb 0edh,0deh - ld (upinit),hl ;/ - ld (r0init),hl ;/ - ld (up),hl ;/ - ld (rpp),hl ;/ - ld de,rts ;/ de <-- rtn stack & term. buf space -; subw hl,de ;/ hl <-- inits0 - defb 0edh,0deh - ld (s0init),hl ;/ - ld (tibini),hl ;/ - ld sp,hl ;/ - ld bc,cld1 - ld ix,next ; pointer to next - ld iy,hpush ; pointer to hpush - jnext -; -; -cld1: defw cold -; - defb 84h ; COLD - defc 'COLD' - defw warm-7 -cold: - defw docol - defw mtbuf - defw one,recadr ; AvdH - defw store - defw lit,buf1 - defw at ;/ - defw use,store - defw lit,buf1 - defw at ;/ - defw prev,store - defw drzer - defw zero ;/ - defw lit,eprint - defw cstor ;/ -; - defw lit - defw orig+12h - defw lit - defw up - defw at - defw lit - defw 6 - defw plus - defw lit - defw 10h - defw cmove - defw lit - defw orig+0ch - defw at - defw lit - defw forth+6 - defw store - defw fcb ;/A - defw lit,opnfil ;/A open mass storage - defw bdos ;/A - defw lit,0ffh ;/A - defw equal ;/A file present? - defw zbran,cld2-$ ;/A - defw zero ;/A - defw warn,store ;/A - defw cr,pdotq ;/A - defb 7 ;/A - db 'No file' ;/A -cld2: - defw abort -; -; - defb 84h ; S->D - defc 'S->D' - defw cold-7 -stod: defw $+2 - pop hl ;/ -; exts hl ;/ de <-- h(7) - defb 0edh,6ch - ex de,hl ;/ - jp dpush ; ( n1 -- d1L d1H) -; -; - defb 82h ; +- - defc '+-' - defw STOD-7 -pm: - defw docol - defw zless - defw zbran ; if - defw pm1-$ - defw minus ; endif -pm1: - defw semis -; -; - defb 83h ; D+- - defc 'D+-' - defw pm-5 -dpm: - defw docol - defw zless - defw zbran ; if - defw dpm1-$ - defw dminu ; endif -dpm1: - defw semis -; -; - defb 83h ; ABS - defc 'ABS' - defw dpm-6 -abs: - defw docol - defw dup - defw pm - defw semis -; -; - defb 84h ; DABS - defc 'DABS' - defw abs-6 -dabs: - defw docol - defw dup - defw dpm - defw semis -; -; - defb 83h ; MIN - defc 'MIN' - defw dabs-7 -min: - defw docol - defw tdup - defw great - defw zbran ; if - defw min1-$ - defw swap ; endif -min1: - defw drop - defw semis -; -; - defb 83h ; MAX - defc 'MAX' - defw min-6 -max: defw docol - defw tdup - defw less - defw zbran ; if - defw max1-$ - defw swap ; endif -max1: - defw drop - defw semis -; -; - defb 82h ; M* ( n1 n2 --- d) - defc 'M*' - defw max-6 -mstar: - defw $+2 ;/ - pop de ; de <-- multiplicator - pop hl ; hl <-- multiplicant -; multw hl,de ;/ dehl <-- hl * de - defb 0edh,0d2h - ex de,hl ;/ - jp dpush ;/ ( n1 n2 --- d1l d1h) -; -; - defb 82h ;/ M/ ( d n1 --- nrem nquot) - defc 'M/' - defw mstar-5 -mslas: - defw $+2 ; ( d n1 --- n2 n3) - exx ; save ip - pop hl ; divisor - ld a,h - and 80h ; filter sign - jr z,mslas1 ; positive -; neg hl ; make positive - defb 0edh,4ch -mslas1: - ld b,h - ld c,l ; bc <-- divisor - pop hl ; dividend.hw - pop de ; dividend.lw - bit 7,h ; negative? - jr z,mslas2 ; no - inc a ; dividend sign flag - push hl - ld hl,0 -; subw hl,de ; neg dividend.lw - defb 0edh,0deh - pop de ; dividend.hw - push hl - ld hl,0 - sbc hl,de ; neg dividend.hw - pop de ; dividend.lw -mslas2: -; cpw hl,bc ; dividend.hw >= divisor - defb 0edh,0c7h - jr c,mslas3 ; no overflow, continue - ld hl,0ffffh - ld d,h - ld e,l ; set rem & quot to max. - jr mslas5 -; -mslas3: - ex de,hl ; dehl <-- dividend.hw,lw -; divuw dehl,bc ; de <-- remainder, hl <-- quotient - defb 0edh,0cbh - ex de,hl ; hl <-- remainder - bit 0,a ; was dividend negative - jr z,mslas4 ; no -; neg hl ; yes, negate remainder - defb 0edh,4ch -mslas4: - ex de,hl ; hl <-- quotient - or a - jr z,mslas5 ; neither operand negative - cp 81h ; both operands negative? - jr z,mslas5 ; yes, quotient stays positive -; neg hl ; no, negate quotient - defb 0edh,4ch -mslas5: - push de ; remainder - push hl ; quotient - exx ; restore ip - jnext -; -; - defb 81h ; * ( n1 n2 --- nproduct) - defc '*' - defw mslas-5 -star: - defw $+2 - pop de - pop hl -; multw hl,de ;/ dehl <-- product - defb 0edh,0d2h - jhpush -; -; - defb 84h ; /MOD ( n1 n2 --- nrem nquot) - defc '/MOD' - defw star-4 -slmod: - defw $+2 - exx ;/ save ip - pop bc ;/ divisor - pop hl ; dividend - ld a,b - or c ;/ div by 0? - jr nz,slmod1 ;/ no, continue - ld de,0ffffh - ld h,d - ld l,e ;/ set remainder & quotient to max. - jr slmod3 -slmod1: -; cpw hl,8000h ;/ special case -32768 -1 / - defb 0fdh,0edh,0f7h - defw 8000h - jr nz,slmod2 ;/ continue - ld a,b - cp 0ffh - jr nz,slmod2 - cp c ;/ lo byte also 0ffh? - jr nz,slmod2 ;/ no, go & divide - ld de,0 ;/ remainder - jr slmod3 ;/ exit with dividend unchanged -slmod2: -; exts hl ;/ de <-- dividend.hw - defb 0edh,6ch -; divw dehl,bc ;/ de <-- remainder, hl <-- quotient - defb 0edh,0cah -slmod3: - push de - push hl - exx ;/ restore ip - jnext -; -; - defb 81h ; / - defc '/' - defw slmod-7 -slash: - defw $+2 - exx ;/ save ip - pop bc ;/ divisor - pop hl ; dividend - ld a,b - or c ;/ division by 0? - jr nz,slash1 ;/ no, continue - ld hl,0ffffh ;/ set quotient to max. - jr slash3 -slash1: -; cpw hl,8000h ;/ special case -32768 -1 / - defb 0fdh,0edh,0f7h - defw 8000h - jr nz,slash2 ;/ dividend not -32768 - ld a,b - cp 0ffh - jr nz,slash2 ;/ divisor not -1 - cp c - jr z,slash3 ;/ return with dividend unchanged -slash2: -; exts hl ;/ de <-- dividend.hw - defb 0edh,6ch -; divw dehl,bc ;/ hl <-- quotient - defb 0edh,0cah -slash3: - push hl ;/ quotient - exx ;/ restore ip - jnext -; -; - defb 83h ;/ MOD - defc 'MOD' - defw slash-4 -modd: - defw $+2 - exx ; save ip - pop bc ; divisor - pop hl ; dividend - ld a,b - or c ; division by 0? - jr nz,modd1 ; no, continue - ld de,0ffffh ; set remainder to max - jr modd3 -modd1: -; cpw hl,8000h ; special case -32768 -1 / - defb 0fdh,0edh,0f7h - defw 8000h - jr nz,modd2 ; dividend not -32768 - ld a,b - cp 0ffh - jr nz,modd2 ; divisor not -1 - cp c - jr nz,modd2 ; go & divide - ld de,0 ; remainder - jr modd3 -modd2: -; exts hl ; de <-- dividend.hw - defb 0edh,6ch -; divw dehl,bc ; de <-- remainder - defb 0edh,0cah -modd3: - push de ; remainder - exx ; restore ip - jnext -; -; - defb 85h ;/ */MOD - defc '*/MOD' - defw modd-6 -ssmod: - defw $+2 - exx ; save ip - pop hl ; divisor - ld a,h - and 80h ; filter sign - jr z,ssmod1 ; positive -; neg hl ; make positive - defb 0edh,4ch -ssmod1: - ld b,h - ld c,l ; bc <-- divisor - pop hl ; multipicator - pop de ; multiplicant - ex af,af' ; save sign flag -; multw hl,de ; dehl <-- product (= dividend) - defb 0edh,0d2h - ex af,af' ; restore sign flag - ex de,hl ; de <-- dividend.lw - bit 7,h ; dividend negative? - jr z,ssmod2 ; no - inc a ; dividend sign flag - push hl - ld hl,0 -; subw hl,de ; neg dividend.lw - defb 0edh,0deh - pop de ; dividend.hw - push hl - ld hl,0 - sbc hl,de ; neg dividend.hw - pop de ; dividend.lw -ssmod2: -; cpw hl,bc ; dividend.hw >= divisor? - defb 0edh,0c7h - jr c,ssmod3 ; no overflow, continue - ld hl,0ffffh - ld d,h - ld e,l ; set rem & quot to max - jr ssmod5 -; -ssmod3: - ex de,hl ; dehl <-- dividend.hw,lw -; divuw dehl,bc ; de <-- remainder, hl <-- quotient - defb 0edh,0cbh - ex de,hl ; hl <-- remainder - bit 0,a ; was dividend negative? - jr z,ssmod4 ; no -; neg hl ; yes, negate remainder - defb 0edh,4ch -ssmod4: - ex de,hl ; hl <-- quotient - or a - jr z,ssmod5 ; neither operand negative - cp 81h ; both operands negative? - jr z,ssmod5 ; yes, quotient stays positive -; neg hl ; no, negate quotient - defb 0edh,4ch -ssmod5: - push de ; remainder - push hl ; quotient - exx ; restore ip - jnext -; -; - defb 82h ; */ - defc '*/' - defw ssmod-8 -ssla: - defw $+2 ;/ - exx ; save ip - pop hl ; divisor - ld a,h - and 80h ; filter sign - jr z,ssla1 ; positive -; neg hl ; make positive - defb 0edh,4ch -ssla1: - ld b,h - ld c,l ; bc <-- divisor - pop hl ; multipicator - pop de ; multiplicant - ex af,af' ; save sign flag -; multw hl,de ; dehl <-- product (= dividend) - defb 0edh,0d2h - ex af,af' ; restore sign flag - ex de,hl ; de <-- dividend.lw - bit 7,h ; dividend negative? - jr z,ssla2 ; no - inc a ; dividend sign flag - push hl - ld hl,0 -; subw hl,de ; neg dividend.lw - defb 0edh,0deh - pop de ; dividend.hw - push hl - ld hl,0 - sbc hl,de ; neg dividend.hw - pop de ; dividend.lw -ssla2: -; cpw hl,bc ; dividend.hw >= divisor? - defb 0edh,0c7h - jr c,ssla3 ; no overflow, continue - ld hl,0ffffh ; set quotient to max - jr ssla4 -; -ssla3: - ex de,hl ; dehl <-- dividend.hw,lw -; divuw dehl,bc ; de <-- remainder, hl <-- quotient - defb 0edh,0cbh - or a - jr z,ssla4 ; neither operand negative - cp 81h ; both operands negative? - jr z,ssla4 ; yes, quotient stays positive -; neg hl ; no, negate quotient - defb 0edh,4ch -ssla4: - push hl ; quotient - exx ; restore ip - jnext -; -; - defb 85h ; M/MOD - defc 'M/MOD' - defw ssla-5 -msmod: - defw docol - defw tor - defw zero - defw rr - defw uslas - defw fromr - defw swap - defw tor - defw uslas - defw fromr - defw semis -; -; -; Block moved down 2 pages -; - defb 86h ; (LINE) - defc '(LINE)' - defw msmod-8 -pline: - defw docol - defw tor - defw lit - defw 40h - defw bbuf - defw ssmod - defw fromr - defw bscr - defw star - defw plus - defw block - defw plus - defw lit - defw 40h - defw semis -; -; - defb 85h ; .LINE - defc '.LINE' - defw pline-9 -dline: - defw docol - defw pline - defw dtrai - defw type - defw semis -; -; - defb 87h ; MESSAGE - defc 'MESSAGE' - defw dline-8 -mess: - defw docol - defw warn - defw at - defw zbran ; if - defw mess1-$ - defw ddup - defw zbran ; if - defw mess2-$ - defw lit - defw 4 ; 1st message screen - defw ofset - defw at - defw bscr - defw slash - defw subb - defw dline - defw space ; endif -mess2: - defw bran ; else - defw mess3-$ -mess1: - defw pdotq - defb 6 - db 'MSG # ' - defw dot ; endif -mess3: defw semis -; -; - defb 82h ; P@ - defc 'P@' - defw mess-0ah -ptat: - defw $+2 - exx ;d save registers - pop bc ;d bc <-- port# - in l,(c) ;d l <-- data byte - ld h,0 - push hl - exx ;d restore registers - jnext -; -; - defb 82h ; P! - defc 'P!' - defw ptat-5 -ptsto: - defw $+2 - exx ;d save registers - pop bc ;d c <-- port# - pop hl ;d L <-- date byte - out (c),l - exx ;d restore registers - jnext -; -; - page -include DISCIO.FTH - page -include CONPRTIO.FTH - page -; - defb 0c1h ; ' (tick) - defb 0a7h - defw arrow-6 -tick: - defw docol - defw dfind - defw zequ - defw zero - defw qerr - defw drop - defw liter - defw semis -; -; - defb 86h ; FORGET - defc 'FORGET' - defw tick-4 -forg: - defw docol - defw curr - defw at - defw cont - defw at - defw subb - defw lit - defw 18h - defw qerr - defw tick - defw dup - defw fence - defw at - defw uless ;/ FORGET >8000h nw o.k. - defw lit - defw 15h - defw qerr - defw dup - defw nfa - defw dp - defw store - defw lfa - defw at - defw cont - defw at - defw store - defw semis -; -; - defb 84h ; BACK - defc 'BACK' - defw forg-9 -back: - defw docol - defw here - defw subb - defw comma - defw semis -; -; - defb 0c5h ; BEGIN - defc 'BEGIN' - defw back-7 -begin: - defw docol - defw qcomp - defw here - defw one - defw semis -; -; - defb 0c5h ; ENDIF - defc 'ENDIF' - defw begin-8 -endiff: - defw docol - defw qcomp - defw two - defw qpair - defw here - defw over - defw subb - defw swap - defw store - defw semis -; -; - defb 0c4h ; THEN - defc 'THEN' - defw endiff-8 -then: defw docol - defw endiff - defw semis -; -; - defb 0c2h ; DO - defc 'DO' - defw then-7 -do: - defw docol - defw comp - defw xdo - defw here - defw three - defw semis -; -; - defb 0c4h ; LOOP - defc 'LOOP' - defw do-5 -loop: - defw docol - defw three - defw qpair - defw comp - defw xloop - defw back - defw semis -; -; - defb 0c5h ; +LOOP - defc '+LOOP' - defw loop-7 -ploop: - defw docol - defw three - defw qpair - defw comp - defw xploo - defw back - defw semis -; -; - defb 0c5h ; UNTIL - defc 'UNTIL' - defw ploop-8 -until: - defw docol - defw one - defw qpair - defw comp - defw zbran - defw back - defw semis -; -; - defb 0c3h ; END - defc 'END' - defw until-8 -endd: - defw docol - defw until - defw semis -; -; - defb 0c5h ; AGAIN - defc 'AGAIN' - defw endd-6 -again: - defw docol - defw one - defw qpair - defw comp - defw bran - defw back - defw semis -; -; - defb 0c6h ; REPEAT - defc 'REPEAT' - defw again-8 -repea: - defw docol - defw tor - defw tor - defw again - defw fromr - defw fromr - defw twomin ;/ - defw endiff - defw semis -; -; - defb 0c2h ; IF - defc 'IF' - defw repea-9 -iff: - defw docol - defw comp - defw zbran - defw here - defw zero - defw comma - defw two - defw semis -; -; - defb 0c4h ; ELSE - defc 'ELSE' - defw iff-5 -elsee: - defw docol - defw two - defw qpair - defw comp - defw bran - defw here - defw zero - defw comma - defw swap - defw two - defw endiff - defw two - defw semis -; -; - defb 0c5h ; WHILE - defc 'WHILE' - defw elsee-7 -while: - defw docol - defw iff - defw twop - defw semis -; -; - defb 86h ; SPACES - defc 'SPACES' - defw while-8 -spacs: - defw docol - defw zero - defw max - defw ddup - defw zbran ; if - defw spax1-$ - defw zero - defw xdo ; do -spax2: - defw space - defw xloop ; loop endif - defw spax2-$ -spax1: - defw semis -; -; - defb 82h ; <# - defc '<#' - defw spacs-9 -bdigs: - defw docol - defw pad - defw hld - defw store - defw semis -; -; - defb 82h ; #> - defc '#>' - defw bdigs-5 -edigs: - defw docol - defw drop - defw drop - defw hld - defw at - defw pad - defw over - defw subb - defw semis -; -; - defb 84h ; SIGN - defc 'SIGN' - defw edigs-5 -sign: - defw docol - defw rot - defw zless - defw zbran ; if - defw sign1-$ - defw lit - defw 2dh - defw hold ; endif -sign1: - defw semis -; -; - defb 81h ; # - defc '#' - defw sign-7 -dig: - defw docol - defw base - defw at - defw msmod - defw rot - defw lit - defw 9 - defw over - defw less - defw zbran ; if - defw dig1-$ - defw lit - defw 7 - defw plus ; endif -dig1: defw lit - defw 30h - defw plus - defw hold - defw semis -; -; - defb 82h ; #S - defc '#S' - defw dig-4 -digs: - defw docol -digs1: - defw dig ; begin - defw tdup ;/ - defw orr - defw zequ - defw zbran ; until - defw digs1-$ - defw semis -; -; - defb 83h ; D.R - defc 'D.R' - defw digs-5 -ddotr: - defw docol - defw tor - defw swap - defw over - defw dabs - defw bdigs - defw digs - defw sign - defw edigs - defw fromr - defw over - defw subb - defw spacs - defw type - defw semis -; -; - defb 82h ; .R - defc '.R' - defw ddotr-6 -dotr: - defw docol - defw tor - defw stod - defw fromr - defw ddotr - defw semis -; -; - defb 82h ; D. - defc 'D.' - defw dotr-5 -ddot: - defw docol - defw zero - defw ddotr - defw space - defw semis -; -; - defb 81h ; . - defc '.' - defw ddot-5 -dot: - defw docol - defw stod - defw ddot - defw semis -; -; - defb 81h ; ? - defc '?' - defw dot-4 -ques: - defw docol - defw at - defw dot - defw semis -; -; - defb 82h ; U. - defc 'U.' - defw ques-4 -udot: defw docol - defw zero - defw ddot - defw semis -; - - defb 85h ; VLIST - defc 'VLIST' - defw udot-5 -vlist: - defw docol - defw lit - defw 80h - defw outt - defw store - defw cont - defw at - defw at -vlis1: - defw outt ; begin - defw at - defw csll - defw great - defw zbran ; if - defw vlis2-$ - defw cr - defw zero - defw outt - defw store ; endif -vlis2: - defw dup - defw iddot - defw space - defw space - defw pfa - defw lfa - defw at - defw dup - defw zequ - defw qterm - defw orr - defw zbran ; until - defw vlis1-$ - defw drop - defw semis -; -; - defb 83h ; BYE - defc 'BYE' - defw vlist-8 -bye: - defw docol ;/A - defw flush ;/A - defw fcb,lit ;/E - defw 10h,bdos ;/E close file - defw drop ;/E discard directory code - defw zero,zero ;/A - defw bdos ;/A return to CP/M - defw semis ;/A won't get this far, just for pretty -; -; - defb 84h ; LIST - defc 'LIST' - defw bye-6 -list: - defw docol,dec - defw cr,dup - defw scr,store - defw pdotq - defb 6 - db 'SCR # ' - defw dot - defw lit,10h - defw zero,xdo -list1: - defw cr,ido - defw three ;/ was lit,3 - defw dotr,space - defw ido,scr - defw at,dline - defw qterm - defw zbran,list2-$ ; if - defw leave -list2: - defw xloop,list1-$ ; endif - defw cr - defw semis -; -; - defb 85H ;INDEX - defc 'INDEX' - defw list-7 -index: - defw docol - defw lit,ff - defw emit - defw cr - defw onep,swap - defw xdo -inde1: - defw cr,ido - defw three ;/ was lit,3 - defw dotr,space - defw zero,ido - defw dline,qterm - defw zbran,inde2-$ ; if - defw leave ; endif -inde2: - defw xloop,inde1-$ - defw semis -; -; - defb 85h ; TRIAD - defc 'TRIAD' - defw index-8 -triad: - defw docol - defw lit,ff - defw emit - defw three ;/ was lit,3 - defw slash - defw three ;/ was lit,3 - defw star - defw three ;/ was lit,3 - defw over,plus - defw swap,xdo -tria1: - defw cr,ido - defw list - defw qterm - defw zbran,tria2-$ ; if - defw leave -tria2: - defw xloop,tria1-$ ; endif - defw cr - defw lit,15 - defw mess,cr - defw semis -; -; - defb 84h ; .CPU - defc '.CPU' - defw triad-8 -dotcpu: - defw docol - defw base,at - defw lit,36 - defw base,store - defw lit,22h - defw porig,tat - defw ddot - defw base,store - defw semis -; -; - defb 86h ; setclk - defc 'setclk' - defw dotcpu-7 -setclk: - defw $+2 - exx ; save ip - ld c,iopreg - ldctl hl,(c) ; l <-- current i/o page - ld a,l - ex af,af' ; save i/o page - ld l,0feh - ldctl (c),hl ; select i/o page 0feh - xor a - out (cntrl0),a ; disable c/t 0 - out (cntrl1),a ; disable c/t 1 - out (config1),a - ld hl,0ffffh - ld a,10h - out (config0),a ; cascade c/t 0 - c/t 1 - ld c,tcon0 - outw (c),hl ; load c/t 0 time constant - ld c,tcon1 - outw (c),hl ; load c/t 1 time constatnt - ld a,80h - out (config1),a ; continous mode - ld a,0e0h - out (cntrl1),a ; start 32bit counter - ex af,af' ; std. accu - ld l,a ; l <-- previous i/o page - ld c,iopreg - ldctl (c),hl ; restore i/o page - exx ; restore ip - jnext -; -; - defb 86h ; getclk - defc 'getclk' - defw setclk-9 -getclk: - defw $+2 - exx ; save ip - ld c,iopreg - ldctl hl,(c) ; l <-- current i/o page - ld a,l - ex af,af' ; save current i/o page - ld l,0feh - ldctl (c),hl ; select i/o page 0feh - ld a,80h - out (cntrl1),a ; halt 32bit counter - ld c,count1 - inw hl,(c) - ld d,h - ld e,l ; de <-- count1 - ld c,count0 - inw hl,(c) ; hl <-- count0 - ld c,0 - ld a,c ; a <-- 0 - sub l ; 0 - l - ld l,a ; l <-- neg(l) - ld a,c ; a <-- 0 - sbc a,h - ld h,a ; h <-- neg(h) - ld a,c ; a <-- 0 - sbc a,e - ld e,a ; e <-- neg(e) - ld a,c ; a <-- 0 - sbc a,d - ld d,a ; d <-- neg(d), dehl <-- neg(dehl) -; divuw dehl,25000 ; scale to 1/100 secs - defb 0fdh,0edh,0fbh - defw 25000 - push hl ; result - ex af,af' ; std. accu - ld l,a ; l <-- previous i/o page - ld c,iopreg - ldctl (c),hl ; restore i/o page - exx ; restore ip - jnext -; -; - defb 84h ; TASK - defc 'TASK' - defw getclk-9 -; defw dotcpu-7 -task: - defw docol - defw semis -; -; -initdp: - defw 0 -; - end orig - \ No newline at end of file diff --git a/software/CPM/CPM08_Z80FORTH/280FORTH.UPD b/software/CPM/CPM08_Z80FORTH/280FORTH.UPD deleted file mode 100644 index 6bcf6e7..0000000 --- a/software/CPM/CPM08_Z80FORTH/280FORTH.UPD +++ /dev/null @@ -1,44 +0,0 @@ - 1988-NOV-12 - -Z280 fig-FORTH using random CP/M file access -------------------------------------------- - -Z280 fig-FORTH 1.1a, the first version of Z280 fig-FORTH by Edmund Ramm uses -modified Albert van der Horst random file access routines. - -All system calls are done via the BDOS, so this FORTH version should run un- -der all CP/M-80 versions. - -Words which have been deleted from the dictionary (most of them low level de- -finitions) are DRIVE, TRACK, SECTOR, SETIO, SETDRV, SEC/BLK & DENSITY. - -A BDOS call has been introduced: BDOS ( parm fcode --- dircode) where parm -stands for the parameter passed to the BDOS in the DE register pair, and -fcode is the BDOS function number. Dircode is the directory code returned by -the BDOS. This enables you to access CP/M files using high level definitions. - -BYE is now defined as a high level word which ensures that all updated -screens are written back to disc. - -COLD re-opens the screens file and issues a warning upon failure. - -FCB is another new word. It leaves the address of the current file control -block on the stack. - -REC# pushes the corresponding record count address onto the stack. - -EXTEND ( n ---) extends (sic!) the logged in screens file by n blocks, as -long as disc space permits. You could start by SAVE-ing a 0-size file at CCP -level and then expand it after you logged in same file at the time you invoke -280FORTH (e.g. 280FORTH B:SCREENS.FRT). - -The actions of all other words remain as defined in the fig-FORTH Installa- -tion Manual's Glossary, available from the FORTH Interest Group, PO Box 1105 -San Carlos, CA 94070, USA. - -Please report bugs to Edmund R a m m - P.O.Box 1338 - D-2358 Kaltenkirchen - Fed. Rep of Germany - Tel.: (04191) 1621 - \ No newline at end of file diff --git a/software/CPM/CPM08_Z80FORTH/280FORTH.Z80 b/software/CPM/CPM08_Z80FORTH/280FORTH.Z80 deleted file mode 100644 index 2539097..0000000 --- a/software/CPM/CPM08_Z80FORTH/280FORTH.Z80 +++ /dev/null @@ -1,4207 +0,0 @@ - title - subttl Adaptive version -; -; -; Modified from Z80 fig-FORTH 1.1h by EHR 880830 -; Modified frm FIG document keyed by Dennis L. Wilson 800907 -; Converted frm "8080 FIG-FORTH VERSION A0 15SEP79" -; -; fig-FORTH release 1.1 for the 8080 processor. -; -; ALL PUBLICATIONS OF THE FORTH INTEREST GROUP -; ARE PUBLIC DOMAIN. THEY MAY BE FURTHER -; DISTRIBUTED BY THE INCLUSION OF THIS CREDIT NOTICE: -; -; This publication has been made available by the -; Forth Interest Group -; P.O.Box 1105 -; San Carlos, CA 94070 -; U.S.A. -; -; Implementation on 8080 by: -; John Cassady -; 339 15th Street -; Oakland, CA 94612 -; U.S.A -; on 790528 -; Modified by: -; Kim Harris -; Acknowledgements: -; George Flammer -; Robt. D. Villwock -; ---------------------------------------------------------------------- -; Z80 Version for Cromemco CDOS & Digital Research CP/M by: -; Dennis Lee Wilson c/o -; Aristotelian Logicians -; 2631 East Pinchot Avenue -; Phoenix, AZ 85016 -; U.S.A. -; ---------------------------------------------------------------------- -; The 2 byte Z80 code for Jump Relative (JR) has been substituted for -; the 3 byte Jump (JP) wherever practical. The port I/O words P@ & P! -; have been made ROMable by use of Z80 instructions. -; ---------------------------------------------------------------------- -; Further modifications (marked ;/) by: -; Edmund Ramm -; P.O.Box 38 -; 2358 Kaltenkirchen -; Fed. Rep. of Germany 840418 -; -; 850419 changed * (star) -; 850507 added 0<>, 0>, TUCK, NIP, -ROT, CSWAP, PICK -; 850511 added -CMOVE -; -; ----------------------------------------------------------------------------- -; Disc I/O has been modified a la Albert van der Horst (HCCH) to employ -; CP/M 2.x's random access feature. -; ----------------------------------------------------------------------------- -; ----------------------------------------------------------------------------- -; -; Z280 specifics -; -; -iopreg equ 08h ; i/o page register -; -config0 equ 0e0h ; c/t 0 configuration register -cntrl0 equ 0e1h ; c/t 0 command/status register -tcon0 equ 0e2h ; c/t 0 time constatnt register -count0 equ 0e3h ; c/t 0 count-time register -config1 equ 0e8h ; c/t 1 configuration register -cntrl1 equ 0e9h ; c/t 1 command/status register -tcon1 equ 0eah ; c/t 1 time constant register -count1 equ 0ebh ; c/t 1 count-time register -; -; ----------------------------------------------------------------------------- -; -; Release & Version numbers -; -figrel equ 1 ;FIG RELEASE # -figrev equ 1 ;FIG REVISION # -usrver equ 61h ;USER VERSION # a by EHR -; -;Console & printer drivers are in external source named -;CONPRTIO.FTH & disc drivers in DISCIO.FTH. It has 4 screen -;buffers & end of memory is set to FBASE from locn. 0007H. - page -; ASCII characters used -; -abl equ 20h ;BLANK -acr equ 0dh ;CR -adot equ 2eh ;. -bell equ 07h ;^G -bsin equ 08h ;backspace chr = ^H -bsout equ 08h -dle equ 10h ;^P -lf equ 0ah ;^J -ff equ 0ch ;^L -; -; Memory allocation -; -bdoss equ 0005h ;/ system entry -nscr equ 4 ; # of 1024 byte screens -kbbuf equ 128 ; bytes/disc buffer -us equ 40h ; user variables space -rts equ 400h ; Return Stack & term buff space -co equ kbbuf+4 ; Disc buff + 2 header + 2 tail -nbuf equ nscr*400h/kbbuf ; # of buffers -bufsiz equ co*nbuf ;/ total disc buffer size - page - aseg - ;.z280 - ; PRE280 V1.11b 20-Nov-90 Copyright (c) 1990 by A.Zinser (fifi@veeble.north.de) - .Z80 -; - org 0100h -; -orig: - nop - jp cld ; vector to cold start - nop - jp wrm ; vector to warm start - defb figrel ; fig release # - defb figrev ; fig revision # - defb usrver ; user version # - defb 0eh ; implementation attributes -; -; -; -; 0eh = 0000:1110 -; --------- -; B +ORIGIN ...W:IEBA -; -; W: 0=above sufficient -; 1=other differences exist -; I: Interpreter is 0=pre- -; 1=post incrementing -; E: Addr must be even: 0 yes -; 1 no -; B: High byte @ 0=low addr. -; 1=high addr. -; A: CPU Addr. 0=BYTE -; 1=WORD -; -; -; - defw task-7 ; topmost word in FORTH vocabulary - defw bsin ; backspace chr -upinit: defw 0 ;/ init (up) -; -; * Following used by COLD; must be in same order as user variables * -; -s0init: defw 0 ;/ init (s0) -r0init: defw 0 ;/ init (r0) -tibini: defw 0 ;/ init (TIB) - defw 1fh ; init (WIDTH) - defw 0 ; init (WARNING) - defw initdp ; init (FENCE) - defw initdp ; init (dp) - defw forth+8 ; init (VOC-LINK) -; -; * END DATA USED BY COLD * -; - defw 0018h,0f600h ; Z280 CPU name (hw,lw) - ; (32 bit base 36 integer) - page -; REGISTERS -; -; FORTH Z80 FORTH PRESERVATION RULES -; ----- --- ----------------------- -; IP BC should be preserved -; accross FORTH words. -; W DE sometimes output from -; NEXT, may be altered -; b4 JP'ing to NEXT, -; input only when -; "DPUSH" called. -; SP SP should be used only as -; Data Stack accross -; FORTH words, may be -; used within FORTH -; words if restored -; b4 "NEXT" -; HL Never output frm NEXT -; input only when -; "HPUSH" called -; -; -up: defw 0 ;/ user area ptr -rpp: defw 0 ;/ return stack ptr -buf1: defw 0 ;/ address of 1st disc buffer -; -; -; COMMENT CONVENTIONS: -; -; == means "is equal to" -; <-- means assignment -; #NAME = value of name -; NAME = contents @ name -; (NAME) = contents of cell addressed by name -; cfa = code field address -; lfa = link field address -; nfa = name field address -; pfa = parameter field address -; s1 = 1st word of parameter stack -; s2 = 2nd -"- of -"- -"- -; r1 = 1st -"- of return stack -; r2 = 2nd -"- of -"- -"- -; ( above Stack posn. valid b4 & after execution of any word, not during) -; -; lsb = least significant bit -; msb = most significant bit -; lb = low byte -; hb = high byte -; lw = low word -; hw = high word -; (May be used as suffix to above names) - page -; FORTH ADDRESS INTERPRETER -; POST INCREMENTING VERSION -; -; -; -dpush: - push de -hpush: - push hl ; iy points here -next: - ld h,b ;/ w <-- (ip) ix points here - ld l,c ;/ - ;ldw hl,(hl) ;/ (hl) --> cfa - DEFB 0EDh,26h - inc bc - inc bc ;/ ip += 2 -next1: - ;ldw de,(hl) ;/ pc <-- (w) - DEFB 0EDh,16h - ex de,hl - inc de - jp (hl) ; note: de <-- cfa + 1 -; -; -jnext macro - jp (ix) - endm -; -jhpush macro - jp (iy) - endm -; - page -; FORTH DICTIONARY -; DICTIONARY FORMAT: -; -; BYTE -; ADDRESS NAME CONTENTS -; ------- ---- -------- -; (MSB=1 -; (P=PRECEDENCE BIT -; (S=SMUDGE BIT -; NFA NAME FIELD 1PS MSB=0, NAME'S 1st CHAR -; 0<2CHAR> -; ... -; 1 MSB=1, NAME'S LAST CHAR -; LFA LINK FIELD =PREVIOUS WORD'S NFA -; -;LABEL: CFA CODE FIELD =ADDR CPU CODE -; -; PFA PARAMETER <1PARAM> 1st PARAMETER BYTE -; FIELD <2PARAM> -; ... -; -; -; -dp0: - defb 83h ; LIT - defc 'LIT' - defw 0 ; lfa == 0 marks end of dictionary -lit: - defw $+2 ; s1 <-- (ip) - ld h,b - ld l,c - ;ldw hl,(hl) ; hl <-- (ip) = literal - DEFB 0EDh,26h - inc bc ;/ - inc bc ;/ ip += 2 - jhpush ; s1 <-- hl -; -; - defb 87h ; EXECUTE - defc 'EXECUTE' - defw lit-6 -exec: - defw $+2 - pop hl - jp next1 -; -; - defb 86h ; BRANCH - defc 'BRANCH' - defw exec-0ah -bran: - defw $+2 ; ip += (ip) -bran1: - ld h,b - ld l,c ; hl <-- ip - ;addw hl,(hl) ; hl <-- ip + branch offset - DEFB 0DDH - DEFB 0EDH,0C6h - ld c,l - ld b,h ; ip += branch offset - jnext -; -; - defb 87h ; 0BRANCH - defc '0BRANCH' - defw bran-9 -zbran: - defw $+2 - pop hl - ld a,l - or h - jr z,bran1 ; branch if if s1 == 0 - inc bc ; else skip branch offset - inc bc - jnext -; -; - defb 86h ; (LOOP) - defc '(LOOP)' - defw zbran-0ah -xloop: - defw $+2 - ld hl,(rpp) ; (hl) --> index = r1 - ;incw (hl) ;/ index += 1 - DEFB 0DDH - inc BC - ;ldw de,(hl) ;/ de <-- new index - DEFB 0EDh,16h - inc hl ;/ - inc hl ;/ hl --> limit(lb) - ld a,e - sub (hl) - ld a,d - inc hl ; hl --> limit(hb) - sbc a,(hl) ; index < limit? - jp m,bran1 ; yes, loop again - inc hl ; no, done - ld (rpp),hl ; discard r1 & r2 - inc bc - inc bc ; skip branch offset - jnext -; -; - defb 87h ; (+LOOP) - defc '(+LOOP)' - defw xloop-9 -xploo: - defw $+2 - pop de ; de <-- increment - ld hl,(rpp) ; hl --> index - ld a,(hl) ; index += increment - add a,e - ld (hl),a - ld e,a - inc hl - ld a,(hl) - adc a,d - ld (hl),a - inc hl ; (hl) --> limit - inc d - dec d - ld d,a ; de <-- new index - jp m,xloo2 ; if incr > 0 - ld a,e - sub (hl) ; then a <-- index - limit - ld a,d - inc hl - sbc a,(hl) - jp xloo3 - -xloo2: - ld a,(hl) ; else a <-- limit - index - sub e - inc hl - ld a,(hl) - sbc a,d -; ; if a < 0 -xloo3: - jp m,bran1 ; then loop again - inc hl ; else done - ld (rpp),hl ; discard r1 & r2 - inc bc ; skip branch offset - inc bc - jnext -; -; - defb 84h ; (DO) - defc '(DO)' - defw xploo-0ah -xdo: - defw $+2 - pop de ; de <-- initial index - ld hl,(rpp) ; hl <-- rp - dec hl - dec hl - ;pop (hl) ;/ r2 <-- limit - DEFB 0DDH - pop BC - dec hl - dec hl - ;ldw (hl),de ;/ r1 <-- initial index - DEFB 0EDh,1Eh - ld (rpp),hl ; rp -= 4 - jnext -; -; - defb 81h ; I - defc 'I' - defw xdo-7 -ido: - defw $+2 - ld hl,(rpp) - ;push (hl) ;/ s1 <-- r1, r1 unchanged - DEFB 0DDH - push BC - jnext -; -; - defb 85h ; DIGIT - defc 'DIGIT' - defw ido-4 -digit: - defw $+2 - pop hl ; l <-- s1.lb = base value - pop de ; e <-- s2.lb = chr to be converted - ld a,e ; a <-- chr - sub '0' ; >= 0? - jr c,digi2 ;/ < 0 is invalid - cp 0ah ; > 9? - jr c,digi1 ;/ no, test base value - sub 07h ; gap between '9' & 'A', nw 'A'=0ah - cp 0ah ; >= 'A'? - jr c,digi2 ;/ chrs btwn '9' & 'A' are invalid -digi1: - cp l ; < base value? - jr nc,digi2 ;/ no, invalid - ld e,a ; s2 <-- de = converted digit - ld hl,0001h ; s1 <-- true - jp dpush -; -digi2: - ld l,h ; hl <-- false - jhpush ; s1 <-- false -; -; - defb 86h ; (FIND) (2-1)FAILURE - defc '(FIND)' ; (2-3)SUCCESS - defw digit-8 -pfind: - defw $+2 - pop de ; de <-- nfa -pfin1: - pop hl ; hl <-- string addr - push hl ; save for next iteration - ld a,(de) - xor (hl) ; filter differences - and 3fh ; mask msb & precedence bit - jr nz,pfin4 ; lengths differ -pfin2: - inc hl ; hl --> next string chr - inc de ; de --> next name field chr - ld a,(de) - xor (hl) ; filter differences - add a,a ; shift msbit into carry - jr nz,pfin3 ; no match - jr nc,pfin2 ; match so far, loop agn - ld hl,0005h ; string matches - add hl,de ; (sp) <-- pfa - ex (sp),hl -pfin6: - dec de ; de --> nfa - ld a,(de) - or a ; msb=1? =length byte - jp p,pfin6 ; no, try next chr - ld e,a ; e <-- length byte - ld d,00h - ld hl,0001h ; hl <-- true - jp dpush ; name field found, return -; -; above name field not a match, try next one -; -pfin3: - jr c,pfin5 ; carry=end of name field -pfin4: - inc de ; find name field end - ld a,(de) - or a ; msb=1? - jp p,pfin4 ; no, loop -pfin5: - inc de ; de <-- lfa - ex de,hl - ;ldw de,(hl) ;/ de <-- lfa - DEFB 0EDh,16h - ld a,d - or e ; end of dictionary (lfa = 0)? - jr nz,pfin1 ; no, try previous definition - pop hl ; drop string address - ld hl,0 ; hl <-- false - jhpush ; no match found, return -; -; - defb 87h ; ENCLOSE - defc 'ENCLOSE' - defw pfind-9 -encl: - defw $+2 - pop de ; de <-- s1 = delimiter chr - pop hl ; hl <-- s2 = addr of text to scan - push hl ; s4 <-- addr - ld a,e - ld d,a ; d <-- delim chr - ld e,-1 ; init chr offset counter - dec hl ; hl <-- addr - 1 -encl1: - inc hl ; skip over leading delim chrs - inc e - cp (hl) ; delim chr? - jr z,encl1 ; yes, loop - ld d,0 - push de ; s3 <-- e = offset to 1st non delim - ld d,a ; d <-- delim chr - ld a,(hl) - and a ; 1st non-delim=null? - jr nz,encl2 ; no - ld d,0 ; yes - inc e - push de ; s2 <-- offset to byte following null - dec e - push de ; s1 <-- offset to null - jnext -; -encl2: - ld a,d ; A <-- delim chr - inc hl ; hl <-- next chr's address - inc e ; e <-- offset to next chr - cp (hl) ; delim chr? - jr z,encl4 ; yes - ld a,(hl) - and a ; null? - jr nz,encl2 ; no, continue scan -encl3: - ld d,0 - push de ; s2 <-- offset to null - push de ; s1 <-- offset to null - jnext -; -encl4: - ld d,0 - push de ; s2 <-- offset to byte following text - inc e - push de ; s1 <-- offset 2 bytes aft end of word - jnext -; -; - defb 84h ; EMIT - defc 'EMIT' - defw encl-0ah -emit: - defw docol - defw pemit - defw one,outt - defw pstor,semis -; -; - defb 83h ; KEY - defc 'KEY' - defw emit-7 -key: - defw $+2 - jp pkey -; -; - defb 89h ; ?TERMINAL - defc '?TERMINAL' - defw key-6 -qterm: - defw $+2 - ld hl,0 - jp pqter -; -; - defb 82h ; CR - defc 'CR' - defw qterm-0ch -cr: - defw $+2 - jp pcr -; -; - defb 85h ; CMOVE - defc 'CMOVE' - defw cr-5 -cmove: - defw $+2 - exx ;/ save ip - pop bc ; bc <-- s1 = # of chrs - pop de ; de <-- s2 = dest addr - pop hl ;/ hl <-- s3 = source addr - ld a,b - or c ; bc=0? - jr z,cmove1 ; yes, nothing to move - ldir ;/ xfer string -cmove1: - exx ;/ restore ip - jnext -; -; - defb 86h ;/ -CMOVE ( from to count --- ) - defc '-CMOVE' - defw cmove-8 -bcmov: - defw $+2 - exx ; save ip - pop bc ; bc <-- count - pop de ; de <-- destination - pop hl ; hl <-- source - ld a,b - or c ; bc =0? - jr z,bcmov1 ; yes, nothing to move - add hl,bc - dec hl ; hl --> hi end of source block - ex de,hl - add hl,bc - dec hl - ex de,hl ; de --> hi end of dest. block - lddr ; (de) <-- (hl), --hl,bc until bc=0 -bcmov1: - exx ; restore ip - jnext -; -; - defb 82h ; U* 16*16 unsigned multiply - defc 'U*' ; with 32 bit result - defw bcmov-9 -ustar: - defw $+2 - pop de ; de <-- multiplier - pop hl ; hl <-- multiplicant - ;multuw hl,de ;/ - DEFB 0EDH,0D3h - ex de,hl ;/ de <-- product.lw, hl <-- product.hw - jp dpush ; s2,s1 <-- product.lw,hw -; -; - defb 82h ; U/ ( ud u1 -- urem uq ) - defc 'U/' - defw ustar-5 -uslas: - defw $+2 - exx ;/ save ip - pop bc ; bc <-- divisor - pop hl ; hl <-- dividend.hw - pop de ; de <-- dividend.lw - ;cpw hl,bc ;/ dividend.hw >= divisor? - DEFB 0EDH,0C7h - jr c,usla1 ; no, go ahead - ld hl,0ffffh ; yes, overflow - ld d,h - ld e,l ;/ set rem & quot to max - jr usla2 -usla1: - ex de,hl ;/ de,hl <-- dividend.hw,lw - ;divuw dehl,bc ;/ de <-- remainder, hl <-- quotient - DEFB 0EDH,0CBh -usla2: - push de ;/ s2 <-- remainder - push hl ;/ s1 <-- quotient - exx ;/ restore ip - jnext -; -; - defb 83h ; AND - defc 'AND' - defw uslas-5 -andd: - defw $+2 ; s1 <-- s1 AND s2 - pop de - pop hl - ld a,e - and l - ld l,a - ld a,d - and h - ld h,a - jhpush -; -; - defb 82h ; OR - defc 'OR' - defw andd-6 -orr: - defw $+2 ; s1 <-- s1 OR s2 - pop de - pop hl - ld a,e - or l - ld l,a - ld a,d - or h - ld h,a - jhpush -; -; - defb 83h ; XOR - defc 'XOR' - defw orr-5 -xorr: - defw $+2 ; s1 <-- s1 XOR s2 - pop de - pop hl - ld a,e - xor l - ld l,a - ld a,d - xor h - ld h,a - jhpush -; -; - defb 83h ; SP@ - defc 'SP@' - defw xorr-6 -spat: - defw $+2 - ld hl,0 - add hl,sp ; hl <-- sp - jhpush ; s1 <-- sp -; -; - defb 83h ; SP! - defc 'SP!' - defw spat-6 -spsto: - defw $+2 ; sp <-- s0 (user variable) - ld hl,(up) ; hl <-- user variables base address - ld de,6 - add hl,de ; hl --> s0 - ;ldw sp,(hl) ;/ sp <-- s0 - DEFB 0EDh,36h - jnext -; -; - defb 83h ; RP@ - defc 'RP@' - defw spsto-6 -rpat: - defw $+2 - ld hl,(rpp) - jhpush ; s1 <-- rp -; -; - defb 83h ; RP! - defc 'RP!' - defw rpat-6 -rpsto: - defw $+2 ; rp <-- r0 (user variable) - ld hl,(up) ; hl <-- user variables base address - ld de,0008h - add hl,de ; hl --> r0 - ;ldw hl,(hl) ;/ hl <-- r0 - DEFB 0EDh,26h - ld (rpp),hl ;/ rp <-- r0 - jnext -; -; - defb 82h ; ;S - defc ';S' - defw rpsto-6 -semis: - defw $+2 ; ip <-- r1 - ld hl,(rpp) - ;ldw bc,(hl) ;/ bc <-- r1 - DEFB 0EDh,06h - inc hl - inc hl - ld (rpp),hl ; rp += 2 - jnext -; -; - defb 85h ; LEAVE - defc 'LEAVE' - defw semis-5 -leave: - defw $+2 ; limit <-- index - ld hl,(rpp) - ;ldw de,(hl) ;/ de <-- r1 (= index) - DEFB 0EDh,16h - inc hl - inc hl - ;ldw (hl),de ;/ r2 (= limit) <-- index - DEFB 0EDh,1Eh - jnext -; -; - defb 82h ; >R - defc '>R' - defw leave-8 -tor: - defw $+2 - ld hl,(rpp) - dec hl - dec hl - ;pop (hl) ;/ r1 <-- s1 - DEFB 0DDH - pop BC - ld (rpp),hl ; rp -= 2 - jnext -; -; - defb 82h ; R> - defc 'R>' - defw tor-5 -fromr: - defw $+2 - ld hl,(rpp) - ;push (hl) ;/ s1 <-- r1 - DEFB 0DDH - push BC - inc hl - inc hl - ld (rpp),hl ; rp += 2 - jnext -; -; - defb 81h ; R - defc 'R' - defw fromr-5 -rr: - defw ido+2 -; -; - defb 82h ; 0= - defc '0=' - defw rr-4 -zequ: - defw $+2 - pop de - ld hl,0 - ;cpw hl,de ;/ - DEFB 0EDH,0D7h - jr nz,zequ1 - inc l ; hl <-- true -zequ1: - jhpush -; -; - defb 83h ;/ 0<> - defc '0<>' - defw zequ-5 -znequ: - defw $+2 - pop de - ld hl,0 - ;cpw hl,de ;/ - DEFB 0EDH,0D7h - jr z,znequ1 - inc l ; hl <-- true -znequ1: - jhpush -; -; - defb 82h ; 0< - defc '0<' - defw znequ-6 -zless: - defw $+2 - pop af ;/ a <-- s1.hb - rla ;/ carry <-- bit 7 - ld hl,0 ; hl <-- false - rl l ;/ bit 0 <-- carry - jhpush -; -; - defb 82h ;/ 0> - defc '0>' - defw zless-5 -zgt: - defw $+2 - pop de - ld hl,0 - ;cpw hl,de ;/ - DEFB 0EDH,0D7h - jp p,zgt1 ;/ <= 0 - jp pe,zgt1 ;/ 8000h special case - inc l ;/ hl <-- true -zgt1: - jhpush -; -; - defb 81h ;+ - defc '+' - defw zgt-5 -plus: - defw $+2 - pop de - pop hl - add hl,de - jhpush -; -; - defb 82h ; D+ ( d1l d1h d2l d2h -- d3l d3h) - defc 'D+' - defw plus-4 -dplus: - defw $+2 - exx ;/ save ip - pop bc ; bc <-- d2.hw - pop hl ; hl <-- d2.lw - pop af ;d af <-- d1.hw - pop de ; de <-- d1.lw - push af ;/ s1 <-- d1.hw - add hl,de ; hl <-- d2.lw + d1.lw (= d3.lw) - ex de,hl ; de <-- d3.lw - pop hl ; hl <-- d1.hw - adc hl,bc ;/ hl <-- d1.hw + d2.hw +carry (=d3.hw) - push de ; s2 <-- d3.lw - push hl ;/ s1 <-- d3.hw - exx ;/ restore ip - jnext -; -; - defb 85h ; MINUS - defc 'MINUS' - defw dplus-5 -minus: - defw $+2 - pop hl ;/ - ;neg hl ;/ - DEFB 0EDH,4Ch - jhpush -; -; - defb 86h ; DMINUS - defc 'DMINUS' - defw minus-8 -dminu: - defw $+2 - exx ;/ save ip - pop de ;/ de <-- d1.hw - pop bc ;/ bc <-- d1.lw - ld hl,0 ;/ - ;subw hl,bc ;/ - DEFB 0EDH,0CEh - push hl ; s2 <-- d2.lw - ld hl,0 ;/ - sbc hl,de ;/ - push hl ; s1 <-- d2.hw - exx ;/ - jnext -; -; - defb 84h ; OVER - defc 'OVER' - defw dminu-9 -over: - defw $+2 - ;ldw hl,(sp+2) ;/ - DEFB 0EDh,04h - DEFW +2 - jhpush ;/ -; -; - defb 84h ; DROP - defc 'DROP' - defw over-7 -drop: - defw $+2 - inc sp - inc sp ;/ faster on z280 than dummy pop - jnext -; -; - defb 84h ; SWAP - defc 'SWAP' - defw drop-7 -swap: - defw $+2 - pop hl - ex (sp),hl - jhpush -; -; - defb 83h ; DUP - defc 'DUP' - defw swap-7 -dup: - defw $+2 - ;ldw hl,(sp+0) ;/ - DEFB 0EDh,04h - DEFW +0 - jhpush -; -; - defb 84h ;/ TUCK ( n1 n2 --- n2 n1 n2) - defc 'TUCK' - defw dup-6 -tuck: - defw $+2 - pop hl ;/ hl <-- s1 - pop de ;/ de <-- s2 - push hl ;/ s3 <-- hl - jp dpush -; -; - defb 83h ;/ NIP ( n1 n2 --- n2) - defc 'NIP' - defw tuck-7 -nip: - defw $+2 - pop hl ; hl <-- s1 - ;ldw (sp+0),hl ;/ s1 <-- hl - DEFB 0EDh,05h - DEFW +0 - jnext -; -; - defb 84h ;/ -ROT ( n1 n2 n3 --- n3 n1 n2) - defc '-ROT' - defw nip-6 -mrot: - defw $+2 - pop hl - pop de - ex (sp),hl - ex de,hl - jp dpush -; -; - defb 85h ;/ CSWAP ( n1 --- n1, bytes swapped) - defc 'CSWAP' - defw mrot-7 -cswap: - defw $+2 - pop hl - ;ex h,l ;/ - DEFB 0EDH,0EFh - jhpush -; -; - defb 84h ;/ PICK ( nn...n0 k --- nn..n0 nk) - defc 'PICK' - defw cswap-8 -pick: - defw $+2 - pop hl ; hl <-- depth - add hl,hl ; adjust to word size - add hl,sp ; offset into stack - ;push (hl) ;/ - DEFB 0DDH - push BC - jnext -; -; - defb 84h ; 2DUP - defc '2DUP' - defw pick-7 -tdup: - defw $+2 - pop hl - pop de - push de - push hl - jp dpush -; -; - defb 82h ; +! - defc '+!' - defw tdup-7 -pstor: - defw $+2 - pop hl ; hl --> variable - pop de ; de <-- number - ld a,(hl) - add a,e - ld (hl),a - inc hl - ld a,(hl) - adc a,d - ld (hl),a ; (hl) += number - jnext -; -; - defb 86h ; TOGGLE - defc 'TOGGLE' - defw pstor-5 -toggl: - defw $+2 - pop de ; e <-- bit pattern - pop hl ; hl --> address - ld a,(hl) - xor e - ld (hl),a - jnext -; -; - defb 81h ; @ - defc '@' - defw toggl-9 -at: - defw $+2 - pop hl - ;push (hl) ;/ - DEFB 0DDH - push BC - jnext -; -; - defb 82h ; C@ - defc 'C@' - defw at-4 -cat: - defw $+2 - pop hl - ld l,(hl) - ld h,0 - jhpush -; -; - defb 82h ; 2@ - defc '2@' - defw cat-5 -tat: - defw $+2 - pop hl ; hl --> address - ;ldw de,(hl) ;/ de <-- d.hw - DEFB 0EDh,16h - inc hl - inc hl ; hl --> d.lw - ;push (hl) ;/ s2 <-- d.lw - DEFB 0DDH - push BC - push de ;/ s1 <-- d.hw - jnext -; -; - defb 81h ; ! - defc '!' - defw tat-5 -store: - defw $+2 - pop hl ; hl --> address - ;pop (hl) ;/ - DEFB 0DDH - pop BC - jnext -; -; - defb 82h ; C! - defc 'C!' - defw store-4 -cstor: - defw $+2 - pop hl ; hl --> address - pop de ; e <-- char - ld (hl),e - jnext -; -; - defb 82h ; 2! - defc '2!' - defw cstor-5 -tstor: - defw $+2 - pop hl ; hl --> address - ;pop (hl) ;/ store d.hw - DEFB 0DDH - pop BC - inc hl - inc hl - ;pop (hl) ;/ store d.lw - DEFB 0DDH - pop BC - jnext -; -; - defb 0c1h ; : - defc ':' - defw tstor-5 -colon: - defw docol - defw qexec - defw scsp - defw curr - defw at - defw cont - defw store - defw creat - defw rbrac - defw pscod -docol: - ld hl,(rpp) - dec hl - dec hl - ;ldw (hl),bc ;/ save return address - DEFB 0EDh,0Eh - ld (rpp),hl - inc de - ld c,e - ld b,d - jnext -; -; - defb 0c1h ; ; - defc ';' - defw colon-4 -semi: - defw docol - defw qcsp - defw comp - defw semis - defw smudg - defw lbrac - defw semis -; -; - defb 84h ; NOOP - defc 'NOOP' - defw semi-4 -noop: - defw docol - defw semis -; -; - defb 88h ; CONSTANT - defc 'CONSTANT' - defw noop-7 -con: - defw docol - defw creat - defw smudg - defw comma - defw pscod -docon: - inc de - ex de,hl - ;push (hl) ;/ - DEFB 0DDH - push BC - jnext -; -; - defb 88h ; VARIABLE - defc 'VARIABLE' - defw con-0bh -var: - defw docol - defw con - defw pscod -dovar: - inc de - push de - jnext -; -; - defb 84h ; USER - defc 'USER' - defw var-0bh -user: - defw docol - defw con - defw pscod -douse: - inc de - ex de,hl - ld l,(hl) ;/ - ld h,0 ;/ - ;addw hl,(up) ;/ - DEFB 0DDH - DEFB 0EDH,0D6h - DEFW UP - jhpush -; -; - defb 81h ; 0 - defc '0' - defw user-7 -zero: - defw $+2 ;/ - ;push 0000h ;/ - DEFB 0FDH - push AF - DEFW 0000H - jnext -; -; - defb 81h ; 1 - defc '1' - defw zero-4 -one: - defw $+2 ;/ - ;push 0001h ;/ - DEFB 0FDH - push AF - DEFW 0001H - jnext -; -; - defb 81h ; 2 - defc '2' - defw one-4 -two: - defw $+2 ;/ - ;push 0002h ;/ - DEFB 0FDH - push AF - DEFW 0002H - jnext -; -; - defb 81h ; 3 - defc '3' - defw two-4 -three: - defw $+2 ;/ - ;push 0003h ;/ - DEFB 0FDH - push AF - DEFW 0003H - jnext -; -; - defb 82h ; BL - defc 'BL' - defw three-4 -bl: - defw docon - defw 20h -; -; - defb 83h ; C/L - defc 'C/L' - defw bl-5 -csll: - defw docon - defw 64 -; -; - defb 85h ; FIRST - defc 'FIRST' - defw csll-6 -first: - defw docon - defw 0 ;/ set by CLD -; -; - defb 85h ; LIMIT - defc 'LIMIT' - defw first-8 -limit: - defw docon - defw 0 ;/ set by CLD -; -; - defb 85h ; B/BUF - defc 'B/BUF' - defw limit-8 -bbuf: - defw docon - defw kbbuf -; -; - defb 85h ; B/SCR - defc 'B/SCR' - defw bbuf-8 -bscr: - defw docon - defw 400h/kbbuf -; -; - defb 87h ; +ORIGIN - defc '+ORIGIN' - defw bscr-8 -porig: - defw docol - defw lit - defw orig - defw plus - defw semis -; -; USER VARIABLES -; - defb 82h ; S0 - defc 'S0' - defw porig-0ah -szero: - defw douse - defw 6 -; -; - defb 82h ; R0 - defc 'R0' - defw szero-5 -rzero: - defw douse - defw 8 -; -; - defb 83h ; TIB - defc 'TIB' - defw rzero-5 -tib: - defw douse - defb 0ah -; -; - defb 85h ; WIDTH - defc 'WIDTH' - defw tib-6 -width: - defw douse - defb 0ch -; -; - defb 87h ; WARNING - defc 'WARNING' - defw width-8 -warn: - defw douse - defb 0eh -; -; - defb 85h ; FENCE - defc 'FENCE' - defw warn-0ah -fence: - defw douse - defb 10h -; -; - defb 82h ; DP - defc 'DP' - defw fence-8 -dp: - defw douse - defb 12h -; -; - defb 88h ; VOC-LINK - defc 'VOC-LINK' - defw dp-5 -vocl: - defw douse - defw 14h -; -; - defb 83h ; BLK - defc 'BLK' - defw vocl-0bh -blk: - defw douse - defb 16h -; -; - defb 82h ; IN - defc 'IN' - defw blk-6 -inn: - defw douse - defb 18h -; -; - defb 83h ; OUT - defc 'OUT' - defw inn-5 -outt: - defw douse - defb 1ah -; -; - defb 83h ; SCR - defc 'SCR' - defw outt-6 -scr: - defw douse - defb 1ch -; -; - defb 86h ; OFFSET - defc 'OFFSET' - defw scr-6 -ofset: - defw douse - defb 1eh -; -; - defb 87h ; CONTEXT - defc 'CONTEXT' - defw ofset-9 -cont: - defw douse - defb 20h -; -; - defb 87h ; CURRENT - defc 'CURRENT' - defw cont-0ah -curr: - defw douse - defb 22h -; -; - defb 85h ; STATE - defc 'STATE' - defw curr-0ah -state: - defw douse - defb 24h -; -; - defb 84h ; BASE - defc 'BASE' - defw state-8 -base: - defw douse - defb 26h -; -; - defb 83h ; DPL - defc 'DPL' - defw base-7 -dpl: - defw douse - defb 28h -; -; - defb 83h ; FLD - defc 'FLD' - defw dpl-6 -fld: - defw douse - defb 2ah -; -; - defb 83h ; CSP - defc 'CSP' - defw fld-6 -cspp: - defw douse - defb 2ch -; - - defb 82h ; R# - defc 'R#' - defw cspp-6 -rnum: - defw douse - defb 2eh -; - - defb 83h ; HLD - defc 'HLD' - defw rnum-5 -hld: - defw douse - defw 30h -; -; END OF USER VARIABLES -; - defb 82h ; 1+ - defc '1+' - defw hld-6 -onep: - defw $+2 ;/ - pop hl ;/ - inc hl ;/ - jhpush ;/ -; -; - defb 82h ; 2+ - defc '2+' - defw onep-5 -twop: - defw $+2 ;/ - pop hl ;/ - inc hl ;/ - inc hl ;/ - jhpush ;/ -; -; - defb 82h ;/ 1- - defc '1-' ;/ - defw twop-5 ;/ -onemin: - defw $+2 ;/ - pop hl ;/ - dec hl ;/ - jhpush ;/ -; -; - defb 82h ;/ 2- - defc '2-' ;/ - defw onemin-5 ;/ -twomin: - defw $+2 ;/ - pop hl ;/ - dec hl ;/ - dec hl ;/ - jhpush ;/ -; -; - defb 82h ;/ 2* - defc '2*' ;/ - defw twomin-5 ;/ -twosta: - defw $+2 ;/ - pop hl ;/ - add hl,hl ;/ asl hl - jhpush ;/ -; -; - defb 82h ;/ 2/ - defc '2/' ;/ - defw twosta-5 ;/ -twosla: - defw $+2 ;/ - pop hl ;/ - bit 7,h ;/ negative? - jr z,twosl1 ;/ no - inc hl ;/ yes, add 1 -twosl1: - sra h ;/ - rr l ;/ asr hl - jhpush ;/ -; -; - defb 84h ; HERE - defc 'HERE' - defw twosla-5 -here: - defw docol - defw dp - defw at - defw semis -; -; - defb 85h ; ALLOT - defc 'ALLOT' - defw here-7 -allot: - defw docol - defw dp - defw pstor - defw semis -; -; - defb 81h ; , - defc ',' - defw allot-8 -comma: - defw docol - defw here - defw store - defw two - defw allot - defw semis -; - - defb 82h ; C, - defc 'C,' - defw comma-4 -ccomm: - defw docol - defw here - defw cstor - defw one - defw allot - defw semis -; -; - defb 81h ; - - defc '-' - defw ccomm-5 -subb: - defw $+2 - pop de - pop hl - ;subw hl,de ;/ - DEFB 0EDH,0DEh - jhpush -; -; - defb 81h ; = - defc '=' - defw subb-4 -equal: - defw $+2 ;/ - pop de ;/ - pop hl ;/ - ;subw hl,de ;/ - DEFB 0EDH,0DEh - ld hl,0 ; hl <-- false - jr nz,equal1 - inc l ;/ hl <-- true -equal1: - jhpush -; -; - defb 81h ; < - defc '<' - defw equal-4 -less: - defw $+2 - pop de - pop hl ; hl de < - ld a,d - xor h ; one operand negative? - jp m,less1 ; yes, determine which - ;subw hl,de ;/ - DEFB 0EDH,0DEh -less1: - bit 7,h ;/ h negative? - ld hl,0 ; hl <-- false - jr z,less2 - inc l ;/ hl <-- true -less2: - jhpush -; -; - defb 82h ; U< - defc 'U<' - defw less-4 -uless: - defw $+2 - pop de - pop hl ;/ hl de U< - ;subw hl,de ;/ - DEFB 0EDH,0DEh - ld hl,0 ; hl <-- false - rl l ;/ bit 0 <-- carry -uless1: - jhpush -; -; - defb 81h ; > - defc '>' - defw uless-5 -great: - defw $+2 - pop hl ;/ - pop de ;/ hl de > (= de hl < ) - ld a,d - xor h ; one operand negative? - jp m,great1 ; yes, determine which - ;subw hl,de ;/ - DEFB 0EDH,0DEh -great1: - bit 7,h ;/ h negative? - ld hl,0 ; hl <-- false - jr z,great2 - inc l ;/ hl <-- true -great2: - jhpush -; -; - defb 83h ; ROT ( n1 n2 n3 --- n2 n3 n1) - defc 'ROT' - defw great-4 -rot: - defw $+2 - pop de ; de <-- n3 - pop hl ; hl <-- n2 - ex (sp),hl ; s1 <-- n2, hl <-- n1 - jp dpush ; s2 <-- n3, s3 <-- n1 -; -; - defb 85h ; SPACE - defc 'SPACE' - defw rot-6 -space: - defw docol - defw bl - defw emit - defw semis -; -; - defb 84h ; -DUP - defc '-DUP' - defw space-8 -ddup: - defw $+2 ;/ - ;ldw hl,(sp+0) ;/ - DEFB 0EDh,04h - DEFW +0 - ld a,h ;/ - or l ;/ hl = 0? - jr z,ddup1 ;/ yes, don't dup - push hl ;/ -ddup1: - jnext -; -; - defb 88h ; TRAVERSE - defc 'TRAVERSE' - defw ddup-7 -trav: - defw docol - defw swap -trav1: - defw over ; begin - defw plus - defw lit - defw 7fh - defw over - defw cat - defw less - defw zbran ; until - defw trav1-$ - defw swap - defw drop - defw semis -; -; - defb 86h ; LATEST - defc 'LATEST' - defw trav-0bh -lates: - defw docol - defw curr - defw at - defw at - defw semis -; -; - defb 83h ; LFA - defc 'LFA' - defw lates-9 -lfa: - defw $+2 - pop hl ;/ hl <-- pfa - ;subw hl,4 ;/ - DEFB 0FDH - DEFB 0EDH,0FEh - DEFW 4 - jhpush ;/ s1 <-- lfa -; -; - defb 83h ; CFA - defc 'CFA' - defw lfa-6 -cfa: - defw docol - defw twomin ;/ - defw semis -; -; - defb 83h ; NFA - defc 'NFA' - defw cfa-6 -nfa: - defw docol - defw lit - defw 5 - defw subb - defw lit - defw -1 - defw trav - defw semis -; -; - defb 83h ; PFA - defc 'PFA' - defw nfa-6 -pfa: - defw docol - defw one - defw trav - defw lit - defw 5 - defw plus - defw semis -; -; - defb 84h ; !CSP - defc '!CSP' - defw pfa-6 -scsp: - defw docol - defw spat - defw cspp - defw store - defw semis -; -; - defb 86h ; ?ERROR - defc '?ERROR' - defw scsp-7 -qerr: - defw docol - defw swap - defw zbran ; if - defw qerr1-$ - defw error - defw bran ; else - defw qerr2-$ -qerr1: - defw drop ; endif -qerr2: - defw semis -; -; - defb 85h ; ?COMP - defc '?COMP' - defw qerr-9 -qcomp: - defw docol - defw state - defw at - defw zequ - defw lit - defw 11h - defw qerr - defw semis -; -; - defb 85h ; ?EXEC - defc '?EXEC' - defw qcomp-8 -qexec: - defw docol - defw state - defw at - defw lit - defw 12h - defw qerr - defw semis -; -; - defb 86h ; ?PAIRS - defc '?PAIRS' - defw qexec-8 -qpair: - defw docol - defw subb - defw lit - defw 13h - defw qerr - defw semis -; -; - defb 84h ; ?CSP - defc '?CSP' - defw qpair-9 -qcsp: - defw docol - defw spat - defw cspp - defw at - defw subb - defw lit - defw 14h - defw qerr - defw semis -; -; - defb 88h ; ?LOADING - defc '?LOADING' - defw qcsp-7 -qload: - defw docol - defw blk - defw at - defw zequ - defw lit - defw 16h - defw qerr - defw semis -; -; - defb 87h ; COMPILE - defc 'COMPILE' - defw qload-0bh -comp: - defw docol - defw qcomp - defw fromr - defw dup - defw twop - defw tor - defw at - defw comma - defw semis -; -; - defb 0c1h ; [ - defc '[' - defw comp-0ah -lbrac: - defw docol - defw zero - defw state - defw store - defw semis -; -; - defb 81h ; ] - defc ']' - defw lbrac-4 -rbrac: - defw docol - defw lit,0c0h - defw state,store - defw semis -; -; - defb 86h ; SMUDGE - defc 'SMUDGE' - defw rbrac-4 -smudg: - defw docol - defw lates - defw lit - defw 20h - defw toggl - defw semis -; -; - defb 83h ; HEX - defc 'HEX' - defw smudg-9 -hex: - defw docol - defw lit - defw 10h - defw base - defw store - defw semis -; -; - defb 87h ; DECIMAL - defc 'DECIMAL' - defw hex-6 -dec: - defw docol - defw lit - defw 0ah - defw base - defw store - defw semis -; -; - defb 87h ; (;CODE) - defc '( ;CODE)' - defw dec-0ah -pscod: - defw docol - defw fromr - defw lates - defw pfa - defw cfa - defw store - defw semis -; -; - defb 0c5h ; ;CODE - defc ';CODE' - defw pscod-0ah -semic: - defw docol - defw qcsp - defw comp - defw pscod - defw lbrac -semi1: - defw noop ; assembler - defw semis -; -; - defb 87h ; - defc 'DOES>' - defw build-0ah -does: - defw docol - defw fromr - defw lates - defw pfa - defw store - defw pscod -dodoe: - ld hl,(rpp) - dec hl - dec hl - ;ldw (hl),bc ;/ - DEFB 0EDh,0Eh - ld (rpp),hl - inc de - ex de,hl - ;ldw bc,(hl) ;/ - DEFB 0EDh,06h - inc hl - inc hl - jhpush -; -; - defb 85h ; COUNT - defc 'COUNT' - defw does-8 -count: - defw docol - defw dup - defw onep - defw swap - defw cat - defw semis -; -; - defb 84h ; TYPE - defc 'TYPE' - defw count-8 -type: - defw docol - defw ddup - defw zbran ; if - defw type1-$ - defw over - defw plus - defw swap - defw xdo ; do -type2: - defw ido - defw cat - defw emit - defw xloop ; loop - defw type2-$ - defw bran ; else - defw type3-$ -type1: - defw drop ; endif -type3: - defw semis -; -; - defb 89h ; -TRAILING - defc '-TRAILING' - defw type-7 -dtrai: - defw docol - defw dup - defw zero - defw xdo ; do -dtra1: - defw tdup ;/ - defw plus - defw onemin ;/ - defw cat - defw bl - defw subb - defw zbran ; if - defw dtra2-$ - defw leave - defw bran ; else - defw dtra3-$ -dtra2: - defw onemin ;/ -dtra3: - defw xloop ; loop - defw dtra1-$ - defw semis -; -; - defb 84h ; (.") - defc '(.")' - defw dtrai-0ch -pdotq: - defw docol - defw rr - defw count - defw dup - defw onep - defw fromr - defw plus - defw tor - defw type - defw semis -; -; - defb 0c2h ; ." - defc '."' - defw pdotq-7 -dotq: - defw docol - defw lit - defw 22h - defw state - defw at - defw zbran ; if - defw dotq1-$ - defw comp - defw pdotq - defw word - defw here - defw cat - defw onep - defw allot - defw bran ; else - defw dotq2-$ -dotq1: - defw word - defw here - defw count - defw type ; endif -dotq2: - defw semis -; -; - defb 86h ; EXPECT - defc 'EXPECT' - defw dotq-5 -expec: - defw docol - defw over - defw plus - defw over - defw xdo ; do -expe1: - defw key - defw dup - defw lit - defw 0eh - defw porig - defw at - defw equal - defw zbran ; if - defw expe2-$ - defw drop - defw dup - defw ido - defw equal - defw dup - defw fromr - defw twomin ;/ - defw plus - defw tor - defw zbran ; if - defw expe6-$ - defw lit - defw bell - defw bran ; else - defw expe7-$ -expe6: - defw lit - defw bsout ; endif -expe7: - defw bran ; else - defw expe3-$ -expe2: - defw dup - defw lit - defw acr ;/ - defw equal - defw zbran ; if - defw expe4-$ - defw leave - defw drop - defw bl - defw zero - defw bran ; else - defw expe5-$ -expe4: - defw dup ; endif -expe5: - defw ido - defw cstor - defw zero - defw ido - defw onep - defw store ; endif -expe3: - defw emit - defw xloop ; loop - defw expe1-$ - defw drop - defw semis -; -; - defb 85h ; QUERY - defc 'QUERY' - defw expec-9 -query: - defw docol - defw tib - defw at - defw lit - defw 50h - defw expec - defw zero - defw inn - defw store - defw semis -; -; - defb 0c1h ; NULL - defb 80h - defw query-8 -null: - defw docol - defw blk - defw at - defw zbran ; if - defw null1-$ - defw one - defw blk - defw pstor - defw zero - defw inn - defw store - defw blk - defw at - defw bscr - defw onemin ;/ - defw andd - defw zequ - defw zbran ; if - defw null2-$ - defw qexec - defw fromr - defw drop ; endif -null2: - defw bran ; else - defw null3-$ -null1: - defw fromr - defw drop ; endif -null3: - defw semis -; - defb 84h ; FILL - defc 'FILL' - defw null-4 -fill: - defw $+2 - exx ;/ save ip - pop de ;/ e <-- byte - pop bc ; bc <-- quantity - pop hl ;/ hl <-- address -fill1: - ld a,b - or c ; qty == 0? - jr z,fill2 ; yes, nothing (more) to fill - ld (hl),e ;/ (hl) <-- byte - inc hl ; inc pointer - dec bc ; dec counter - jp fill1 ;/ -fill2: - exx ;/ restore ip - jnext -; -; - defb 85h ; ERASE - defc 'ERASE' - defw fill-7 -erasee: - defw docol - defw zero - defw fill - defw semis -; -; - defb 86h ; BLANKS - defc 'BLANKS' - defw erasee-8 -blank: - defw docol - defw bl - defw fill - defw semis -; -; - defb 84h ; HOLD - defc 'HOLD' - defw blank-9 -hold: - defw docol - defw lit - defw -1 - defw hld - defw pstor - defw hld - defw at - defw cstor - defw semis -; -; - defb 83h ; PAD - defc 'PAD' - defw hold-7 -pad: - defw docol - defw here - defw lit - defw 44h - defw plus - defw semis -; -; - defb 84h ; WORD - defc 'WORD' - defw pad-6 -word: - defw docol - defw blk - defw at - defw zbran ; if - defw word1-$ - defw blk - defw at - defw block - defw bran ; else - defw word2-$ -word1: - defw tib - defw at ; endif -word2: - defw inn - defw at - defw plus - defw swap - defw encl - defw here - defw lit - defw 22h - defw blank - defw inn - defw pstor - defw over - defw subb - defw tor - defw rr - defw here - defw cstor - defw plus - defw here - defw onep - defw fromr - defw cmove - defw semis -; -; - defb 88h ; (NUMBER) - defc '(NUMBER)' - defw word-7 -pnumb: - defw docol -pnum1: - defw onep ; begin - defw dup - defw tor - defw cat - defw base - defw at - defw digit - defw zbran ; while - defw pnum2-$ - defw swap - defw base - defw at - defw ustar - defw drop - defw rot - defw base - defw at - defw ustar - defw dplus - defw dpl - defw at - defw onep - defw zbran ; if - defw pnum3-$ - defw one - defw dpl - defw pstor ; endif -pnum3: - defw fromr - defw bran ; repeat - defw pnum1-$ -pnum2: - defw fromr - defw semis -; -; - defb 86h ; NUMBER - defc 'NUMBER' - defw pnumb-0bh -numb: - defw docol - defw zero - defw zero - defw rot - defw dup - defw onep - defw cat - defw lit - defw 2dh - defw equal - defw dup - defw tor - defw plus - defw lit - defw -1 -numb1: - defw dpl ; begin - defw store - defw pnumb - defw dup - defw cat - defw bl - defw subb - defw zbran ; while - defw numb2-$ - defw dup - defw cat - defw lit - defw 2eh - defw subb - defw zero - defw qerr - defw zero - defw bran ; repeat - defw numb1-$ -numb2: - defw drop - defw fromr - defw zbran ; if - defw numb3-$ - defw dminu ; endif -numb3: - defw semis -; -; - defb 85h ; -FIND (0-3) SUCCESS - defc '-FIND' ; (0-1) FAILURE - defw numb-9 -dfind: - defw docol - defw bl - defw word - defw here - defw cont - defw at - defw at - defw pfind - defw dup - defw zequ - defw zbran ; if - defw dfin1-$ - defw drop - defw here - defw lates - defw pfind ; endif -dfin1: - defw semis -; -; - defb 87h ; (ABORT) - defc '(ABORT)' - defw dfind-8 -pabor: - defw docol - defw abort - defw semis -; - defb 85h ; ERROR - defc 'ERROR' - defw pabor-0ah -error: - defw docol - defw warn - defw at - defw zless - defw zbran ; if - defw erro1-$ - defw pabor ; endif -erro1: - defw here - defw count - defw type - defw pdotq - defb 2 - db '? ' - defw mess - defw spsto -; CHANGE FROM fig MODEL -; defw inn,at,blk,at - defw blk,at - defw ddup - defw zbran,erro2-$ ; if - defw inn,at - defw swap ; endif -erro2: - defw quit -; -; - defb 83h ; ID. - defc 'ID.' - defw error-8 -iddot: - defw docol - defw pad - defw lit - defw 20h - defw blank ;/ - defw dup - defw pfa - defw lfa - defw over - defw subb - defw dup ;/ change frm MODEL - defw tor ;/ to suppress BIT 7 - defw pad - defw swap - defw cmove - defw pad - defw fromr ;/ for terminals - defw pad ;/ with an 8 bit - defw plus ;/ ASCII character set. - defw onemin ;/ - defw dup ;/ - defw at ;/ - defw lit ;/ - defw 7fh ;/ - defw andd ;/ - defw swap ;/ - defw store ;/ - defw count - defw lit - defw 1fh ; WIDTH - defw andd - defw type - defw space - defw semis -; - defb 86h ; CREATE - defc 'CREATE' - defw iddot-6 -creat: - defw docol - defw dfind - defw zbran ; if - defw crea1-$ - defw drop - defw nfa - defw iddot - defw lit - defw 4 - defw mess - defw space ; endif -crea1: - defw here - defw dup - defw cat - defw width - defw at - defw min - defw onep - defw allot - defw dup - defw lit - defw 0a0h - defw toggl - defw here - defw onemin - defw lit - defw 80h - defw toggl - defw lates - defw comma - defw curr - defw at - defw store - defw here - defw twop - defw comma - defw semis -; -; - defb 0c9h ; [COMPILE] - defc '[COMPILE]' - defw creat-9 -bcomp: - defw docol - defw dfind - defw zequ - defw zero - defw qerr - defw drop - defw cfa - defw comma - defw semis -; -; - defb 0c7h ; LITERAL - defc 'LITERAL' - defw bcomp-0ch -liter: - defw docol - defw state - defw at - defw zbran ; if - defw lite1-$ - defw comp - defw lit - defw comma ; endif -lite1: - defw semis -; -; - defb 0c8h ; DLITERAL - defc 'DLITERAL' - defw liter-0ah -dlite: - defw docol - defw state - defw at - defw zbran ; if - defw dlit1-$ - defw swap - defw liter - defw liter ; endif -dlit1: - defw semis -; -; - defb 86h ; ?STACK - defc '?STACK' - defw dlite-0bh -qstac: - defw docol - defw spat - defw szero - defw at - defw swap - defw uless - defw one - defw qerr - defw spat - defw here - defw lit - defw 80h - defw plus - defw uless - defw lit - defw 7 - defw qerr - defw semis -; -; - defb 89h ; INTERPRET - defc 'INTERPRET' - defw qstac-9 -inter: - defw docol -inte1: - defw dfind ; begin - defw zbran ; if - defw inte2-$ - defw state - defw at - defw less - defw zbran ; if - defw inte3-$ - defw cfa - defw comma - defw bran ; else - defw inte4-$ -inte3: - defw cfa - defw exec ; endif -inte4: - defw qstac - defw bran ; else - defw inte5-$ -inte2: - defw here - defw numb - defw dpl - defw at - defw onep - defw zbran ; if - defw inte6-$ - defw dlite - defw bran ; else - defw inte7-$ -inte6: - defw drop - defw liter ; endif -inte7: - defw qstac ; endif -inte5: - defw bran ; again - defw inte1-$ -; -; - defb 89h ; IMMEDIATE - defc 'IMMEDIATE' - defw inter-0ch -immed: - defw docol - defw lates - defw lit - defw 40h - defw toggl - defw semis -; -; - defb 8ah ; VOCABULARY - defc 'VOCABULARY' - defw immed-0ch -vocab: - defw docol - defw build - defw lit - defw 0a081h - defw comma - defw curr - defw at - defw cfa - defw comma - defw here - defw vocl - defw at - defw comma - defw vocl - defw store - defw does -dovoc: - defw twop - defw cont - defw store - defw semis -; -; - defb 0c5h ; FORTH - defc 'FORTH' - defw vocab-0dh -forth: - defw dodoe - defw dovoc - defw 0a081h - defw task-7 ; cold start value only -; changed aech time a def is appended -; to the FORTH vocabulary - defw 0 ; end of vocabulary list -; -; - defb 8bh ; DEFINITIONS - defc 'DEFINITIONS' - defw forth-8 -defin: - defw docol - defw cont - defw at - defw curr - defw store - defw semis -; -; - defb 0c1h ; ( - defc '(' - defw defin-0eh -paren: - defw docol - defw lit - defw 29h - defw word - defw semis -; -; - defb 84h ; QUIT - defc 'QUIT' - defw paren-4 -quit: - defw docol - defw zero - defw blk - defw store - defw lbrac -quit1: - defw rpsto ; begin - defw cr - defw query - defw inter - defw state - defw at - defw zequ - defw zbran ; if - defw quit2-$ - defw pdotq - defb 2 - db 'ok' ; endif -quit2: - defw bran ; again - defw quit1-$ -; -; - defb 85h ; ABORT - defc 'ABORT' - defw quit-7 -abort: - defw docol - defw spsto - defw dec - defw qstac - defw cr - defw dotcpu - defw pdotq - defb 0eh ; count of chrs to follow - db 'fig-FORTH ' - defb figrel+30h,adot,figrev+30h,usrver - defw forth - defw defin - defw quit -; -; -wrm: ld bc,wrm1 - jnext -wrm1: defw warm -; -; - defb 84h ; WARM - defc 'WARM' - defw abort-8 -warm: - defw docol - defw mtbuf - defw abort -; -; -cld: - ld hl,(bdoss+1) ;/ - ld l,0 ;/ hl <-- fbase - ld (limit+2),hl ;/ set limit - ld de,bufsiz ;/ de <-- total disc buffer size - ;subw hl,de ;/ hl <-- addr. of 1st disc buffer - DEFB 0EDH,0DEh - ld (first+2),hl ;/ set FIRST - ld (use+2),hl ;/ set USE - ld (prev+2),hl ;/ set PREV - ld (buf1),hl ;/ - ld de,us ;/ de <-- user variable space - ;subw hl,de ;/ hl <-- initr0 - DEFB 0EDH,0DEh - ld (upinit),hl ;/ - ld (r0init),hl ;/ - ld (up),hl ;/ - ld (rpp),hl ;/ - ld de,rts ;/ de <-- rtn stack & term. buf space - ;subw hl,de ;/ hl <-- inits0 - DEFB 0EDH,0DEh - ld (s0init),hl ;/ - ld (tibini),hl ;/ - ld sp,hl ;/ - ld bc,cld1 - ld ix,next ; pointer to next - ld iy,hpush ; pointer to hpush - jnext -; -; -cld1: defw cold -; - defb 84h ; COLD - defc 'COLD' - defw warm-7 -cold: - defw docol - defw mtbuf - defw one,recadr ; AvdH - defw store - defw lit,buf1 - defw at ;/ - defw use,store - defw lit,buf1 - defw at ;/ - defw prev,store - defw drzer - defw zero ;/ - defw lit,eprint - defw cstor ;/ -; - defw lit - defw orig+12h - defw lit - defw up - defw at - defw lit - defw 6 - defw plus - defw lit - defw 10h - defw cmove - defw lit - defw orig+0ch - defw at - defw lit - defw forth+6 - defw store - defw fcb ;/A - defw lit,opnfil ;/A open mass storage - defw bdos ;/A - defw lit,0ffh ;/A - defw equal ;/A file present? - defw zbran,cld2-$ ;/A - defw zero ;/A - defw warn,store ;/A - defw cr,pdotq ;/A - defb 7 ;/A - db 'No file' ;/A -cld2: - defw abort -; -; - defb 84h ; S->D - defc 'S->D' - defw cold-7 -stod: defw $+2 - pop hl ;/ - ;exts hl ;/ de <-- h(7) - DEFB 0EDH,6Ch - ex de,hl ;/ - jp dpush ; ( n1 -- d1L d1H) -; -; - defb 82h ; +- - defc '+-' - defw STOD-7 -pm: - defw docol - defw zless - defw zbran ; if - defw pm1-$ - defw minus ; endif -pm1: - defw semis -; -; - defb 83h ; D+- - defc 'D+-' - defw pm-5 -dpm: - defw docol - defw zless - defw zbran ; if - defw dpm1-$ - defw dminu ; endif -dpm1: - defw semis -; -; - defb 83h ; ABS - defc 'ABS' - defw dpm-6 -abs: - defw docol - defw dup - defw pm - defw semis -; -; - defb 84h ; DABS - defc 'DABS' - defw abs-6 -dabs: - defw docol - defw dup - defw dpm - defw semis -; -; - defb 83h ; MIN - defc 'MIN' - defw dabs-7 -min: - defw docol - defw tdup - defw great - defw zbran ; if - defw min1-$ - defw swap ; endif -min1: - defw drop - defw semis -; -; - defb 83h ; MAX - defc 'MAX' - defw min-6 -max: defw docol - defw tdup - defw less - defw zbran ; if - defw max1-$ - defw swap ; endif -max1: - defw drop - defw semis -; -; - defb 82h ; M* ( n1 n2 --- d) - defc 'M*' - defw max-6 -mstar: - defw $+2 ;/ - pop de ; de <-- multiplicator - pop hl ; hl <-- multiplicant - ;multw hl,de ;/ dehl <-- hl * de - DEFB 0EDH,0D2h - ex de,hl ;/ - jp dpush ;/ ( n1 n2 --- d1l d1h) -; -; - defb 82h ;/ M/ ( d n1 --- nrem nquot) - defc 'M/' - defw mstar-5 -mslas: - defw $+2 ; ( d n1 --- n2 n3) - exx ; save ip - pop hl ; divisor - ld a,h - and 80h ; filter sign - jr z,mslas1 ; positive - ;neg hl ; make positive - DEFB 0EDH,4Ch -mslas1: - ld b,h - ld c,l ; bc <-- divisor - pop hl ; dividend.hw - pop de ; dividend.lw - bit 7,h ; negative? - jr z,mslas2 ; no - inc a ; dividend sign flag - push hl - ld hl,0 - ;subw hl,de ; neg dividend.lw - DEFB 0EDH,0DEh - pop de ; dividend.hw - push hl - ld hl,0 - sbc hl,de ; neg dividend.hw - pop de ; dividend.lw -mslas2: - ;cpw hl,bc ; dividend.hw >= divisor - DEFB 0EDH,0C7h - jr c,mslas3 ; no overflow, continue - ld hl,0ffffh - ld d,h - ld e,l ; set rem & quot to max. - jr mslas5 -; -mslas3: - ex de,hl ; dehl <-- dividend.hw,lw - ;divuw dehl,bc ; de <-- remainder, hl <-- quotient - DEFB 0EDH,0CBh - ex de,hl ; hl <-- remainder - bit 0,a ; was dividend negative - jr z,mslas4 ; no - ;neg hl ;/ yes, negate remainder - DEFB 0EDH,4Ch -mslas4: - ex de,hl ; hl <-- quotient - or a - jr z,mslas5 ; neither operand negative - cp 81h ; both operands negative? - jr z,mslas5 ; yes, quotient stays positive - ;neg hl ;/ no, negate quotient - DEFB 0EDH,4Ch -mslas5: - push de ; remainder - push hl ; quotient - exx ; restore ip - jnext -; -; - defb 81h ; * ( n1 n2 --- nproduct) - defc '*' - defw mslas-5 -star: - defw $+2 - pop de - pop hl - ;multw hl,de ;/ dehl <-- product - DEFB 0EDH,0D2h - jhpush -; -; - defb 84h ; /MOD ( n1 n2 --- nrem nquot) - defc '/MOD' - defw star-4 -slmod: - defw $+2 - exx ;/ save ip - pop bc ;/ divisor - pop hl ; dividend - ld a,b - or c ;/ div by 0? - jr nz,slmod1 ;/ no, continue - ld de,0ffffh - ld h,d - ld l,e ;/ set remainder & quotient to max. - jr slmod3 -slmod1: - ;cpw hl,8000h ;/ special case -32768 -1 / - DEFB 0FDH - DEFB 0EDH,0F7h - DEFW 8000H - jr nz,slmod2 ;/ continue - ld a,b - cp 0ffh - jr nz,slmod2 - cp c ;/ lo byte also 0ffh? - jr nz,slmod2 ;/ no, go & divide - ld de,0 ;/ remainder - jr slmod3 ;/ exit with dividend unchanged -slmod2: - ;exts hl ;/ de <-- dividend.hw - DEFB 0EDH,6Ch - ;divw dehl,bc ;/ de <-- remainder, hl <-- quotient - DEFB 0EDH,0CAh -slmod3: - push de - push hl - exx ;/ restore ip - jnext -; -; - defb 81h ; / - defc '/' - defw slmod-7 -slash: - defw $+2 - exx ;/ save ip - pop bc ;/ divisor - pop hl ; dividend - ld a,b - or c ;/ division by 0? - jr nz,slash1 ;/ no, continue - ld hl,0ffffh ;/ set quotient to max. - jr slash3 -slash1: - ;cpw hl,8000h ;/ special case -32768 -1 / - DEFB 0FDH - DEFB 0EDH,0F7h - DEFW 8000H - jr nz,slash2 ;/ dividend not -32768 - ld a,b - cp 0ffh - jr nz,slash2 ;/ divisor not -1 - cp c - jr z,slash3 ;/ return with dividend unchanged -slash2: - ;exts hl ;/ de <-- dividend.hw - DEFB 0EDH,6Ch - ;divw dehl,bc ;/ hl <-- quotient - DEFB 0EDH,0CAh -slash3: - push hl ;/ quotient - exx ;/ restore ip - jnext -; -; - defb 83h ;/ MOD - defc 'MOD' - defw slash-4 -modd: - defw $+2 - exx ; save ip - pop bc ; divisor - pop hl ; dividend - ld a,b - or c ; division by 0? - jr nz,modd1 ; no, continue - ld de,0ffffh ; set remainder to max - jr modd3 -modd1: - ;cpw hl,8000h ;/ special case -32768 -1 / - DEFB 0FDH - DEFB 0EDH,0F7h - DEFW 8000H - jr nz,modd2 ; dividend not -32768 - ld a,b - cp 0ffh - jr nz,modd2 ; divisor not -1 - cp c - jr nz,modd2 ; go & divide - ld de,0 ; remainder - jr modd3 -modd2: - ;exts hl ; de <-- dividend.hw - DEFB 0EDH,6Ch - ;divw dehl,bc ; de <-- remainder - DEFB 0EDH,0CAh -modd3: - push de ; remainder - exx ; restore ip - jnext -; -; - defb 85h ;/ */MOD - defc '*/MOD' - defw modd-6 -ssmod: - defw $+2 - exx ; save ip - pop hl ; divisor - ld a,h - and 80h ; filter sign - jr z,ssmod1 ; positive - ;neg hl ; make positive - DEFB 0EDH,4Ch -ssmod1: - ld b,h - ld c,l ; bc <-- divisor - pop hl ; multipicator - pop de ; multiplicant - ex af,af' ; save sign flag - ;multw hl,de ; dehl <-- product (= dividend) - DEFB 0EDH,0D2h - ex af,af' ; restore sign flag - ex de,hl ; de <-- dividend.lw - bit 7,h ; dividend negative? - jr z,ssmod2 ; no - inc a ; dividend sign flag - push hl - ld hl,0 - ;subw hl,de ; neg dividend.lw - DEFB 0EDH,0DEh - pop de ; dividend.hw - push hl - ld hl,0 - sbc hl,de ; neg dividend.hw - pop de ; dividend.lw -ssmod2: - ;cpw hl,bc ; dividend.hw >= divisor? - DEFB 0EDH,0C7h - jr c,ssmod3 ; no overflow, continue - ld hl,0ffffh - ld d,h - ld e,l ; set rem & quot to max - jr ssmod5 -; -ssmod3: - ex de,hl ; dehl <-- dividend.hw,lw - ;divuw dehl,bc ; de <-- remainder, hl <-- quotient - DEFB 0EDH,0CBh - ex de,hl ; hl <-- remainder - bit 0,a ; was dividend negative? - jr z,ssmod4 ; no - ;neg hl ; yes, negate remainder - DEFB 0EDH,4Ch -ssmod4: - ex de,hl ; hl <-- quotient - or a - jr z,ssmod5 ; neither operand negative - cp 81h ; both operands negative? - jr z,ssmod5 ; yes, quotient stays positive - ;neg hl ; no, negate quotient - DEFB 0EDH,4Ch -ssmod5: - push de ; remainder - push hl ; quotient - exx ; restore ip - jnext -; -; - defb 82h ; */ - defc '*/' - defw ssmod-8 -ssla: - defw $+2 ;/ - exx ; save ip - pop hl ; divisor - ld a,h - and 80h ; filter sign - jr z,ssla1 ; positive - ;neg hl ; make positive - DEFB 0EDH,4Ch -ssla1: - ld b,h - ld c,l ; bc <-- divisor - pop hl ; multipicator - pop de ; multiplicant - ex af,af' ; save sign flag - ;multw hl,de ; dehl <-- product (= dividend) - DEFB 0EDH,0D2h - ex af,af' ; restore sign flag - ex de,hl ; de <-- dividend.lw - bit 7,h ; dividend negative? - jr z,ssla2 ; no - inc a ; dividend sign flag - push hl - ld hl,0 - ;subw hl,de ; neg dividend.lw - DEFB 0EDH,0DEh - pop de ; dividend.hw - push hl - ld hl,0 - sbc hl,de ; neg dividend.hw - pop de ; dividend.lw -ssla2: - ;cpw hl,bc ; dividend.hw >= divisor? - DEFB 0EDH,0C7h - jr c,ssla3 ; no overflow, continue - ld hl,0ffffh ; set quotient to max - jr ssla4 -; -ssla3: - ex de,hl ; dehl <-- dividend.hw,lw - ;divuw dehl,bc ; de <-- remainder, hl <-- quotient - DEFB 0EDH,0CBh - or a - jr z,ssla4 ; neither operand negative - cp 81h ; both operands negative? - jr z,ssla4 ; yes, quotient stays positive - ;neg hl ; no, negate quotient - DEFB 0EDH,4Ch -ssla4: - push hl ; quotient - exx ; restore ip - jnext -; -; - defb 85h ; M/MOD - defc 'M/MOD' - defw ssla-5 -msmod: - defw docol - defw tor - defw zero - defw rr - defw uslas - defw fromr - defw swap - defw tor - defw uslas - defw fromr - defw semis -; -; -; Block moved down 2 pages -; - defb 86h ; (LINE) - defc '(LINE)' - defw msmod-8 -pline: - defw docol - defw tor - defw lit - defw 40h - defw bbuf - defw ssmod - defw fromr - defw bscr - defw star - defw plus - defw block - defw plus - defw lit - defw 40h - defw semis -; -; - defb 85h ; .LINE - defc '.LINE' - defw pline-9 -dline: - defw docol - defw pline - defw dtrai - defw type - defw semis -; -; - defb 87h ; MESSAGE - defc 'MESSAGE' - defw dline-8 -mess: - defw docol - defw warn - defw at - defw zbran ; if - defw mess1-$ - defw ddup - defw zbran ; if - defw mess2-$ - defw lit - defw 4 ; 1st message screen - defw ofset - defw at - defw bscr - defw slash - defw subb - defw dline - defw space ; endif -mess2: - defw bran ; else - defw mess3-$ -mess1: - defw pdotq - defb 6 - db 'MSG # ' - defw dot ; endif -mess3: defw semis -; -; - defb 82h ; P@ - defc 'P@' - defw mess-0ah -ptat: - defw $+2 - exx ;d save registers - pop bc ;d bc <-- port# - in l,(c) ;d l <-- data byte - ld h,0 - push hl - exx ;d restore registers - jnext -; -; - defb 82h ; P! - defc 'P!' - defw ptat-5 -ptsto: - defw $+2 - exx ;d save registers - pop bc ;d c <-- port# - pop hl ;d L <-- date byte - out (c),l - exx ;d restore registers - jnext -; -; - page -include DISCIO.Z80 - page -include CONPRTIO.Z80 - page -; - defb 0c1h ; ' (tick) - defb 0a7h - defw arrow-6 -tick: - defw docol - defw dfind - defw zequ - defw zero - defw qerr - defw drop - defw liter - defw semis -; -; - defb 86h ; FORGET - defc 'FORGET' - defw tick-4 -forg: - defw docol - defw curr - defw at - defw cont - defw at - defw subb - defw lit - defw 18h - defw qerr - defw tick - defw dup - defw fence - defw at - defw uless ;/ FORGET >8000h nw o.k. - defw lit - defw 15h - defw qerr - defw dup - defw nfa - defw dp - defw store - defw lfa - defw at - defw cont - defw at - defw store - defw semis -; -; - defb 84h ; BACK - defc 'BACK' - defw forg-9 -back: - defw docol - defw here - defw subb - defw comma - defw semis -; -; - defb 0c5h ; BEGIN - defc 'BEGIN' - defw back-7 -begin: - defw docol - defw qcomp - defw here - defw one - defw semis -; -; - defb 0c5h ; ENDIF - defc 'ENDIF' - defw begin-8 -endiff: - defw docol - defw qcomp - defw two - defw qpair - defw here - defw over - defw subb - defw swap - defw store - defw semis -; -; - defb 0c4h ; THEN - defc 'THEN' - defw endiff-8 -then: defw docol - defw endiff - defw semis -; -; - defb 0c2h ; DO - defc 'DO' - defw then-7 -do: - defw docol - defw comp - defw xdo - defw here - defw three - defw semis -; -; - defb 0c4h ; LOOP - defc 'LOOP' - defw do-5 -loop: - defw docol - defw three - defw qpair - defw comp - defw xloop - defw back - defw semis -; -; - defb 0c5h ; +LOOP - defc '+LOOP' - defw loop-7 -ploop: - defw docol - defw three - defw qpair - defw comp - defw xploo - defw back - defw semis -; -; - defb 0c5h ; UNTIL - defc 'UNTIL' - defw ploop-8 -until: - defw docol - defw one - defw qpair - defw comp - defw zbran - defw back - defw semis -; -; - defb 0c3h ; END - defc 'END' - defw until-8 -endd: - defw docol - defw until - defw semis -; -; - defb 0c5h ; AGAIN - defc 'AGAIN' - defw endd-6 -again: - defw docol - defw one - defw qpair - defw comp - defw bran - defw back - defw semis -; -; - defb 0c6h ; REPEAT - defc 'REPEAT' - defw again-8 -repea: - defw docol - defw tor - defw tor - defw again - defw fromr - defw fromr - defw twomin ;/ - defw endiff - defw semis -; -; - defb 0c2h ; IF - defc 'IF' - defw repea-9 -iff: - defw docol - defw comp - defw zbran - defw here - defw zero - defw comma - defw two - defw semis -; -; - defb 0c4h ; ELSE - defc 'ELSE' - defw iff-5 -elsee: - defw docol - defw two - defw qpair - defw comp - defw bran - defw here - defw zero - defw comma - defw swap - defw two - defw endiff - defw two - defw semis -; -; - defb 0c5h ; WHILE - defc 'WHILE' - defw elsee-7 -while: - defw docol - defw iff - defw twop - defw semis -; -; - defb 86h ; SPACES - defc 'SPACES' - defw while-8 -spacs: - defw docol - defw zero - defw max - defw ddup - defw zbran ; if - defw spax1-$ - defw zero - defw xdo ; do -spax2: - defw space - defw xloop ; loop endif - defw spax2-$ -spax1: - defw semis -; -; - defb 82h ; <# - defc '<#' - defw spacs-9 -bdigs: - defw docol - defw pad - defw hld - defw store - defw semis -; -; - defb 82h ; #> - defc '#>' - defw bdigs-5 -edigs: - defw docol - defw drop - defw drop - defw hld - defw at - defw pad - defw over - defw subb - defw semis -; -; - defb 84h ; SIGN - defc 'SIGN' - defw edigs-5 -sign: - defw docol - defw rot - defw zless - defw zbran ; if - defw sign1-$ - defw lit - defw 2dh - defw hold ; endif -sign1: - defw semis -; -; - defb 81h ; # - defc '#' - defw sign-7 -dig: - defw docol - defw base - defw at - defw msmod - defw rot - defw lit - defw 9 - defw over - defw less - defw zbran ; if - defw dig1-$ - defw lit - defw 7 - defw plus ; endif -dig1: defw lit - defw 30h - defw plus - defw hold - defw semis -; -; - defb 82h ; #S - defc '#S' - defw dig-4 -digs: - defw docol -digs1: - defw dig ; begin - defw tdup ;/ - defw orr - defw zequ - defw zbran ; until - defw digs1-$ - defw semis -; -; - defb 83h ; D.R - defc 'D.R' - defw digs-5 -ddotr: - defw docol - defw tor - defw swap - defw over - defw dabs - defw bdigs - defw digs - defw sign - defw edigs - defw fromr - defw over - defw subb - defw spacs - defw type - defw semis -; -; - defb 82h ; .R - defc '.R' - defw ddotr-6 -dotr: - defw docol - defw tor - defw stod - defw fromr - defw ddotr - defw semis -; -; - defb 82h ; D. - defc 'D.' - defw dotr-5 -ddot: - defw docol - defw zero - defw ddotr - defw space - defw semis -; -; - defb 81h ; . - defc '.' - defw ddot-5 -dot: - defw docol - defw stod - defw ddot - defw semis -; -; - defb 81h ; ? - defc '?' - defw dot-4 -ques: - defw docol - defw at - defw dot - defw semis -; -; - defb 82h ; U. - defc 'U.' - defw ques-4 -udot: defw docol - defw zero - defw ddot - defw semis -; - - defb 85h ; VLIST - defc 'VLIST' - defw udot-5 -vlist: - defw docol - defw lit - defw 80h - defw outt - defw store - defw cont - defw at - defw at -vlis1: - defw outt ; begin - defw at - defw csll - defw great - defw zbran ; if - defw vlis2-$ - defw cr - defw zero - defw outt - defw store ; endif -vlis2: - defw dup - defw iddot - defw space - defw space - defw pfa - defw lfa - defw at - defw dup - defw zequ - defw qterm - defw orr - defw zbran ; until - defw vlis1-$ - defw drop - defw semis -; -; - defb 83h ; BYE - defc 'BYE' - defw vlist-8 -bye: - defw docol ;/A - defw flush ;/A - defw fcb,lit ;/E - defw 10h,bdos ;/E close file - defw drop ;/E discard directory code - defw zero,zero ;/A - defw bdos ;/A return to CP/M - defw semis ;/A won't get this far, just for pretty -; -; - defb 84h ; LIST - defc 'LIST' - defw bye-6 -list: - defw docol,dec - defw cr,dup - defw scr,store - defw pdotq - defb 6 - db 'SCR # ' - defw dot - defw lit,10h - defw zero,xdo -list1: - defw cr,ido - defw three ;/ was lit,3 - defw dotr,space - defw ido,scr - defw at,dline - defw qterm - defw zbran,list2-$ ; if - defw leave -list2: - defw xloop,list1-$ ; endif - defw cr - defw semis -; -; - defb 85H ;INDEX - defc 'INDEX' - defw list-7 -index: - defw docol - defw lit,ff - defw emit - defw cr - defw onep,swap - defw xdo -inde1: - defw cr,ido - defw three ;/ was lit,3 - defw dotr,space - defw zero,ido - defw dline,qterm - defw zbran,inde2-$ ; if - defw leave ; endif -inde2: - defw xloop,inde1-$ - defw semis -; -; - defb 85h ; TRIAD - defc 'TRIAD' - defw index-8 -triad: - defw docol - defw lit,ff - defw emit - defw three ;/ was lit,3 - defw slash - defw three ;/ was lit,3 - defw star - defw three ;/ was lit,3 - defw over,plus - defw swap,xdo -tria1: - defw cr,ido - defw list - defw qterm - defw zbran,tria2-$ ; if - defw leave -tria2: - defw xloop,tria1-$ ; endif - defw cr - defw lit,15 - defw mess,cr - defw semis -; -; - defb 84h ; .CPU - defc '.CPU' - defw triad-8 -dotcpu: - defw docol - defw base,at - defw lit,36 - defw base,store - defw lit,22h - defw porig,tat - defw ddot - defw base,store - defw semis -; -; - defb 86h ; setclk - defc 'setclk' - defw dotcpu-7 -setclk: - defw $+2 - exx ; save ip - ld c,iopreg - ;ldctl hl,(c) ; l <-- current i/o page - DEFB 0EDh,66h - ld a,l - ex af,af' ; save i/o page - ld l,0feh - ;ldctl (c),hl ; select i/o page 0feh - DEFB 0EDh,6Eh - xor a - out (cntrl0),a ; disable c/t 0 - out (cntrl1),a ; disable c/t 1 - out (config1),a - ld hl,0ffffh - ld a,10h - out (config0),a ; cascade c/t 0 - c/t 1 - ld c,tcon0 - ;outw (c),hl ; load c/t 0 time constant - DEFB 0EDH,0BFh - ld c,tcon1 - ;outw (c),hl ; load c/t 1 time constatnt - DEFB 0EDH,0BFh - ld a,80h - out (config1),a ; continous mode - ld a,0e0h - out (cntrl1),a ; start 32bit counter - ex af,af' ; std. accu - ld l,a ; l <-- previous i/o page - ld c,iopreg - ;ldctl (c),hl ; restore i/o page - DEFB 0EDh,6Eh - exx ; restore ip - jnext -; -; - defb 86h ; getclk - defc 'getclk' - defw setclk-9 -getclk: - defw $+2 - exx ; save ip - ld c,iopreg - ;ldctl hl,(c) ; l <-- current i/o page - DEFB 0EDh,66h - ld a,l - ex af,af' ; save current i/o page - ld l,0feh - ;ldctl (c),hl ; select i/o page 0feh - DEFB 0EDh,6Eh - ld a,80h - out (cntrl1),a ; halt 32bit counter - ld c,count1 - ;inw hl,(c) - DEFB 0EDH,0B7h - ld d,h - ld e,l ; de <-- count1 - ld c,count0 - ;inw hl,(c) ; hl <-- count0 - DEFB 0EDH,0B7h - ld c,0 - ld a,c ; a <-- 0 - sub l ; 0 - l - ld l,a ; l <-- neg(l) - ld a,c ; a <-- 0 - sbc a,h - ld h,a ; h <-- neg(h) - ld a,c ; a <-- 0 - sbc a,e - ld e,a ; e <-- neg(e) - ld a,c ; a <-- 0 - sbc a,d - ld d,a ; d <-- neg(d), dehl <-- neg(dehl) - ;divuw dehl,25000 ; scale to 1/100 secs - DEFB 0FDH - DEFB 0EDH,0FBh - DEFW 25000 - push hl ; result - ex af,af' ; std. accu - ld l,a ; l <-- previous i/o page - ld c,iopreg - ;ldctl (c),hl ; restore i/o page - DEFB 0EDh,6Eh - exx ; restore ip - jnext -; -; - defb 84h ; TASK - defc 'TASK' - defw getclk-9 -; defw dotcpu-7 -task: - defw docol - defw semis -; -; -initdp: - defw 0 -; - end orig - \ No newline at end of file diff --git a/software/CPM/CPM08_Z80FORTH/CONPRTIO.280 b/software/CPM/CPM08_Z80FORTH/CONPRTIO.280 deleted file mode 100644 index b16a957..0000000 --- a/software/CPM/CPM08_Z80FORTH/CONPRTIO.280 +++ /dev/null @@ -1,149 +0,0 @@ -; CP/M CONSOLE & PRINTER INTERFACE -; -; Last update: -; -; 850511 - Saved BC' prior to CP/M calls -; 841010 - Saved IX & IY prior to CP/M calls -; 840909 - Converted all BIOS calls to BDOS calls for compatibility -; with CP/M 3.0 -; -; -; -lstout equ 05h ; printer output -dconio equ 06h ; direct console I/O -; -cacr equ 12h ; cache control register -; -rubout equ 7fh -inpreq equ 0ffh ; dconio input request -; - .z280 -; -eprint: defb 0 ; printer flag - ; 0=disabled, 1=enabled -; -sysent: - push bc - push de - push hl - push ix - push iy - exx - push bc ; save ip (if used as such) - exx - call bdoss ; perform function (C) - exx - pop bc ; restore ip - exx - pop iy - pop ix - pop hl - pop de - pop bc - ret -; -cstat: - push bc - ld c,dconio ; direct console I/O - ld e,inpreq ; input request - call sysent ; any chr typed? - pop bc ; if yes, a <-- char - ret ; else a <-- 00h (ignore chr) -; -; -cin: - push bc - ld c,dconio ; direct console i/o - ld e,inpreq ; request input -cinlp: - call sysent ; a <-- chr (or 0 if nothing typed) - or a - jr z,cinlp ; wait for CHR to be typed - cp rubout - jr nz,cin1 - ld a,bsout ; convert RUB to ^H -cin1: - res 7,a ; msb <-- 0 - pop bc - ret -; -; -cout: - push bc - push de ; save e = chr - ld c,dconio ; direct console output - call sysent ; send e to con: - pop de - pop bc - ret -; -; -pout: - push bc - ld c,lstout - call sysent ; send e to lst: - pop bc - ret -; -; -cpout: - call cout ; send e to console - ld a,(eprint) - or a ; if eprint <> 0 - call nz,pout ;send e to LST: - ret -; -; -; FORTH TO CP/M SERIAL I/O INTERFACE -; -pqter: - call cstat - ld hl,0 - or a ; chr typed? - jr z,pqte1 ; no - inc l ; yes, s1 <-- true -pqte1: - jhpush -; -; -pkey: - call cin ; read chr from console - cp dle ; ^P? - ld e,a - jr nz,pkey1 ; no - ld hl,eprint - ld e,abl ; e <-- blank - ld a,(hl) - xor 01h ; toggle eprint lsb - ld (hl),a -pkey1: - ld l,e - ld h,0 - jhpush ; s1.lb <-- chr -; -; -pemit: - defw $+2 ; (EMIT) orphan - pop de ; e <-- s1.lb = chr - ld a,e - cp bsout - jr nz,pemit1 - call cout ; backspace - ld e,abl ; blank - call cout ; erase chr on con: - ld e,bsout ; backspace -pemit1: - call cpout ; send chr to con: - jnext ; and lst: if eprint = 01h -; -; -pcr: - ld e,acr - call cpout ; output cr - ld e,lf - call cpout ; and lf - jnext -; -; -; - \ No newline at end of file diff --git a/software/CPM/CPM08_Z80FORTH/CONPRTIO.Z80 b/software/CPM/CPM08_Z80FORTH/CONPRTIO.Z80 deleted file mode 100644 index b55b8d6..0000000 --- a/software/CPM/CPM08_Z80FORTH/CONPRTIO.Z80 +++ /dev/null @@ -1,157 +0,0 @@ -; CP/M CONSOLE & PRINTER INTERFACE -; -; Last update: -; -; 850511 - Saved BC' prior to CP/M calls -; 841010 - Saved IX & IY prior to CP/M calls -; 840909 - Converted all BIOS calls to BDOS calls for compatibility -; with CP/M 3.0 -; -; -; -lstout equ 05h ; printer output -dconio equ 06h ; direct console I/O -; -cacr equ 12h ; cache control register -; -rubout equ 7fh -inpreq equ 0ffh ; dconio input request -; - ;.z280 - ; PRE280 V1.11b 20-Nov-90 Copyright (c) 1990 by A.Zinser (fifi@veeble.north.de) - .Z80 -; -eprint: defb 0 ; printer flag - ; 0=disabled, 1=enabled -; -sysent: - push bc - push de - push hl - push ix - push iy - exx - push bc ; save ip (if used as such) - exx - call bdoss ; perform function (C) - exx - pop bc ; restore ip - exx - pop iy - pop ix - pop hl - pop de - pop bc - ret -; -cstat: - push bc - ld c,dconio ; direct console I/O - ld e,inpreq ; input request - call sysent ; any chr typed? - pop bc ; if yes, a <-- char - ret ; else a <-- 00h (ignore chr) -; -; -cin: - push bc - ld c,dconio ; direct console i/o - ld e,inpreq ; request input -cinlp: - call sysent ; a <-- chr (or 0 if nothing typed) - or a - jr z,cinlp ; wait for CHR to be typed - cp rubout - jr nz,cin1 - ld a,bsout ; convert RUB to ^H -cin1: - res 7,a ; msb <-- 0 - pop bc - ret -; -; -cout: - push bc - push de ; save e = chr - ld c,dconio ; direct console output - call sysent ; send e to con: - pop de - pop bc - ret -; -; -pout: - push bc - ld c,lstout - call sysent ; send e to lst: - pop bc - ret -; -; -cpout: - call cout ; send e to console - ld a,(eprint) - or a ; if eprint <> 0 - call nz,pout ;send e to LST: - ret -; -; -; FORTH TO CP/M SERIAL I/O INTERFACE -; -pqter: - call cstat - ld hl,0 - or a ; chr typed? - jr z,pqte1 ; no - inc l ; yes, s1 <-- true -pqte1: - jhpush -; -; -pkey: - call cin ; read chr from console - cp dle ; ^P? - ld e,a - jr nz,pkey1 ; no - ld hl,eprint - ld e,abl ; e <-- blank - ld a,(hl) - xor 01h ; toggle eprint lsb - ld (hl),a -pkey1: - ld l,e - ld h,0 - jhpush ; s1.lb <-- chr -; -; -pemit: - defw $+2 ; (EMIT) orphan - pop de ; e <-- s1.lb = chr - ld a,e - cp bsout - jr nz,pemit1 - call cout ; backspace - ld e,abl ; blank - call cout ; erase chr on con: - ld e,bsout ; backspace -pemit1: - call cpout ; send chr to con: - jnext ; and lst: if eprint = 01h -; -; -pcr: - ld e,acr - call cpout ; output cr - ld e,lf - call cpout ; and lf - jnext -; -; -; -int = 01h -; -; -pcr: - ld e,acr - call cpout ; output cr - \ No newline at end of file diff --git a/software/CPM/CPM08_Z80FORTH/DISCIO.280 b/software/CPM/CPM08_Z80FORTH/DISCIO.280 deleted file mode 100644 index d7613ff..0000000 --- a/software/CPM/CPM08_Z80FORTH/DISCIO.280 +++ /dev/null @@ -1,424 +0,0 @@ -; CP/M DISC INTERFACE -; -; Last update: -; -; 881212 - EXTEND now writes blanks to screens it creates -; 860120 - EXTEND's R/W address now at HERE, was Osborne video ram -; 850511 - saved BC' in 'BDOS' -; 850227 - saved index regs. in 'BDOS' -; 840812 - added EXTEND -; 840731 - installed BDOS calls -; -; -; CP/M BDOS CALLS USED (as per Albert van der Horst, HCCH) -; -; R/W reads or writes a sector in the file specified when invoking -; Z280 fig-FORTH (A>280FORTH d:filename.ext), using the default FCB. -; More than one disc may be accessed by temporary use of a user de- -; fined FCB. -; -; -; -deffcb equ 005ch ; default FCB -; -; CP/M FUNCTIONS -; -opnfil equ 0fh ; open file -clsfil equ 10h ; close file -setdma equ 1ah ; set DMA address -wrtrnd equ 22h ; write random -; -; - .z280 -; -; -; -; FORTH variables & constants used in disc interface -; - defb 83h ; FCB (current FCB address) - defc 'FCB' - defw ptsto-5 -fcb: - defw docon - defw deffcb -; -; - defb 84h ; REC# (returns addr. of random rec.#) - defc 'REC#' - defw fcb-6 -recadr: - defw docol - defw fcb - defw lit - defw 21h - defw plus - defw semis -; -; - defb 83h ; USE - defc 'USE' - defw recadr-7 -use: - defw dovar - defw 0 ;/ initialised by CLD -; -; - defb 84h ; PREV - defc 'PREV' - defw use-6 -prev: - defw dovar - defw 0 ;/ initialised by CLD -; -; - defb 85h ; #BUFF - defc '#BUFF' - defw prev-07h -nobuf: - defw docon - defw nbuf -; -; - defb 8ah ; DISK-ERROR - defc 'DISK-ERROR' - defw nobuf-08h -dskerr: - defw dovar - defw 0 -; -; -; DISC INTERFACE HIGH LEVEL ROUTINES -; - defb 84h ; +BUF - defc '+BUF' - defw dskerr-0dh -pbuf: - defw docol - defw lit,co - defw plus - defw dup - defw limit - defw equal - defw zbran - defw pbuf1-$ - defw drop - defw first -pbuf1: - defw dup - defw prev - defw at - defw subb - defw semis -; -; - defb 86h ; UPDATE - defc 'UPDATE' - defw pbuf-07h -updat: - defw docol - defw prev - defw at - defw at - defw lit - defw 8000h - defw orr - defw prev - defw at - defw store - defw semis -; -; - defb 8dh ; EMPTY-BUFFERS - defc 'EMPTY-BUFFERS' - defw updat-9 -mtbuf: - defw docol - defw first - defw limit - defw over - defw subb - defw erasee - defw semis -; -; - defb 83h ; DR0 - defc 'DR0' - defw mtbuf-10h -drzer: - defw docol - defw zero - defw ofset - defw store - defw semis -; -; - defb 83h ; DR1 - defc 'DR1' - defw drzer-6 -drone: - defw docol - defw lit - defw 1600 ; Osborne DD -dron2: - defw ofset - defw store - defw semis -; -; - defb 86h ; BUFFER - defc 'BUFFER' - defw drone-6 -buffe: - defw docol - defw use - defw at - defw dup - defw tor -buff1: - defw pbuf ; won't work if single buffer - defw zbran - defw buff1-$ - defw use - defw store - defw rr - defw at - defw zless - defw zbran - defw buff2-$ - defw rr - defw twop - defw rr - defw at - defw lit - defw 7fffh - defw andd - defw zero - defw rslw -buff2: - defw rr - defw store - defw rr - defw prev - defw store - defw fromr - defw twop - defw semis -; -; - defb 85h ; BLOCK - defc 'BLOCK' - defw buffe-9 -block: - defw docol - defw ofset - defw at - defw plus - defw tor - defw prev - defw at - defw dup - defw at - defw rr - defw subb - defw dup - defw plus - defw zbran - defw bloc1-$ -bloc2: - defw pbuf - defw zequ - defw zbran - defw bloc3-$ - defw drop - defw rr - defw buffe - defw dup - defw rr - defw one - defw rslw - defw twomin ;/ -bloc3: - defw dup - defw at - defw rr - defw subb - defw dup - defw plus - defw zequ - defw zbran - defw bloc2-$ - defw dup - defw prev - defw store -BLOC1: - defw fromr - defw drop - defw twop - defw semis -; -; - defb 84h ; BDOS (CP/M function call) - defc 'BDOS' - defw block-8 -bdos: - defw $+2 - exx ;/ save ip - pop bc ; c <-- s1.lb = BDOS function code - pop de ; de <-- s2) = parameter - push ix - push iy - exx - push bc ; some BIOS use alternate registers - exx - call bdoss ; return value in a - exx - pop bc ;/ bc <-- ip - pop iy - pop ix - ld l,a - ld h,00h - jhpush ; s1 <-- hl = returned value -; -; - defb 83h ; R/W - defc 'R/W' - defw bdos-07h -rslw: - defw docol - defw tor ; store R/W flag - defw recadr - defw store - defw zero - defw recadr ; set record # - defw twop - defw cstor - defw lit - defw setdma - defw bdos - defw drop ; set DMA address - defw lit - defw wrtrnd - defw fromr - defw subb ; select READ or WRITE - defw fcb - defw swap - defw bdos ; do it - defw dskerr - defw store ; store return code - defw semis -; -; - defb 85h ; FLUSH - defc 'FLUSH' - defw rslw-6 -flush: - defw docol - defw nobuf - defw onep - defw zero - defw xdo -flus1: - defw zero - defw buffe - defw drop - defw xloop - defw flus1-$ - defw semis -; -; - defb 86h ;/ EXTEND - defc 'EXTEND' ;/ - defw flush-08h ;/ -extend: - defw docol ;/ - defw here ;/ fill with b/buf blanks - defw bbuf - defw blank - defw lit ;/ - defw 0008h ;/ - defw star ;/ - defw zero ;/ -extnd1: - defw onep ;/ begin - defw here ;/ was lit,f000h (Osborne video ram) - defw over ;/ - defw one ;/ - defw rslw ;/ - defw dskerr ;/ - defw at ;/ - defw zbran ;/ - defw extnd1-$ ;/ until - defw swap ;/ - defw over ;/ - defw plus ;/ - defw swap ;/ - defw xdo ;/ do -extnd2: - defw here ;/ was lit,f000h (Osborne video ram) - defw ido ;/ - defw zero ;/ - defw rslw ;/ - defw xloop ;/ - defw extnd2-$ ;/ loop - defw fcb ;/ - defw lit ;/ - defw clsfil ;/ - defw bdos ;/ close file - defw drop ;/ - defw fcb ;/ - defw lit ;/ - defw opnfil ;/ - defw bdos ;/ & re-open - defw drop ;/ - defw semis ;/ -; -; - defb 84h ; LOAD - defc 'LOAD' - defw extend-09h -load: - defw docol - defw blk - defw at - defw tor - defw inn - defw at - defw tor - defw zero - defw inn - defw store - defw bscr - defw star - defw blk - defw store ; BLK <-- SCR * B/SCR - defw inter ; interpret from other screen - defw fromr - defw inn - defw store - defw fromr - defw blk - defw store - defw semis -; -; - defb 0c3h ; --> - defc '-->' - defw load-7 -arrow: - defw docol - defw qload - defw zero - defw inn - defw store - defw bscr - defw blk - defw at - defw over - defw modd - defw subb - defw blk - defw pstor - defw semis -; -; - \ No newline at end of file diff --git a/software/CPM/CPM08_Z80FORTH/DISCIO.Z80 b/software/CPM/CPM08_Z80FORTH/DISCIO.Z80 deleted file mode 100644 index d42b8e1..0000000 --- a/software/CPM/CPM08_Z80FORTH/DISCIO.Z80 +++ /dev/null @@ -1,429 +0,0 @@ -; CP/M DISC INTERFACE -; -; Last update: -; -; 881212 - EXTEND now writes blanks to screens it creates -; 860120 - EXTEND's R/W address now at HERE, was Osborne video ram -; 850511 - saved BC' in 'BDOS' -; 850227 - saved index regs. in 'BDOS' -; 840812 - added EXTEND -; 840731 - installed BDOS calls -; -; -; CP/M BDOS CALLS USED (as per Albert van der Horst, HCCH) -; -; R/W reads or writes a sector in the file specified when invoking -; Z280 fig-FORTH (A>280FORTH d:filename.ext), using the default FCB. -; More than one disc may be accessed by temporary use of a user de- -; fined FCB. -; -; -; -deffcb equ 005ch ; default FCB -; -; CP/M FUNCTIONS -; -opnfil equ 0fh ; open file -clsfil equ 10h ; close file -setdma equ 1ah ; set DMA address -wrtrnd equ 22h ; write random -; -; - ;.z280 - ; PRE280 V1.11b 20-Nov-90 Copyright (c) 1990 by A.Zinser (fifi@veeble.north.de) - .Z80 -; -; -; -; FORTH variables & constants used in disc interface -; - defb 83h ; FCB (current FCB address) - defc 'FCB' - defw ptsto-5 -fcb: - defw docon - defw deffcb -; -; - defb 84h ; REC# (returns addr. of random rec.#) - defc 'REC#' - defw fcb-6 -recadr: - defw docol - defw fcb - defw lit - defw 21h - defw plus - defw semis -; -; - defb 83h ; USE - defc 'USE' - defw recadr-7 -use: - defw dovar - defw 0 ;/ initialised by CLD -; -; - defb 84h ; PREV - defc 'PREV' - defw use-6 -prev: - defw dovar - defw 0 ;/ initialised by CLD -; -; - defb 85h ; #BUFF - defc '#BUFF' - defw prev-07h -nobuf: - defw docon - defw nbuf -; -; - defb 8ah ; DISK-ERROR - defc 'DISK-ERROR' - defw nobuf-08h -dskerr: - defw dovar - defw 0 -; -; -; DISC INTERFACE HIGH LEVEL ROUTINES -; - defb 84h ; +BUF - defc '+BUF' - defw dskerr-0dh -pbuf: - defw docol - defw lit,co - defw plus - defw dup - defw limit - defw equal - defw zbran - defw pbuf1-$ - defw drop - defw first -pbuf1: - defw dup - defw prev - defw at - defw subb - defw semis -; -; - defb 86h ; UPDATE - defc 'UPDATE' - defw pbuf-07h -updat: - defw docol - defw prev - defw at - defw at - defw lit - defw 8000h - defw orr - defw prev - defw at - defw store - defw semis -; -; - defb 8dh ; EMPTY-BUFFERS - defc 'EMPTY-BUFFERS' - defw updat-9 -mtbuf: - defw docol - defw first - defw limit - defw over - defw subb - defw erasee - defw semis -; -; - defb 83h ; DR0 - defc 'DR0' - defw mtbuf-10h -drzer: - defw docol - defw zero - defw ofset - defw store - defw semis -; -; - defb 83h ; DR1 - defc 'DR1' - defw drzer-6 -drone: - defw docol - defw lit - defw 1600 ; Osborne DD -dron2: - defw ofset - defw store - defw semis -; -; - defb 86h ; BUFFER - defc 'BUFFER' - defw drone-6 -buffe: - defw docol - defw use - defw at - defw dup - defw tor -buff1: - defw pbuf ; won't work if single buffer - defw zbran - defw buff1-$ - defw use - defw store - defw rr - defw at - defw zless - defw zbran - defw buff2-$ - defw rr - defw twop - defw rr - defw at - defw lit - defw 7fffh - defw andd - defw zero - defw rslw -buff2: - defw rr - defw store - defw rr - defw prev - defw store - defw fromr - defw twop - defw semis -; -; - defb 85h ; BLOCK - defc 'BLOCK' - defw buffe-9 -block: - defw docol - defw ofset - defw at - defw plus - defw tor - defw prev - defw at - defw dup - defw at - defw rr - defw subb - defw dup - defw plus - defw zbran - defw bloc1-$ -bloc2: - defw pbuf - defw zequ - defw zbran - defw bloc3-$ - defw drop - defw rr - defw buffe - defw dup - defw rr - defw one - defw rslw - defw twomin ;/ -bloc3: - defw dup - defw at - defw rr - defw subb - defw dup - defw plus - defw zequ - defw zbran - defw bloc2-$ - defw dup - defw prev - defw store -BLOC1: - defw fromr - defw drop - defw twop - defw semis -; -; - defb 84h ; BDOS (CP/M function call) - defc 'BDOS' - defw block-8 -bdos: - defw $+2 - exx ;/ save ip - pop bc ; c <-- s1.lb = BDOS function code - pop de ; de <-- s2) = parameter - push ix - push iy - exx - push bc ; some BIOS use alternate registers - exx - call bdoss ; return value in a - exx - pop bc ;/ bc <-- ip - pop iy - pop ix - ld l,a - ld h,00h - jhpush ; s1 <-- hl = returned value -; -; - defb 83h ; R/W - defc 'R/W' - defw bdos-07h -rslw: - defw docol - defw tor ; store R/W flag - defw recadr - defw store - defw zero - defw recadr ; set record # - defw twop - defw cstor - defw lit - defw setdma - defw bdos - defw drop ; set DMA address - defw lit - defw wrtrnd - defw fromr - defw subb ; select READ or WRITE - defw fcb - defw swap - defw bdos ; do it - defw dskerr - defw store ; store return code - defw semis -; -; - defb 85h ; FLUSH - defc 'FLUSH' - defw rslw-6 -flush: - defw docol - defw nobuf - defw onep - defw zero - defw xdo -flus1: - defw zero - defw buffe - defw drop - defw xloop - defw flus1-$ - defw semis -; -; - defb 86h ;/ EXTEND - defc 'EXTEND' ;/ - defw flush-08h ;/ -extend: - defw docol ;/ - defw here ;/ fill with b/buf blanks - defw bbuf - defw blank - defw lit ;/ - defw 0008h ;/ - defw star ;/ - defw zero ;/ -extnd1: - defw onep ;/ begin - defw here ;/ was lit,f000h (Osborne video ram) - defw over ;/ - defw one ;/ - defw rslw ;/ - defw dskerr ;/ - defw at ;/ - defw zbran ;/ - defw extnd1-$ ;/ until - defw swap ;/ - defw over ;/ - defw plus ;/ - defw swap ;/ - defw xdo ;/ do -extnd2: - defw here ;/ was lit,f000h (Osborne video ram) - defw ido ;/ - defw zero ;/ - defw rslw ;/ - defw xloop ;/ - defw extnd2-$ ;/ loop - defw fcb ;/ - defw lit ;/ - defw clsfil ;/ - defw bdos ;/ close file - defw drop ;/ - defw fcb ;/ - defw lit ;/ - defw opnfil ;/ - defw bdos ;/ & re-open - defw drop ;/ - defw semis ;/ -; -; - defb 84h ; LOAD - defc 'LOAD' - defw extend-09h -load: - defw docol - defw blk - defw at - defw tor - defw inn - defw at - defw tor - defw zero - defw inn - defw store - defw bscr - defw star - defw blk - defw store ; BLK <-- SCR * B/SCR - defw inter ; interpret from other screen - defw fromr - defw inn - defw store - defw fromr - defw blk - defw store - defw semis -; -; - defb 0c3h ; --> - defc '-->' - defw load-7 -arrow: - defw docol - defw qload - defw zero - defw inn - defw store - defw bscr - defw blk - defw at - defw over - defw modd - defw subb - defw blk - defw pstor - defw semis -; -; - - defw blk - defw at - def \ No newline at end of file diff --git a/software/CPM/CPM08_Z80FORTH/EDITOR.DOC b/software/CPM/CPM08_Z80FORTH/EDITOR.DOC deleted file mode 100644 index f09d0d8..0000000 --- a/software/CPM/CPM08_Z80FORTH/EDITOR.DOC +++ /dev/null @@ -1,71 +0,0 @@ - Z80 fig-FORTH Line Editor Commands - ---------------------------------- - - -B Back cursor to the beginning of the string in the PAD. - -C Spread text at cursor to insert the following string. Characters - pushed off the end of the line are lost. - -D n --- - Delete the nth line and move subsequent lines 1 up. The deleted - line is held in the PAD. - -E n --- - Erase the nth line by filling it with 64 blanks. - -F Find the first occurrence of the following text string. - -H n --- - Copy the nth line to the PAD and hold it there. - -I n --- - Insert text from PAD into line n. Shift the original nth and sub- - sequent lines down 1 line. The original line 15 is lost. - -L Re-list the screen being edited. - -M n --- - Move cursor n characters. - -N Find the next occurence of the text already in the PAD. - -P n --- - Put the following text on line n. Write over its old contents. - -R n --- - Replace the nth line with the text stored in the PAD. - -S n --- - Spread line n with blanks. Shift the original line n and subse- - quent lines down 1 line. The original line 15 is lost. - -T n --- - Type line n of the current screen and copy it to the PAD. - -X Delete the following text from the current line. - -CLEAR n --- - Clear screen n by filling it with blanks and make it current. - -COPY n1 n2 --- - Copy screen n1 to screen n2. - -DELETE n --- - Delete n characters in front of the cursor. Move the text from the - end of the line to fill up the space. Fill with blanks at the end - of the line. - -FIND Search the entire screen for the string stored in the PAD and move - the cursor to the end of the string. Issue an error message if the - search failed. - -TILL Delete all characters from the cursor location up to the end of - the following text string. - -TOP Move the cursor to the leftmost position at line 0. - -TS Type Screen. Useful for finding hidden NULL characters which would - prematurely end compilation. If line numbers at the right don't - line up, retype the line or use E command if line is empty. - \ No newline at end of file diff --git a/software/CPM/CPM08_Z80FORTH/PIP.COM b/software/CPM/CPM08_Z80FORTH/PIP.COM deleted file mode 100644 index a8a17e1..0000000 Binary files a/software/CPM/CPM08_Z80FORTH/PIP.COM and /dev/null differ diff --git a/software/CPM/CPM08_Z80FORTH/SCREENS.FRT b/software/CPM/CPM08_Z80FORTH/SCREENS.FRT deleted file mode 100644 index 6d56c67..0000000 Binary files a/software/CPM/CPM08_Z80FORTH/SCREENS.FRT and /dev/null differ diff --git a/software/CPM/CPM08_Z80FORTH/SETGETCL.280 b/software/CPM/CPM08_Z80FORTH/SETGETCL.280 deleted file mode 100644 index 486f91b..0000000 --- a/software/CPM/CPM08_Z80FORTH/SETGETCL.280 +++ /dev/null @@ -1,79 +0,0 @@ - defb 86h ; setclk - defc 'setclk' - defw dotcpu-7 -setclk: - defw $+2 - exx ; save ip - ld c,iopreg - ldctl hl,(c) ; l <-- current i/o page - ld a,l - ex af,af' ; save i/o page - ld l,0feh - ldctl (c),hl ; select i/o page 0feh - xor a - out (cntrl0),a ; disable c/t 0 - out (cntrl1),a ; disable c/t 1 - out (config1),a - ld hl,0ffffh - ld a,10h - out (config0),a ; cascade c/t 0 - c/t 1 - ld c,tcon0 - outw (c),hl ; load c/t 0 time constant - ld c,tcon1 - outw (c),hl ; load c/t 1 time constatnt - ld a,80h - out (config1),a ; continous mode - ld a,0e0h - out (cntrl1),a ; start 32bit counter - ex af,af' ; std. accu - ld l,a ; l <-- previous i/o page - ld c,iopreg - ldctl (c),hl ; restore i/o page - exx ; restore ip - jnext -; -; - defb 86h ; getclk - defc 'getclk' - defw setclk-9 -getclk: - defw $+2 - exx ; save ip - ld c,iopreg - ldctl hl,(c) ; l <-- current i/o page - ld a,l - ex af,af' ; save current i/o page - ld l,0feh - ldctl (c),hl ; select i/o page 0feh - ld a,80h - out (cntrl1),a ; halt 32bit counter - ld c,count1 - inw hl,(c) - ld d,h - ld e,l ; de <-- count1 - ld c,count0 - inw hl,(c) ; hl <-- count0 - ld c,0 - ld a,c ; a <-- 0 - sub l ; 0 - l - ld l,a ; l <-- neg(l) - ld a,c ; a <-- 0 - sbc a,h - ld h,a ; h <-- neg(h) - ld a,c ; a <-- 0 - sbc a,e - ld e,a ; e <-- neg(e) - ld a,c ; a <-- 0 - sbc a,d - ld d,a ; d <-- neg(d), dehl <-- neg(dehl) - divuw dehl,25000 ; scale to 1/100 secs - push hl ; result - ex af,af' ; std. accu - ld l,a ; l <-- previous i/o page - ld c,iopreg - ldctl (c),hl ; restore i/o page - exx ; restore ip - jnext -; -; - \ No newline at end of file diff --git a/software/CPM/CPM08_Z80FORTH/STARTUP.FRT b/software/CPM/CPM08_Z80FORTH/STARTUP.FRT deleted file mode 100644 index 213274b..0000000 --- a/software/CPM/CPM08_Z80FORTH/STARTUP.FRT +++ /dev/null @@ -1 +0,0 @@ - 10 0 DO DUP I + C@ B. *************** fig FORTH MODEL *********************** FORTH INTEREST GROUP P.O. BOX 1105 SAN CARLOS, CA. 94070 RELEASE 1.1F FOR CP/M WITH COMPILER SECURITY AND VARIABLE LENGTH NAMES ADAPTED TO CP/M 2.2 SCREENS ALLOCATED IN RANDOM ACCESS FILE HEX : HOME 1A EMIT ; 0 VARIABLE I-STATE : A-L SCR @ (LINE) ; ( 1/2 ADDRESS OF LINE) : GET-L A-L F000 SWAP CMOVE ; ( /0 MOVE LINE TO SCREEN) : PUT-L A-L F000 ROT ROT CMOVE ; ( /0 MOVE LINE FR SCREEN) : DISPATCH ( 1/0 EXECUTE CONTROL CHARACTER) ( ^D) DUP 4 = IF 1B EMIT 57 EMIT DROP ELSE ( ^I) DUP 9 = IF I-STATE 1 TOGGLE DROP ELSE ( ^X) DUP 18 = IF 1B EMIT 45 EMIT DROP ELSE ( ^Y) DUP 19 = IF 1B EMIT 52 EMIT DROP ELSE ( ^Q) DUP 11 = IF ." ABORTED" QUIT ELSE EMIT THEN THEN THEN THEN THEN ; : EMIT1 I-STATE @ IF 1B EMIT 51 EMIT THEN EMIT ; ( 1/0) : XX BEGIN KEY DUP DUP 20 < IF DISPATCH ELSE EMIT1 THEN ( ^E) 5 = UNTIL ; : E-L HOME DUP GET-L XX A EMIT PUT-L UPDATE ; : C-L SWAP A-L DROP SWAP A-L CMOVE ; --> : GET-S 10 0 DO I A-L F000 I 80 * + SWAP CMOVE LOOP ; : PUT-S 10 0 DO F000 I 80 * + I A-L UPDATE CMOVE LOOP ; : CLEAN F800 F000 DO I C@ 7F AND I C! LOOP ; : E-S 0 I-STATE ! HOME GET-S XX CLEAN PUT-S HOME ; : EDIT SCR ! E-S ; ( EXTENDING THE SPACE ALLOCATED ) : LAST-SEC ( 0/1 LEAVES ONE MORE THAN THE LAST BLOCK NR) 0 BEGIN 1+ F000 OVER 1 R/W DISK-ERROR @ UNTIL ; : EXTEND ( 1/0 EXTENDS # BLOCKS WITH NUMBER-1 ) 8 * LAST-SEC HOME ( GET AMOUNT OF BLOCKS) SWAP OVER + SWAP DO F000 I 0 R/W LOOP FCB 10 BDOS DROP ( CLOSE THE FILE,I.E. UPDATE DIRECTORY) FCB 0F BDOS DROP ( OPEN AGAIN ) ; ( SCR # 3) : COPY-SCREEN ( 2/0 COPY SCREEN-2 TO SCREEN-1 ) B/SCR * SWAP B/SCR * SWAP ( GET START BUFFER #'S) B/SCR 0 DO DUP I + BUFFER DROP LOOP ( RESERVE BUFFERS) B/SCR 0 DO OVER I + BLOCK OVER I + BLOCK B/BUF CMOVE UPDATE LOOP DROP DROP FLUSH ; ( ERROR MESSAGES ) MSG # 1 : EMPTY STACK MSG # 2 : DICTIONARY FULL MSG # 3 : HAS INCORRECT ADDRESS MODE MSG # 4 : ISN'T UNIQUE MSG # 6 : DISK RANGE ? MSG # 7 : FULL STACK MSG # 8 : DISC ERROR ! ( FIGFORTH CP/M 2.2 ** HOBBY COMPUTER CLUB HOLLAND **) ( ERROR MESSAGES ) MSG # 17 : COMPILATION ONLY, USE IN DEFINITION MSG # 18 : EXECUTION ONLY MSG # 19 : CONDITIONALS NOT PAIRED MSG # 20 : DEFINITION NOT FINISHED MSG # 21 : IN PROTECTED DICTIONARY MSG # 22 : USE ONLY WHEN LOADING MSG # 23 : OFF CURRENT EDITING SCREEN MSG # 24 : DECLARE VOCABULARY ( DEBUG SCR#6) 0 VARIABLE BASE' : BASE' @ BASE ! ; ( 1/0 AND BACK) ( 1/0 PRINT IN HEX REGARDLESS OF BASE) : H. TYPE SPACE HEX> ; ( 1/0 IDEM FOR A SINGLE BYTE) : B. TYPE HEX> ; : BASE? BASE @ H. ; ( 0/0 TRUE VALUE OF BASE) : ^ ( 0/0 NON DESTRUCTIVE STACK PRINT) CR ." S: " SP@ S0 @ ( FIND LIMITS) BEGIN OVER OVER = 0= WHILE 2 - DUP @ H. REPEAT DROP DROP ; --> - db 0f3h - else - db 0edh,77h,m & 7fh - endif -endm -; --------------------------------------------------------------------------- * -ei macro m - ifb - db 0fbh - else - db 0edh,7fh,m & 7fh - endif -endm -; --------------------------------------------------------------------------- * -exts macro r - ifidn , - dw 64edh - exitm - endif - ifidn , - dw 6cedh - exitm - endif -endm -; --------------------------------------------------------------------------- * -im macro p - ifidn

,<0> - dw 46edh - exitm - endif - ifidn

,<1> - dw 56edh - exitm - endif - ifidn

,<2> - dw 5eedh - exitm - endif - ifidn

,<3> - dw 4eedh - exitm - endif -endm -; --------------------------------------------------------------------------- * -inw macro d,s -ifidn , - ifidn ,<(c)> - dw 0b7edh - endif -endif -endm -; --------------------------------------------------------------------------- * -ldctl macro d,s -ifidn ,<(c)> - ifidn , - dw 6eedh ;; ldctl (c),hl - exitm - endif - ifidn , - db 0ddh,0edh,6eh ;; ldctl (c),ix - exitm - endif - ifidn , - db 0fdh,0edh,6eh ;; ldctl (c),iy - exitm - endif -endif -ifidn ,<(c)> - ifidn , - dw 66edh ;; ldctl hl,(c) - exitm - endif - ifidn , - db 0ddh,0edh,66h ;; ldctl ix,(c) - exitm - endif - ifidn , - db 0fdh,0edh,66h ;; ldctl iy,(c) - exitm - endif -endif -ifidn , - ifidn , - dw 87edh ;; ldctl hl,usp - exitm - endif - ifidn , - db 0ddh,0edh,87h ;; ldctl ix,usp - exitm - endif - ifidn , - db 0fdh,0edh,87h ;; ldctl iy,usp - exitm - endif -endif -ifidn , - ifidn , - dw 8fedh ;; ldctl usp,hl - exitm - endif - ifidn , - db 0ddh,0edh,8fh ;; ldctl usp,ix - exitm - endif - ifidn , - db 0fdh,0edh,8fh ;; ldctl usp,iy - exitm - endif -endif -endm - -; --------------------------------------------------------------------------- * -neg macro r - ifidn , - dw 44edh - exitm - endif - ifidn , - dw 4cedh - exitm - endif -endm -; --------------------------------------------------------------------------- * -outw macro d,s -ifidn ,<(c)> - ifidn , - dw 0bfedh ;; outw (c),hl - endif -endif -endm -; --------------------------------------------------------------------------- * -pcache macro - dw 65edh -endm -; --------------------------------------------------------------------------- * -retil macro - dw 55edh -endm -; --------------------------------------------------------------------------- * -sc macro n - dw 71edh,n -endm -; --------------------------------------------------------------------------- * - .list - \ No newline at end of file diff --git a/software/CPM/CPM09_CPMTEX/TEX.COM b/software/CPM/CPM09_CPMTEX/TEX.COM deleted file mode 100644 index c61539c..0000000 Binary files a/software/CPM/CPM09_CPMTEX/TEX.COM and /dev/null differ diff --git a/software/CPM/CPM09_CPMTEX/TEXP.COM b/software/CPM/CPM09_CPMTEX/TEXP.COM deleted file mode 100644 index 48a84ec..0000000 Binary files a/software/CPM/CPM09_CPMTEX/TEXP.COM and /dev/null differ diff --git a/software/CPM/CPM09_CPMTEX/TEXPAT1.ASM b/software/CPM/CPM09_CPMTEX/TEXPAT1.ASM deleted file mode 100644 index 54bfc3d..0000000 --- a/software/CPM/CPM09_CPMTEX/TEXPAT1.ASM +++ /dev/null @@ -1,33 +0,0 @@ - ;TEX PATCH #1: 27 JUN 78 - - ;THIS PATCH CORRECTS AN ERROR WHICH OCCURS DURING - ;".NA" MODE WHERE A WORD IS DUPLICATED WHEN THE - ;OUTPUT LINE IS EQUAL TO THE LINE LENGTH. - - ;PATCH FOLLOWS: - -PATCH EQU 1D43H -L606 EQU 0DABH -TLINE EQU 1DE5H -WLINE EQU 1DE6H -ELINE EQU 1DE8H -NLINE EQU 1DEAH - -ORG L606 - - JMP PATCH - -RETPAT: - -ORG PATCH - - STA TLINE - LDA WLINE - LXI H,ELINE - CMP M - JP RETPAT - LDA NLINE - STA WLINE - JMP RETPAT -END - \ No newline at end of file diff --git a/software/CPM/CPM09_CPMTEX/TEXPAT1.HEX b/software/CPM/CPM09_CPMTEX/TEXPAT1.HEX deleted file mode 100644 index 99da4b7..0000000 --- a/software/CPM/CPM09_CPMTEX/TEXPAT1.HEX +++ /dev/null @@ -1,5 +0,0 @@ -:030DAB00C3431D22 -:101D430032E51D3AE61D21E81DBEF2AE0D3AEA1D4D -:061D530032E61DC3AE0DD7 -:0000000000 - \ No newline at end of file diff --git a/software/CPM/CPM09_CPMTEX/TEXPAT1.PRN b/software/CPM/CPM09_CPMTEX/TEXPAT1.PRN deleted file mode 100644 index b8cd4a8..0000000 --- a/software/CPM/CPM09_CPMTEX/TEXPAT1.PRN +++ /dev/null @@ -1,35 +0,0 @@ - - - ;TEX PATCH #1: 27 JUN 78 - - ;THIS PATCH CORRECTS AN ERROR WHICH OCCURS DURING - ;".NA" MODE WHERE A WORD IS DUPLICATED WHEN THE - ;OUTPUT LINE IS EQUAL TO THE LINE LENGTH. - - ;PATCH FOLLOWS: - - 1D43 = PATCH EQU 1D43H - 0DAB = L606 EQU 0DABH - 1DE5 = TLINE EQU 1DE5H - 1DE6 = WLINE EQU 1DE6H - 1DE8 = ELINE EQU 1DE8H - 1DEA = NLINE EQU 1DEAH - - 0DAB ORG L606 - - 0DAB C3431D JMP PATCH - - RETPAT: - - 1D43 ORG PATCH - - 1D43 32E51D STA TLINE - 1D46 3AE61D LDA WLINE - 1D49 21E81D LXI H,ELINE - 1D4C BE CMP M - 1D4D F2AE0D JP RETPAT - 1D50 3AEA1D LDA NLINE - 1D53 32E61D STA WLINE - 1D56 C3AE0D JMP RETPAT - 1D59 END - \ No newline at end of file diff --git a/software/CPM/CPM09_CPMTEX/TEXPAT2.ASM b/software/CPM/CPM09_CPMTEX/TEXPAT2.ASM deleted file mode 100644 index 49bd230..0000000 --- a/software/CPM/CPM09_CPMTEX/TEXPAT2.ASM +++ /dev/null @@ -1,28 +0,0 @@ - ;TEX PATCH #2, 28 JUN 78 - ;THIS PATCH CORRECTS AN ERROR WHICH OCCURS WHEN - ;THE $F FORM FEED OPTION IS USED. - ;IN PARTICULAR, THIS PATCH CAUSES A FORM FEED - ;ON THE FIRST PAGE, WHICH WAS NOT PREVIOUSLY DONE. - -PATCH EQU 1D59H -L445 EQU 0980H -SAV$LINELENGTH EQU 1F11H -FORM$FEED EQU 1F0CH -PUTDEST EQU 0672H -FF EQU 0CH - - ORG L445 - JMP PATCH - -RETPAT: - - ORG PATCH - STA SAV$LINELENGTH - LDA FORM$FEED - RAL - MVI C,FF - CC PUTDEST - JMP RETPAT - END - - \ No newline at end of file diff --git a/software/CPM/CPM09_CPMTEX/TEXPAT2.HEX b/software/CPM/CPM09_CPMTEX/TEXPAT2.HEX deleted file mode 100644 index c31cdf6..0000000 --- a/software/CPM/CPM09_CPMTEX/TEXPAT2.HEX +++ /dev/null @@ -1,4 +0,0 @@ -:03098000C3591D3B -:0F1D590032111F3A0C1F170E0CDC7206C38309E0 -:0000000000 - \ No newline at end of file diff --git a/software/CPM/CPM09_CPMTEX/TEXPAT2.PRN b/software/CPM/CPM09_CPMTEX/TEXPAT2.PRN deleted file mode 100644 index 6f3aa7b..0000000 --- a/software/CPM/CPM09_CPMTEX/TEXPAT2.PRN +++ /dev/null @@ -1,29 +0,0 @@ - - - ;TEX PATCH #2, 28 JUN 78 - ;THIS PATCH CORRECTS AN ERROR WHICH OCCURS WHEN - ;THE $F FORM FEED OPTION IS USED. - ;IN PARTICULAR, THIS PATCH CAUSES A FORM FEED - ;ON THE FIRST PAGE, WHICH WAS NOT PREVIOUSLY DONE. - - 1D59 = PATCH EQU 1D59H - 0980 = L445 EQU 0980H - 1F11 = SAV$LINELENGTH EQU 1F11H - 1F0C = FORM$FEED EQU 1F0CH - 0672 = PUTDEST EQU 0672H - 000C = FF EQU 0CH - - 0980 ORG L445 - 0980 C3591D JMP PATCH - - RETPAT: - - 1D59 ORG PATCH - 1D59 32111F STA SAV$LINELENGTH - 1D5C 3A0C1F LDA FORM$FEED - 1D5F 17 RAL - 1D60 0E0C MVI C,FF - 1D62 DC7206 CC PUTDEST - 1D65 C38309 JMP RETPAT - 1D68 END - \ No newline at end of file diff --git a/software/CPM/CPM10_DISKUTILFUNC5/DUF05.ASM b/software/CPM/CPM10_DISKUTILFUNC5/DUF05.ASM deleted file mode 100644 index 42c94ff..0000000 --- a/software/CPM/CPM10_DISKUTILFUNC5/DUF05.ASM +++ /dev/null @@ -1,3244 +0,0 @@ - -;******************************************************** -;* DUF05.ASM * -;* DISK UTILITY FUNCTIONS * -;* USED FOR CP/M & MP/M * -;* BRUCE JONES 01/13/83 * -;******************************************************** - - - -; .I8080 ;JUST 8080 CODE - - .PABS - .PHEX - .XLINK - .XSYM - .LOC 100H - - TRUE == 0FFFFH - FALSE == #TRUE - -;USE TDL OR CDL ZASM TO ASSEMBLE - -;******************************************************** -; CP/M INTERFACE FUNCTIONS -;******************************************************** - - SRESET == 0 ;RESET DISK SYSTEM - GETCON == 1 ;GET CONSOLE - PRTCON == 2 ;OUTPUT CONSOLE - LIST == 5 ;LIST OUTPUT - PRINTS == 9 ;PRINT STRING - GETBUF == 10 ;GET CONSOLE BUFFER - CONST == 11 ;GET CONSOLE STATUS - GETVER == 12 ;GET VERSION NUMBER - DSKRST == 13 ;RESET DISK SYSTEM - SLDISK == 14 ;SELECT DISK - OPENF == 15 ;OPEN FILE - CLOSEF == 16 ;CLOSE FILE - SEARCH == 17 ;SEARCH FOR MATCH - SRHNXT == 18 ;SEARCH FOR NEXT - DELETE == 19 ;DELETE FILE - READF == 20 ;READ FILE - WRITEF == 21 ;WRITE FILE - MAKEF == 22 ;MAKE FILE - RENAME == 23 ;RENAME FILE - RETLOG == 24 ;RETURN LOGIN VECTOR - RETDSK == 25 ;RETURN CURRENT DISK - DMAF == 26 ;SET DMA ADDRESS - GETADD == 27 ;GET ALLOCATION VECTOR ADDRESS - WRTPRO == 28 ;WRITE PROTECT DISK - SETATT == 30 ;SET FILE ATTRIBUTES - GETDPB == 31 ;GET ADDRESS OF DPB FOR DISK - SETUSR == 32 ;GET/SET USER CODE - RESET == 37 ;RESET DRIVES FOR NEW DISK - - BDOS == 5 ;BDOS ENTRY - - -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; CONSOLE CHARS -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - BELL == 7 ;BELL - TAB == 9 ;TAB OVER 8 CHARS - CR == 0DH ;CARRIAGE RETURN - LF == 0AH ;LINE FEED - CLEAR == 1AH ;CLEAR SCREEN - -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; PRINTER CHARS -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - FF == 0CH ;FORM FEED - - EOL == '$' ;CP/M END OF LINE MARKER - TMPBUF == 80H ;DEFAULT DMA BUFFER - - -;========== ASSEMBLY TIME SWITCHES ============= - - -;PROTCT IS USED FOR INITIAL TESTING OF DUF -;IF == 0, PROTECTION IS ENABLED AND THE PROGRAM -;HALTS ON ANY SERIOUS DISK ERROR TO PREVENT -;SECTOR MODIFICATION - -PROTCT =\ \ENTER 0 FOR PROTECTION, 1 IF NOT \ - -;ROMER IS USED TO RUN ONLY FOR THE ZEUS80 CPU BOARD -;IF == 0, A CHECK IS MADE FOR A VALID ROM - -;*********** NOTE *********** -;FOR GENERAL CP/M SYSTEM USE SET PROTCT & ROMER TO "1" - - -ROMER =\ \ENTER 0 FOR ROM TEST, 1 IF NOT \ - -;******************************************************** -; STARTUP. MAKE LOCAL BIOS TABLE & RESET PRINTER ECHO -;******************************************************** - -START: - LXI SP,STACK ;PUT HERE - - -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; TEST FOR CP/M OR MP/M -; IF MP/M GET CONTROL OF DISK QUEUE -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - -; SEE IF CP/M OR MP/M NEXT -; IF MP/M GET CONTROL OF MXDisk QUEUE - - - MVI C,12 ;GET VERSION NUMBER - CALL BDOS - MOV A,H ;SEE IF CP/M OR MP/M - STA VERFLG ;SAVE FOR EXIT - JZ CPM ;IF 0 THEN ITS' CP/M - - MVI A,0FFH - STA DSKQ ;SET MXDISK FLAG AS TRUE - - MVI C,9CH ;GET PROCESS DESC. ADDRESS - CALL BDOS - LXI D,6 ;ADD NAME OFFSET - DAD D ;POINT HL TO IT - MOV A,M ;GET 1st BYTE - ANI 7FH ;STRIP BIT 7 - MOV M,A ;PUT BACK IN DESC. NAME - - - MVI C,135 ;OPEN QUEUE - LXI D,UMXDSK - CALL BDOS - - - - MVI C,137 ;READ QUEUE - LXI D,UMXDSK;FOR MXDisk - CALL BDOS - XRA A - STA MSGADD+14 ;PUT 0 IN MESSAGE AT 15th BYTE - - JMP CPM - - - -; FOLLOWING IS UQCB TO GET MXDisk FOR THIS PROCESS - -UMXDSK: - - .BYTE 0,0 ;TWO BYTES FOR QUEUE ADDRESS - .WORD MSGADD ;MESSAGE WRITTEN HERE - .ASCII \MXDisk \ ;NAME TO GET -MSGADD: .BLKB 33 ;33 BYTES FOR STORAGE - - - -FREQUE: - -; RELEASE THE MXDisk QUEUE NEXT - - LDA DSKQ ;SEE IF WE HAD HELD MXDISK - ORA A - JRZ ..NOQU - MVI C,139 ;WRITE BACK TO QUEUE - LXI D,UMXDSK;UFORMS' Q.C.B. - CALL BDOS - -..NOQU: - MVI C,0 ;MP/M RESET SYSTEM - XRA A - JMP BDOS ;EXIT HERE FOR MP/M - JMP ZERO - -DSKQ: .WORD 0 -VERFLG: .WORD 0 - - - -CPM: - - CALL BVECT ;SET UP BIOS POINTERS - LXI H,0 - SHLD BADNUM ;NO BAD RECORDS YET - MVI A,1 - STA LSTER ;TURN OFF LIST ECHO - CALL BADIT ;SET FIRST BAD FILE NAME - - - .IFE PROTCT,[ - - LXI B,7FH - CALL SETSEC - LXI B,2 - CALL SETTRK - LXI B,FILBUF - CALL SETDMA - CALL SECRD - ORA A - JZ SIGON - HLT - ] - - -;******************************************************** -; SIGN ON AND GET DRIVE TO TEST -;******************************************************** - -SIGON: - MVI C,PRINTS ;SHOW USER THE PROGRAM - LXI D,MESS1 ;AND GET TEST DRIVE - CALL BDOS ;IF ANY - CALL GETDRV - JNC SIGON ;IF DRIVE NOT VALID - STA TEST ;SAVE DRIVE HERE - CALL GETPRM ;GET DPH ETC FOR THIS DRIVE - JMP GETOPT - - -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; GET A DRIVE FROM THE USER -; RETURN WITH IT IN ACC. -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: - -GETDRV: - MVI C,GETCON ;GET ANSWER - CALL BDOS - CPI 3 ;IF ^C THEN GO WARM BOOT - JZ ZERO - CPI 27 - JZ PRMPT - CPI 'Q' - JC UPPER - SUI 'a'-'A' ;GET UPPER CASE -UPPER: - CPI 'Q' ;SEE IF VALID - RNC - CPI 'A' - JC TOOLOW - SUI 'A' ;GET HEX VALUE - CPI 17 - RET -TOOLOW: - CMC - RET - -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; GET PARAMETERS FOR DRIVE IN ACC. -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: - -GETPRM: - MVI B,0 - MOV C,A ;GET THIS DISK - PUSH B ;SAVE IT - LXI B,DIRBUF ;SET SAFE DMA AREA - CALL SETDMA ;HAVE BIOS SET IT - POP B ;GET BACK DRIVE - MVI E,0 ;FIRST SELECT - CALL SELDSK ;HAVE BIOS SELECT DRIVE - SHLD DPHADD ;SAVE DPH ADDRESS VECTOR - MOV A,M ;NOW GET XLATE VECTOR LOW BYTE - INX H - MOV H,M ;GET HIGH BYTE - MOV L,A - SHLD XLATE ;SAVE XLATE VECTOR HERE - LHLD DPHADD ;GET BACK DPH ADDRESS - LXI D,10 ;INDEX INTO DPB VECTOR - DAD D ;HL NOW HAS DPB VECTOR - MOV A,M ;GET LOW BYTE - INX H - MOV H,M ;GET UPPER BYTE - MOV L,A - LXI D,DPB1 ;MAKE LOCAL DPB1 THE DESTINATION - MVI C,15 ;15 BYTES TO MOVE - CALL BMOVE ;COPY DPB INTO LOCAL RAM - RET - - -;******************************************************** -; DISPLAY PROGRAM OPTIONS & GET USER RESPONCE -;******************************************************** - -GETOPT: - LXI SP,STACK ;RESET FOR MULTIPLE ACTIONS - MVI A,1 - STA REMFLG ;RESET REMOVAL FLAG - LXI D,MESS2 ;PRINT USER OPTION MESSAGE - MVI C,PRINTS - CALL BDOS - LXI D,INBUFF - MVI C,GETBUF - CALL BDOS - - - .IFE ROMER,[ - - LXI H,0E000H ;1800H BYTES BELOW MONITOR - LXI D,600H ;1/4 OF 1800H - DAD D ;NOW MAKE IT 0F800H BY ADDING - DAD D - DAD D - DAD D - LXI B,0F30BH ;B HAS FIRST BYTE OF MONITOR, C HAS - ;MONITOR PRONM 'ON' PORT - OUTP A ;TURN IT ON - MOV A,M ;GET FIRST BYTE OF MONITOR - CMP B ;SEE IF SAME AS B - JZ ROMOFF ;IF SO SHUT OFF MONITOR - HLT ;ELSE QUIT -ROMOFF: - DCX B ;MAKE MONITOR 'OFF' PORT - OUTP A ;TURN IT OFF - ] - - LDA INBUFF+1 ;GET # OF KEYS PRESSED - CPI 1 ;SEE IF OPTION 1 TO 9 - JZ NINER - LDA INBUFF+3 - SUI '0' - ADI 10 - CPI 12 - JNC GETOPT - MOV C,A - MVI A,1 - STA LSTER ;CANCEL PRINTER OUTPUT - MOV A,C - DCR A - JMP ADJUST - -NINER: - LDA INBUFF+2 ;GET 1 TO 9 - CPI '1' ;TEST FOR VALID ANSWER - JC GETOPT - CPI ':' - JNC GETOPT - CPI '9' - JZ NOFLG - CPI '7' - JNZ GETECH -NOFLG: - MVI A,1 - JMP DOFLG -GETECH: - LXI D,MESS3 ;ASK IF THEY WANT TO ECHO ON PRINTER - MVI C,PRINTS - CALL BDOS - MVI C,GETCON - CALL BDOS - STA ANS1 - CALL CRLF - LDA ANS1 - CPI 'Y' - JNZ NOTY - XRA A -DOFLG: - STA LSTER ;SET PRINTER ECHO FLAG - JMP DOFCN - -NOTY: - MVI A,1 - STA LSTER - - -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; PROCESS REQUEST -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: - -DOFCN: - LDA INBUFF+2 ;GET KEY TYPED - SUI '1' ;GET INDEX VALUE -ADJUST: - ADD A ;*2 - LXI H,OPTTAB ;OPTION TABLE - MVI D,0 - MOV E,A - DAD D - MOV A,M ;GET LOWER ADDRESS BYTE - INX H - MOV H,M ;GET UPPER ADDRESS BYTE - MOV L,A ;GET LOWER INTO L - PCHL ;DO IT - -OPTTAB: - .WORD DMPSRN ;DUMP DIRECTORY ON SCREEN - .WORD DISP ;DISPLAY ALL INVALID ENTRIES - .WORD RENAM ;RENAME INVALID ENTRIES - .WORD REMOV ;REMOVE INVALID ENTRIES - .WORD SURFAC ;TEST ENTIRE DISK SURFACE - .WORD BLOCK ;REMOVE BAD BLOCKS - .WORD START ;START OVER - .WORD RDSYS ;READ SYSTEM TRACKS - .WORD UNERA ;UNERASE ALL FILES - .WORD COPY ;COPY DISKS - .WORD DUMPT ;DUMP TRACKS - .WORD EMPTY - -EMPTY: - JMP START - - -;******************************************************** -; DUMP THE DIRECTORY ON THE SYSTEM DISPLAY -;******************************************************** - -DMPSRN: - CALL DIRNIT ;SET UP INITIAL PARAMETERS - LXI B,DIRBUF ;READ INTO DIRECTORY BUFFER - CALL SETDMA -DMP0: - CALL READ ;READ THE SECTOR - CALL DUMP ;SHOW ON SCREEN - CALL UPDATE ;POINT TO NEXT POSSIBLE READ - JZ PRMPT ;IF DONE NOW - JMP DMP0 - - -;******************************************************** -; READ A SECTOR FROM A GIVEN TRACK -;******************************************************** - -READ: - LHLD CURTRK ;GET CURRENT TRACK - PUSH H - POP B - CALL SETTRK ;SET IT IN BIOS - LHLD CURSEC ;GET CURRENT SECTOR # - PUSH H - POP B - LHLD XLATE ;PICK UP TRANSLATE VECTOR - PUSH H - POP D ;GET XLATE TABLE INTO DE - CALL SECTRN ;GET BIOS SECTOR VALUE - MOV B,H ;MAKE IT SELECTABLE - MOV C,L - CALL SETSEC ;NOW SET TRANSLATED SECTOR - CALL SECRD ;READ ONE SECTOR - RET - - -;******************************************************** -; POINT TO NEXT SECTOR & TRACK OR SHOW ALL DONE -;******************************************************** - -UPDATE: - LDA CURSEC ;GET CURRENT SECTOR - INR A ;UPDATE IT - STA CURSEC - MOV C,A ;SAVE IN C - LDA SPT ;GET MAX SECTORS PER TRACK - CMP C ;TEST WITH UPDATE - JNZ SECEND - XRA A - STA CURSEC ;ZERO SECTOR FOR NEXT TRACK TO READ - LHLD CURTRK ;AND GET CURRENT TRACK - INX H ;MAKE NEXT - SHLD CURTRK ;SAVE IT -SECEND: - LHLD NUMSEC ;GET SECTORS TO READ - DCX H ;UPDATE THEM - SHLD NUMSEC - MOV A,H ;SEE IF LAST SECTOR READ - ORA L - RET ;SHOW WHEN DONE - - -;******************************************************** -; DUMP TRACK ON SCREEN -;******************************************************** - -FRSTS: .WORD 1 -HDFLG: .BYTE 1 -DMPSRC: .BYTE 0 - -DUMPT: - MVI A,1 ;SET DUMP SECTOR TO SCREEN FLAG - STA DMPSRC - CALL DIRNIT ;INIT DRIVE DPH AND DPB - CALL GETREC ;GET MAXIMUM RECORDS - -TELDMP: - LXI D,MESS17 ;TELL USER TO ENTER STARTING TRACK # - MVI C,PRINTS - CALL BDOS - CALL LDHL ;GET TWO HEX BYTES IN HL FOR STARTING TRACK - SHLD CURTRK ;SAVE IT AS CURRENT TRACK - - - LXI H,DIRBUF ;SET DIRBUF AS DMA FOR DUMP - SHLD CURDMA - PUSH H - POP B - CALL SETDMA - LHLD CURTRK ;SEE WHICH STARTING TRACK WE HAVE - MOV A,H ;SEE IF READLY HIGH - CPI 0 - JNZ DUMPT1 ;IF SO GO DO MAJOR DUMP - MOV C,L ;SAVE IN C - LDA OFF ;GET OFFSET TRACK - CMP C ;SEE IF SYSTEM TRACK - JC DUMPT1 ;IF NOT DO MAJOR DUMP - CALL RDSYS1 ;ELSE READ SYSTEM TRACKS - - LDA OFF ;GET OFFSET - MOV L,A - MVI H,0 ;MAKE IT NEXT TRACK - SHLD CURTRK - MVI A,0 ;SET NEXT SECTOR - STA CURSEC - -DUMPT1: - -; COMPUTE REMAINIG RECORDS TO DO READS - - LHLD CURTRK ;GET OUR TRACK - MOV A,H ;TEST IF OUR TRACK = OFF TRACK - CPI 0 - JNZ ITSUP ;MUST BE QUITE HIGH - MOV C,L - LDA OFF - CMP C - JZ DUMPT2 ;MAX RECS ARE O.K. -ITSUP: - LDA OFF ;GET OFF TRACKS - -DOOFF: - DCX H ;REMOVE SYSTEM TRACKS - DCR A - JNZ DOOFF - LXI D,0 ;DE WILL HOLD RECORDS WHEN DONE - -RCLOP: - LDA SPT - MOV B,A -RCLOP1: - INX D ;UPDATE RECORDS - DCR B ;UPDATE SPT - JNZ RCLOP1 - DCX H ;UPDATE TRACKS - MOV A,H - ORA L - JNZ RCLOP - - LHLD MAXREC ;GET MAX RECORDS - MOV A,H - CMP D - JC DUMPT ;TOO BIG - JNZ SIZOK - MOV A,L - CMP E - JC DUMPT ;TOO BIG -SIZOK: - MOV A,L - SUB E - MOV L,A - MOV A,H - SBB D - MOV H,A - SHLD CURREC - - MVI A,0 - STA CURSEC - -DUMPT2: - CALL READ - CALL DUMP - LHLD CURREC - DCX H - SHLD CURREC - MOV A,H - ORA L - JZ PRMPTF - LDA CURSEC - INR A - STA CURSEC - MOV C,A - LDA SPT - CMP C - JNZ DUMPT2 - LHLD CURTRK - INX H - SHLD CURTRK - MVI A,0 - STA CURSEC - JMP DUMPT2 - -PRMPTF: - XRA A - STA DMPSRC - JMP PRMPT - - -;***************************************************** -;* GET TWO BYTES OF HEX DATA FROM K.B. -;* & RETURN WITH THEM IN HL REGS -;***************************************************** - -LDHL: - CALL HEXIN ;GET K.B. AND MAKE HEX - MOV H,A ;THATS THE HI BYTE - CALL HEXIN ;DO HEX AGAIN - MOV L,A ;THATS THE LOW BYTE - RET ;GO BACK WITH ADDRESS - - -;***************************************************** -;* GET K.B. DATA & MAKE IT 'HEX' -;***************************************************** - -HEXIN: - CALL NIBL ;DO A NIBBLE - RLC ;MOVE FIRST BYTE UPPER NIBBLE - RLC - RLC - RLC - MOV B,A ;SAVE ROTATED BYTE - CALL NIBL ;DO NEXT NIBBLE - ADD B ;COMBINE NIBBLES IN ACC. - RET ;DONE - -NIBL: - CALL KIN ;GET K.B. DATA - CPI 40H ;TEST FOR ALPHA - JRNC ALPH - ANI 0FH ;GET THE BITS - RET -ALPH: - ANI 0FH - ADI 09H ;MAKE IT HEX A-F - RET - -KIN: - PUSH H - PUSH B - MVI C,GETCON - CALL BDOS - POP B - POP H - RET - - - -;******************************************************** -; COPY FROM DISK TO DISK -;******************************************************** - -COPY: - LXI D,MESS13 ;ASK FOR SOURCE DRIVE - MVI C,PRINTS - CALL BDOS - CALL GETDRV - STA DRVONE - LXI D,MESS14 ;ASK FOR DESTINATION DRIVE - MVI C,PRINTS - CALL BDOS - CALL GETDRV - STA DRVTWO - - LDA DRVONE ;GET DPH ETC. FOR DRIVE ONE - CALL GETPRM - LHLD XLATE - SHLD XLATE1 - LXI H,DPB1 ;DPB WAS PUT HERE - LXI D,DPB2 ;PUT IT HERE - MVI C,15 - CALL BMOVE - - LDA DRVTWO ;GET SAME FOR DRIVE TWO - CALL GETPRM - LHLD XLATE - SHLD XLATE2 - LXI H,DPB1 - LXI D,DPB3 - MVI C,15 - CALL BMOVE - - LXI H,DPB2 ;TEST DPBS FOR COMPATABILITY - LXI D,DPB3 - MVI C,15 -DPHCMP: - LDAX D - CMP M - JNZ DRVDIF ;IF DRIVES ARE NOT SAME - INX H - INX D - DCR C - JNZ DPHCMP - -COPY1: - CALL DIRNIT ;INITIALIZE RECORDS TO COPY - LHLD OFF ;GET OFFSET - SHLD CURTRK ;SET FIRST TRACK - CALL GETREC ;COMPUTE MAX RECORDS - LHLD MAXREC - SHLD CURREC - LXI H,0 - SHLD CURSEC - LXI D,MESS8 - MVI C,PRINTS - CALL BDOS - -COPY3: - - MVI A,CR - CALL COUT - LHLD CURTRK - CALL PHLD - - MVI A,3 - STA RETRY - -COPY30: - LXI H,COPBF - SHLD CURDMA - PUSH H - POP B - CALL SETDMA - LDA DRVONE - MOV C,A - MVI E,1 - CALL SELDSK - -; READ A FULL TRACK NEXT - -COPY4: - CALL READ - LHLD CURDMA - LXI D,128 - DAD D - SHLD CURDMA - PUSH H - POP B - CALL SETDMA - LDA CURSEC - INR A - STA CURSEC - MOV C,A - LDA SPT - CMP C - JNZ COPY4 - XRA A - STA CURSEC - -; WRITE A FULL TRACK NEXT - -COPY5: - LDA DRVTWO - MOV C,A - MVI E,1 - CALL SELDSK - LXI H,COPBF - SHLD CURDMA - PUSH H - POP B - CALL SETDMA - -COPY6: - CALL WRITE0 - LHLD CURDMA - LXI D,128 - DAD D - SHLD CURDMA - PUSH H - POP B - CALL SETDMA - - LDA CURSEC - INR A - STA CURSEC - MOV C,A - LDA SPT - CMP C - JNZ COPY6 - XRA A - STA CURSEC - -COPY7: - LXI H,COPBF1 - SHLD CURDMA - PUSH H - POP B - CALL SETDMA - -; READ THE TRACK JUST WRITTEN AN VERIFY ITS' DATA - -COPY8: - CALL READ - LHLD CURDMA - LXI D,128 - DAD D - SHLD CURDMA - PUSH H - POP B - CALL SETDMA - LHLD CURREC - DCX H - SHLD CURREC - MOV A,H - ORA L - JZ COPY9 - LDA CURSEC - INR A - STA CURSEC - MOV C,A - LDA SPT - CMP C - JNZ COPY8 - - LXI H,COPBF - LXI D,COPBF1 - LDA SPT - MOV C,A -VLOP: - MVI B,128 - -VLOP0: - LDAX D ;GET DATA READ FROM DESTINATION - CMP M ;TEST WITH DATA WRITTEN - JNZ OHOH - INX H - INX D - DCR B ;UPDATE BYTES PER RECORD - JNZ VLOP0 - DCR C ;LAST SECTOR DONE - JNZ VLOP ;IF NOT COMPARE NEXT - - XRA A - STA CURSEC - LHLD CURTRK - INX H - SHLD CURTRK - JMP COPY3 - -OHOH: - LDA RETRY - DCR A - STA RETRY - JNZ COPY30 - - LXI D,MESS16 - MVI C,PRINTS - CALL BDOS - JMP PRMPT - - -DRVDIF: - LXI D,MESS15 - MVI C,PRINTS - CALL BDOS - -COPY9: - JMP PRMPT - -RETRY: .BLKB 1 - - -;******************************************************** -; UNERASE ALL DIRECTORY ENTRIES -;******************************************************** - -UNERA: - MVI C,PRINTS - LXI D,UMESS - CALL BDOS - CALL DIRNIT - LXI B,DIRBUF - CALL SETDMA - -UNERLP: - CALL READ - CALL RECOV - CALL UPDATE - JZ PRMPT - JMP UNERLP - -RECOV: - MVI A,4 ;4 DIRECTORY ENTRIES PER SECTOR - STA RECCNT - LXI H,DIRBUF ;READ INTO HERE - SHLD DIRPTR -REVLOP: - LHLD DIRPTR - MOV A,M - CPI 0E5H - JNZ NOMAT - INX H ;TEST NEXT BYTE - MOV A,M - CPI 0E5H ;SEE IF UNINITIALIZED AREA - JZ NOMAT ;IF SO SKIP IT - DCX H ;GET BACK TO ERASE BYTE - MVI A,0 ;SET UP FOR NORMAL ENTRY - MOV M,A ;UNERASE IT - -NOMAT: - LHLD DIRPTR ;UPDATE DIRECTORY POINTER - LXI D,32 - DAD D - SHLD DIRPTR - LDA RECCNT ;UPDATE DIRECTORY ENTRY - DCR A - STA RECCNT - JZ FIXOO - JMP REVLOP -FIXOO: - CALL WRITE0 ;WRITE OUT 4 ENTRIES - RET - - -UMESS: - .BYTE CLEAR - .ASCII \Will recover all erased files. Make a backup as soon as possible$\ - - - -;******************************************************** -; DISPLAY ALL INVALID DIRECTORY ENTRIES -;******************************************************** - -DISP: - CALL DIRNIT ;GET INITIAL POINTERS -DIRLP: - CALL READ ;GET A SECTOR - CALL CHECK - CALL UPDATE - JZ PRMPT - JMP DIRLP - -CHECK: - MVI A,4 - STA RECCNT - LXI H,DIRBUF - SHLD DIRPTR -DIRLP0: - LHLD DIRPTR ;SAVE DIRECTORY POINTER - MOV A,M ;GET FIRST BYTE - CPI 0E5H ;SEE IF ERASED - SHLD DIRPTR - CNZ TSTNAM ;IF NOT ERASED CHECK FOR VALID NAME - LHLD DIRNUM ;UPDATE DIRECTORY COUNTER - INX H - SHLD DIRNUM - LHLD DIRPTR - LXI B,32 - DAD B ;GET NEXT LOCATION - SHLD DIRPTR - LHLD DIRLEN ;GET DIRCTORY SIZE - DCX H ;COUNT DOWN ENTRIES - SHLD DIRLEN - MOV A,H - ORA L - JZ PRMPT ;DO NEXT NAME IF MORE - LDA RECCNT - DCR A - STA RECCNT - JNZ DIRLP0 - RET - - -; TEST IF HL POINTS TO A VALID DIRECTORY ENTRY -; HL ENTERS WITH LOCATION OF DIRECTORY ENTRY - -TSTNAM: - LXI D,TESTBF ;MOVE NAME TO A SAFE LOCATION - MVI C,12 - CALL BMOVE - CALL VIOLAT ;TEST FOR BAD ALLOCATION - - LXI H,TESTBF ;POINT TO NAME TO TEST - INX H ;START OF NAME - MVI D,11 ;11 VALID BYTES -NAMLP: - MOV A,M ;GET NAME BYTE -TSTCHR: - CPI '0' ;FIRST RANGE TEST - JC NOTFAR - INX H - DCR D - JNZ NAMLP - RET -NOTFAR: - LXI H,TESTBF - CALL SCANIT ;TEST FOR BAD SPACE FORM IN NAME - LDA VILFLG - MOV C,A - LDA SPCERR - ORA C - RZ ;IF ZERO SET IT WAS GOOD - CALL VRYBAD - XRA A - CPI 2 - RET - - -SCANIT: -; CHECK THE FILE NAME FOR BAD CHARACTER FORM - - PUSH H - XRA A - STA SCNFLG ;SHOW WE HAVE A SPACE - STA SPCERR ;SET SPACE ERROR FLAGE O.K. - LXI B,8 - DAD B ;START AT END OF PRIMARY NAME - MVI B,8 ;8 BYTES TO TEST - - -; FIRST TEST PRIMARY NAME - -SCNLP0: - MOV A,M - ANI 7FH - CPI ' ' - JC ..FLGB ;TOTALLY UNACCEPTABLE BYTE - JNZ NOSPC - LDA SCNFLG ;SEE IF WE HAD A SPACE - ORA A - JZ NXTSP ;NO SPACE VIOLATION -..FLGB: - MVI A,':' ;FLAG A BAD CHARACTER - MOV M,A - STA SPCERR -NOSPC: - MVI A,1 - STA SCNFLG ;SHOW NO MORE SPACES ALLOWED -NXTSP: - DCX H - DCR B - JNZ SCNLP0 ;FINISH PRIMARY NAME - -; NOW TEST NAME EXTENSION - - MVI A,0 ;SHOW A SPACE FOUND - STA SCNFLG - POP H ;RECOVER NAME POINTER - LXI B,11 - DAD B ;MAKE END OF NAME - MVI B,3 ;3 BYTES TO TEST - -SCNLP1: - MOV A,M - ANI 7FH - CPI ' ' - JC ..FLGB ;TOTALLY UNACCEPTABLE - JNZ NOSPC0 - LDA SCNFLG - ORA A - JZ NXTSP0 -..FLGB: - MVI A,':' - MOV M,A - STA SPCERR -NOSPC0: - MVI A,1 ;WE HAVE A NON-SPACE CHARACTER - STA SCNFLG ;SO SET THE FLAG -NXTSP0: - DCX H ;POINT NEXT - DCR B - JNZ SCNLP1 - LDA SPCERR ;SHOW CALLING PROGRAM IF SPACE VIOLATED - ORA A - RET - - - -VRYBAD: - LXI H,BDAT - CALL MSG - CALL CRLF - - LXI H,TESTBF ;GET NAME POINTER - INX H - MVI B,11 - -; NOW PRINT NAME ON SCREEN - -SHOW: - MOV A,B ;GET CHARACTER COUNTER - CPI 3 ;SEE IF START OF EXTENSION - CZ PERD ;IF SO PERIODE IT - MOV A,M - ANI 7FH - CPI ' ' - JNC COUT1 - MVI A,':' -COUT1: CALL COUT - INX H - DCR B - JNZ SHOW - LHLD DIRPTR ;GET DIRECTORY POINTER - CALL FDAT0 ;SHOW FILE DATA - LDA VILFLG ;SEE IF DISK SIZE VIOLATION - ORA A - JZ NOVILR - LXI H,SIZVIL ;IF SO PRINT VIOLATION MESSAGE - CALL MSG -NOVILR: - CALL CRLF - CALL CRLF - RET - - - - - -;******************************************************** -; SET INITIAL POINTERS & VALUES FOR DISRECTORY SCAN -;******************************************************** - -DIRNIT: - LHLD DRM ;GET # OF DIRECTORY ENTRIES - INX H ;MAKE ACTUAL - SHLD DIRLEN - LXI B,0 ;SECTOR COUNTER - -; COMPUTE TOTAL SECTORS IN DIRECTORY - -ENTRY: - DCX H ;4 ENTRIES PER SECTOR - DCX H - DCX H - DCX H - INX B ;UPDATE SECTOR COUNTER - MOV A,H ;TEST IF ALL ENTRIES DONE - ORA L - JNZ ENTRY - MOV A,C ;GET LOW SECTOR COUNT - STA NUMSEC ;SAVE LOW BYTE SECTORS TO READ - MOV A,B ;GET HIGH SECTOR COUNT - STA NUMSEC+1 ;SAVE HIGH BYTE S.T.R. - LHLD NUMSEC - SHLD DIRENT ;SAVE AS RECORDS IN DIRECTORY - LXI H,0 - SHLD DIRNUM ;INITIAL DIRECTORY RECORD - SHLD CURSEC ;INITIAL SECTOR - LHLD OFF ;DIRECTORY TRACK - SHLD CURTRK - RET - - - -;******************************************************** -; SEE IF DIRECTORY ENTRY VIOLATES DISK SIZE -;******************************************************** - -VIOLAT: - XRA A - STA VILFLG ;SHOW NO VIOLATION YET - MVI B,8 ;CHECK 8 ENTRIES - - LHLD DSM ;GET BLOCKS IN DISK - PUSH H ;SAVE DISK SIZE - - LHLD DIRPTR ;GET FILE POINTER - LXI D,31 ;GET BLOCK MAP END - DAD D ;HL PONTS TO END OF ALLOCATION MAP - POP D ;GET DISK SIZE INTO DE - - -; FIRST TEST IF ALLOCATION MAP RUNS OFF THE DISK - -VIOLOP: - MOV A,M ;GET HIGH BYTE ENTRY - CMP D ;COMPARE WITH DISK SIZE HIGH - JC OK ;IF SMALLER THEN O.K. - JNZ BADSIZ ;IF NOT ZERO THEN TOO BIG - -; HIGH BYTE IS SAME SO TEST IF LOW BYTE MUST BE SAME OR LESS - - DCX H ;POINT TO DIRECTORY LOW BYTE - MOV A,M ;GET LOW BYTE - CMP E ;COMPARE WITH DSM LOW BYTE - JC OK1 ;IF SMALLER O.K. - JZ OK1 ;IF SAME SIZE THEN O.K. - -BADSIZ: - MVI A,1 - STA VILFLG ;SHOW SIZE VIOLATION - RET - -OK: - DCX H ;RESET FOR ENTIRE FIELD - -OK1: - DCX H ;POINT NEXT MAP AREA - DCR B ;UPDATE FIELD COUNTER - RZ ;IF AT END - JMP VIOLOP ;TRY NEXT - - -; PRINT A PERIODE - -PERD: - MVI A,'.' - CALL COUT - RET - - -;******************************************************** -; RENAME ALL INVALID DIRECTORY ENTRIES -;******************************************************** - -RENAM: - CALL DIRNIT ;SET INITIAL VALUES - MVI A,'A' ;SETUP NAME VARIABLES - STA BADFNM - STA BADFNM+1 - LXI D,MESS4 ;TELL USER OPTIONS HERE - MVI C,PRINTS - CALL BDOS - LXI D,INBUFF - MVI C,GETBUF ;GET SEED NAME FOR FILE - CALL BDOS - LXI H,INBUFF+1 ;GET CHARACTERS ENTERED - MOV A,M - CPI 5 - JZ FINE - JMP RENAM -FINE: - CALL CRLF - CALL CRLF - MVI C,DSKRST ;RESET DISK SYSTEM - CALL BDOS - LDA TEST ;GET DISK FOR TEST - MVI C,SLDISK ;HAVE BDOS LOG IT ON - MOV E,A - CALL BDOS - CALL CLEARF ;CLEAR FCB - LXI H,INBUFF+2 ;GET SEED NAME LOCATION - MVI C,5 - LXI D,FCB3+1 ;POINT TO NAME AREA IN FCB - CALL BMOVE ;MOVE IT IN - LXI H,HUH ;POINT TO ANY NAME - MVI C,6 - CALL BMOVE - CALL DMATCH ;SEE IF A MATCH - JNZ RENAM ;IF FILE IS DUPLICATED - -RENAM0: - LXI SP,STACK - LXI B,DIRBUF - CALL SETDMA - CALL READ ;READ A SECTOR - CALL RCHECK ;SEE IF ANY BAD ENTRIES - CALL UPDATE ;POINT TO NEXT SECTOR - JZ EPRMPT ;IF ALL DONE - JMP RENAM0 - - -; CHECK THE DIRECTORY ENTRIES IN CURRENT SECTOR FOR VALID FILES - -RCHECK: - MVI A,4 - STA RECCNT - LXI H,DIRBUF - SHLD DIRPTR -RCHKLP: - LHLD DIRPTR - MOV A,M - CPI 0E5H - CNZ TSTNAM - LDA VILFLG ;GET SIZE VIOLATION FLAG - ORA A ;SEE IF OFF DISK - JZ ..NOVL ;WE CAN HANDLE IT ALWAYS - CALL KILL ;WE MIGHT BE REMOVING - JMP ..DRUP ;IF NOT KILLED WE CAN'T HANDLE NOW -..NOVL: - LDA SPCERR ;SEE IF FILE NAME WAS BAD - ORA A - CNZ RENAM1 ;IF FILE NAME BAD RENAME IT -..DRUP: - LHLD DIRNUM ;UPDATE DIRECTORY ENTRY - INX H - SHLD DIRNUM - LHLD DIRPTR - LXI B,32 - DAD B - SHLD DIRPTR - LHLD DIRLEN - DCX H - SHLD DIRLEN - MOV A,H - ORA L - JZ PRMPT - LDA RECCNT - DCR A - STA RECCNT - JNZ RCHKLP - RET - - - -RENAM1: - LDA REMFLG ;SEE IF WE ARE REMOVING - ORA A - JZ KILL ;JUST GET RID OF ENTRY - - CALL CLEARF ;CLEAR FCB - LHLD DIRPTR ;GET FILE LOCATION - MOV A,M ;GETUSER NUMBER - ANI 0FH - - MVI C,SETUSR ;SET TO THIS USER - MOV E,A - CALL BDOS - LHLD DIRPTR ;POINT BACK TO FILE - INX H ;POINT TO NAME FIELD - LXI D,FCB3+1 ;MOVE TO HERE - MVI C,8 - CALL BMOVE - MVI C,3 ;READY TO GET EXTENSION - CALL BMOVES ;STRIP BIT 7 LOW IN EXTENSION - MVI C,SETATT ;SET ATTRIBUTES AS STANDARD - LXI D,FCB3 - CALL BDOS - INR A - JZ ATTFAL - CALL CLEARU ;CLEAR UPPER SEGMENT OF FCB - -; NOW MOVE IN NEW NAME - - LXI D,FCB3+17 ;POINT TO RENAME FIELD - LXI H,INBUFF+2 ;POINT TO SEED NAME - MVI C,5 - CALL BMOVE ;MOVE RENAME CHARACTERS IN - PUSH D ;SAVE DESTINATION - CALL GETTWO ;GET TWO NEW CHARACTERS - MOV A,H - STA NAMCNT - MOV A,L - STA NAMCNT+1 - POP D ;RECOVER DESTINATION - LXI H,NAMCNT - MVI C,3 - CALL BMOVE ;MOVE IN SEED NAME UPDATE - - LXI H,EXTENS ;POINT TO EXTENSION - MVI C,3 - CALL BMOVE - - LXI H,FCB3+17 ;SHOW RENAME ON SCREEN - MVI C,11 -..MOV: - MOV A,M - CALL COUT - INX H - DCR C - JNZ ..MOV - CALL CRLF - - LXI D,READBF - MVI C,DMAF - CALL BDOS - - MVI C,RENAME ;RENAME THIS FILE - LXI D,FCB3 - CALL BDOS - INR A - JNZ USRZR0 - - MVI C,SETUSR - MVI E,0 - CALL BDOS - JMP RENFAL -USRZR0: - LXI B,0 - CALL SETTRK - LXI B,1 - CALL SETSEC - LXI B,80H - CALL SETDMA - CALL SECRD - - MVI E,0 - MVI C,SETUSR - CALL BDOS - RET - -EPRMPT: - MVI C,DSKRST - CALL BDOS - MVI E,0 - MVI C,SETUSR - CALL BDOS - JMP PRMPT - - -;******************************************************** -; ERASE THE HOPELESS FILES FROM DISK DIRECTORY -;******************************************************** - -REMOV: - CALL DIRNIT - XRA A - STA REMFLG ;SHOW WE ARE REMOVING 'FILES' - JMP RENAM0 - -KILL: - LDA REMFLG - ORA A - RNZ - LHLD DIRPTR - MVI A,0E5H - MOV M,A - LXI H,DIRBUF - PUSH H - POP B - CALL SETDMA - MVI C,1 - CALL SECWRT - RET - - -;******************************************************** -; SET UP ADDRESSES FOR DIRECT BIOS ENTRY -; TO PRODUCE A LOCAL JUMP TABLE ACCESSED -; VIA A CALL TO PCHL ROUTINE -;******************************************************** - -BVECT: - - LHLD 1 ;GET BIOS POINTER - MOV A,M ;GET FIRST JUMP - CPI 0C3H ;SEE IF IT IS A 'JMP' - JNZ START ;SOMETHING'S WRONG - LXI D,3 - DAD D - SHLD BCONST ;BIOS CONSOLE STATUS - DAD D - SHLD BCONIN ;BIOS CONSOLE INPUT - DAD D - SHLD BCONOT ;BIOS CONSOLE OUTPUT - - LHLD 1 ;GET BACK BIOS VECTOR FOR DISK I/O - LXI D,21 ;SET FIRST OFFSET - DAD D ;SET HOME VALUE - SHLD BHOME ;BIOS HOME DISK - LXI D,3 - DAD D - SHLD BSEL ;BIOS SELECT DISK - DAD D - SHLD BTRACK ;BIOS SET TRACK - DAD D - SHLD BSEC ;BIOS SET SECTOR - DAD D - SHLD BDMA ;BIOS SET DMA - DAD D - SHLD BREAD ;BIOS SECTOR READ - DAD D - SHLD BWRITE ;BIOS SECTOR WRITE - DAD D - DAD D - SHLD BSTRAN ;BIOS SECTOR TRANSLATE - RET - - -;******************************************************** -; MEMORY DATA BLOCK MOVE ROUTINE -; HL IS SOURCE POINTER, DE HAS DESTINATION POINTER -; C HAS NUMBER OF BYTES TO MOVE -;******************************************************** - -BMOVE: -MLOP: - MOV A,M - STAX D - INX D - INX H - DCR C - JNZ MLOP - RET - -BMOVES: - MOV A,M - ANI 7FH - STAX D - INX H - INX D - DCR C - JNZ BMOVES - RET - -;******************************************************** -; TEST ENTIRE DISK SURFACE NEXT -;******************************************************** - -SURFAC: - LXI H,WRITBF ;ZERO FILL WRITE BUFFER - MVI C,128 - MVI A,0E5H -FILWRT: - MOV M,A - INX H - DCR C - JNZ FILWRT - - LDA TEST ;GET DRIVE TO TEST - ORA A - JZ NOSYS ;DON'T USE SYSTEM DRIVE - - LXI D,MESS7 ;WARN USER ABOUT DISK WRITES - MVI C,PRINTS - CALL BDOS - MVI C,GETCON ;GET ANSWER - CALL BDOS - CPI 'Y' - JNZ START - CALL GETREC ;SET UP DISK SIZE - -; NOW PREPARE TO WRITE DATA ON DISK - - LHLD MAXREC - SHLD CURREC - LXI H,0 - SHLD CURSEC - LXI D,MESS8 - MVI C,PRINTS - CALL BDOS - LHLD OFF - SHLD CURTRK - MVI A,CR - CALL COUT - LHLD CURTRK - CALL PHLD - LXI B,WRITBF - CALL SETDMA - -; WRITE TRACK & SECTOR ADDRESS ON SECTOR - -WADLOP: - LHLD CURTRK - SHLD WRITBF - LDA CURSEC - STA WRITBF+2 - CALL WRITE0 - LHLD CURREC - DCX H - SHLD CURREC - MOV A,H - ORA L - JZ RADCHK - LDA CURSEC - INR A - STA CURSEC - MOV C,A - LDA SPT - CMP C - JNZ WADLOP - XRA A - STA CURSEC - LHLD CURTRK - INX H - SHLD CURTRK - MVI A,CR - CALL COUT - LHLD CURTRK - CALL PHLD - JMP WADLOP - -; READ BACK & CHECK ALL ADDRESSES NEXT - -RADCHK: - LXI D,MESS8 - MVI C,PRINTS - CALL BDOS - - LXI H,0 - SHLD CURSEC - LHLD MAXREC - SHLD CURREC - LHLD OFF - SHLD CURTRK - MVI A,CR - CALL COUT - LHLD CURTRK - CALL PHLD - - LXI B,READBF - CALL SETDMA - -RADLOP: - CALL READ ;READ A SECTOR - LHLD READBF - XCHG - LHLD CURTRK - MOV A,H - CMP D - JNZ BADADD - MOV A,L - CMP E - JNZ BADADD - LDA READBF+2 - MOV C,A - LDA CURSEC - CMP C - JZ GOODAD -BADADD: - CALL PRTBAD -GOODAD: - LHLD CURREC - DCX H - SHLD CURREC - MOV A,H - ORA L - JZ PRMPT - - LDA CURSEC - INR A - MOV C,A - STA CURSEC - LDA SPT - CMP C - JNZ RADLOP - -; MOVE TO NEXT TRACK - - XRA A - STA CURSEC - LHLD CURTRK - INX H - SHLD CURTRK - MVI A,CR - CALL COUT - LHLD CURTRK - CALL PHLD - JMP RADLOP - - -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; SHOW MISS-MATCH IN SECTOR DATA FOR COMPARE -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: - -PRTBAD: - LXI H,MESS10 - CALL MSG - LHLD CURTRK - CALL PHLD - CALL FIVSPC - LDA CURSEC - CALL HXOUT - CALL FIVSPC - LHLD READBF - CALL PHLD - CALL FIVSPC - LDA READBF+2 - CALL HXOUT - MVI A,CR - CALL COUT - MVI A,LF - CALL COUT - RET - -FIVSPC: - LXI H,MESS9 - CALL MSG - RET - - -;******************************************************** -; WRITE TO THE CURRENT SECTOR & TRACK -;******************************************************** - -WRITE0: - LHLD CURTRK - PUSH H - POP B - CALL SETTRK - LHLD CURSEC - PUSH H - POP B - CALL SETSEC - LHLD XLATE - PUSH H - POP D - CALL SECTRN - MOV B,H - MOV C,L - CALL SETSEC - MVI C,2 - CALL SECWRT - RET - - -GETREC: -; CALCULATE NUMBER OF RECORDS TO TEST - - LDA BSH ;GET BSH FOR DISK - MOV C,A ;GET RECORDS PER BLOCK FACTOR INTO C - LHLD DSM ;WE HAVE BLOCKS PER DISK IN HL - -RECLOP: - DAD H ;COMPUTE RECORDS - DCR C - JNZ RECLOP - SHLD MAXREC ;SAVE RECORDS TO TEST - LDA BLM ;GET RECORDS PER BLOCK - INR A - STA RECPB - -; CALCULATE TOTAL DATA TRACKS - - LXI D,0 ;SET DE TO ZERO FOR TOTAL TRACKS -TTLOP: - LDA SPT - MOV B,A -TTLOP1: - DCX H ;COUNT DOWN RECORDS - MOV A,H - ORA L - JZ TTEXIT - DCR B ;AGAINST SPT - JNZ TTLOP1 ;NOT FINISHED A TRACK - INX D ;ADD A TRACK - JMP TTLOP -TTEXIT: - PUSH D - POP H - SHLD MAXTRK ;SAVE DATA TRACKS - RET - -NOSYS: - LXI D,MESS12 - MVI C,PRINTS - CALL BDOS - JMP PRMPT - -;******************************************************** -; READ SYSTEM TRACKS -;******************************************************** - -RDSYS: - -; ENTRY FOR OPTION SELECTION - - LXI H,0 - SHLD CURTRK - -; ENTRY FOR OTHER SELECTION - -RDSYS1: - LXI H,1 ;SET AS A FLOPPY FIRST - SHLD FRST+1 - SHLD FRST1+1 - CALL GETREC ;CALCULATE RECORDS ON DISK - LHLD MAXREC ;GET MAXIMUM RECORDS - MOV A,H ;NOW TEST HIGH BYTE - CPI 8 ;SEE IF S.S.S.D. - JC SSSPT ;IF SO DO NORMAL SECTOR READS - CPI 40H ;SEE IF 2 MEG. OR UP - JC NOTBIG - LXI H,0 ;IF HARD DISK SET FOR SAME - SHLD FRST+1 - SHLD FRST1+1 - JMP SSSPT - -NOTBIG: - MVI A,36 ;ELSE READ 36 SECTORS PER SYSTEM TRACK - STA SYSSEC - JMP RDSYST -SSSPT: - LDA SPT - STA SYSSEC -RDSYST: - LXI D,MESS8 - MVI C,PRINTS - CALL BDOS - - -FRST: - LXI H,1 - SHLD CURSEC - MVI A,CR - CALL COUT - LHLD CURTRK - CALL PHLD - LXI B,DIRBUF - CALL SETDMA - -SYSLOP: - CALL SREAD ;TEST FOR SECTOR DUMP - LDA DMPSRC - ORA A - JZ NODMP - CALL DUMP - -NODMP: - LDA CURSEC - INR A - MOV C,A - STA CURSEC - LDA SYSSEC - CMP C - JNZ SYSLOP - -; READ NEXT SYSTEM TRACK - -FRST1: - LXI H,1 - SHLD CURSEC - LHLD CURTRK - INX H - SHLD CURTRK - MOV A,L - MOV C,A - LDA OFF - CMP C - JZ DMPCHK - MVI A,CR - CALL COUT - LHLD CURTRK - CALL PHLD - JMP SYSLOP - -DMPCHK: - LDA DMPSRC - ORA A - JZ PRMPT - RET - - -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; READ A CP/M RECORD ON A SYSTEM TRACK -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: - -SREAD: - LHLD CURTRK - PUSH H - POP B - CALL SETTRK - LHLD CURSEC - PUSH H - POP B - CALL SETSEC - CALL SECRD - RET - - -;******************************************************** -; ALLOCATE BAD BLOCKS TO A FILE 'JUNKY' -;******************************************************** - -BLOCK: -; SET UP STARTING PARAMETERS - - LXI D,MESS8 - MVI C,PRINTS - CALL BDOS - - - LHLD OFF - SHLD CURTRK ;FIRST TRACK - LXI H,0 - SHLD CURSEC ;FIRST SECTOR - SHLD BLKNUM ;FIRST BLOCK - SHLD RECNUM ;FIRST RECORD - CALL GETREC - LHLD MAXREC ;GET DISK SIZE - SHLD CURREC - LDA RECPB ;GET RECORDS/BLOCK - STA RPBNUM ;SET RPB COUNTER - LXI B,READBF - CALL SETDMA - - LHLD CURTRK - MVI A,CR - CALL COUT - LHLD CURTRK - CALL PHLD - - -; READ ALL OF DISK SURFACE & FLAG BAD BLOCKS - -BLOCK0: - LXI SP,STACK - CALL READ ;READ A SECTOR - ORA A ;TEST IF READ O.K. - CNZ SETBAD - LXI H,RPBNUM ;POINT TO RECORDS PER BLOCK - DCR M ;UPDATE - JNZ GETR ;IF STILL SAME BLOCK SKIP NEXT - LDA RECPB ;ELSE GET RECORDS PER BLOCK THIS DISK - STA RPBNUM ;RESET COUNTER - LHLD BLKNUM ;GET ACTUAL BLOCK NUMBER - INX H ;AND UPDATE IT - SHLD BLKNUM -GETR: - LHLD RECNUM ;GET RECORD NUMBER - INX H ;UPDATE IT - SHLD RECNUM - LHLD CURREC ;GET TOTAL RECORDS - DCX H ;UPDATE - SHLD CURREC - MOV A,H ;TEST IF DISK DONE - ORA L - JZ SEEBAD ;IF DONE CHECK FOR BAD BLOCKS - LDA CURSEC ;UPDATE SECTOR - INR A - STA CURSEC - MOV C,A - LDA SPT - CMP C ;SEE IF LAST SECTOR - JNZ BLOCK0 - -; SET NEXT TRACK - - XRA A - STA CURSEC - LHLD CURTRK ;GET CURRENT TRACK - INX H ;UPDATE IT - SHLD CURTRK - MVI A,CR - CALL COUT - LHLD CURTRK - CALL PHLD - JMP BLOCK0 - -SEEBAD: - LDA BADNUM ;SEE IF ANY BAD BLOCKS - ORA A - JZ PRMPT - XRA A - STA FILCNT ;SAVE FILES CREATED - -FILOP: - LXI SP,STACK - - CALL DIRNIT - - MVI C,DSKRST ;RESET DISK SYSTEM - CALL BDOS - MVI C,SETUSR - MVI E,15 - CALL BDOS ;DO FILES ON USER AREA 15 - LDA TEST ;GET TEST DISK - MOV E,A - MVI C,SLDISK - CALL BDOS - -NAMLOP: - CALL CLEARF ;CLEAR OUT FCB - CALL GETTWO ;GET UNIQUE TWO CHARACTER STRING - MOV A,H ;AND PUT IN FCB PRIMARY NAME - STA BADNAM+5 - MOV A,L - STA BADNAM+6 - -; MOVE NAME INTO FCB - - LXI H,BADNAM - LXI D,FCB3+1 - MVI C,11 - CALL BMOVE - - LXI D,FCB3 - MVI C,SEARCH ;SEE IF IT EXISTS - CALL BDOS - INR A - JNZ NAMLOP ;IF SO TRY ANOTHER NAME - -; NAME IS UNIQUE SO CREATE A DIRECTORY ENTRY - - LXI D,FCB3 - MVI C,MAKEF - CALL BDOS - LXI D,FCB3 ;NOW CLOSE ENTRY - MVI C,CLOSEF - CALL BDOS - -; NOW SCAN DIRECTORY FOR NAME & FILL ALLOCATION MAP WITH BAD BLOCKS - - LHLD OFF - SHLD CURTRK ;FIRST TRACK - LXI H,0 ;FIRST SECTOR - SHLD CURSEC - LXI B,DIRBUF ;USE DIRECTORY BUFFER - CALL SETDMA - -FIXLOP: - CALL READ ;READ A SECTOR - CALL CMPTST ;COMPARE FOR NEW FILE NAME - JZ FILOP ;IF FOUND DO NEXT FILE - CALL UPDATE ;IF NOT FOUND SET NEXT SECTOR - JZ FILOP ;RETURN IF DIRECTORY SCANNED - JMP FIXLOP ;ELSE CONTINUE - - -; SCAN CURRENT SECTOR FOR THIS FILE NAME - -CMPTST: - MVI A,4 ;4 ENTRIES PER SECTOR - STA RECCNT - LXI H,DIRBUF ;FROM THIS BUFFER - SHLD DIRPTR - -CMPTS0: - LHLD DIRPTR ;GET BUFFER POINTER - INX H ;SET AT START OF NAME - LXI D,FCB3+1 ;COMPARE WITH OUR FCB - MVI C,11 ;11 BYTES MUST BE SAME - CALL COMPNM ;DO COMPARE ROUTINE - JZ BLKOUT ;IF MATCH GO DO ALLOCATION - LHLD DIRPTR ;MAKE NEXT ENTRY ADDRESS - LXI B,32 - DAD B - SHLD DIRPTR - LHLD DIRLEN ;UPDATE DIRECTORY ENTRIES - DCX H - SHLD DIRLEN - MOV A,H - ORA L - JZ FILOP ;WE HAVE SCANNED ALL OF DIRECTORY - LDA RECCNT ;GET ENTRIES\SECTOR - DCR A ;UPDATE - STA RECCNT - JNZ CMPTS0 - CPI 2 ;SHOW FILE NOT FOUND HERE - RET ;DO NEXT SECTOR - - -BLKOUT: -; PUT BAD BLOCKS INTO FCB ALLOCATION MAP, SET RECS AS 8 - - CALL FILALL ;FIX UP FCB TO HOLD NEXT 8 BAD BLOCKS - MVI C,1 ;SET DIRECTORY WRITE FLAG - CALL SECWRT ;WRITE THIS SECTOR - LDA FILCNT ;UPDATE FILE COUNT - INR A - STA FILCNT - LDA BADNUM ;SEE IF BAD BLOCKS LEFT - ORA A - JZ PRMPT ;IF ALL DONE - XRA A - RET - - -FILALL: - LHLD DIRPTR ;GET CURRENT ENTRY - LXI D,15 - DAD D ;POINT TO RECORD BYTE - MVI A,8 ;SET FOR 8 RECORDS WRITTEN - MOV M,A - INX H ;POINT TO ALLOCATION MAP ENTRY - PUSH H ;SAVE IT FOR NOW - -; MAKE POINTER TO BAD BLOCK TABLE - - MVI H,0 - LDA FILCNT ;GET THIS FILE # - MOV L,A ;INDEX FOR NEXT 8 BAD BLOCKS - DAD H ;*2 - DAD H ;*4 - DAD H ;*8 - DAD H ;*16 - XCHG ;INDEX VALUE IN DE - LXI H,BLKTAB ;START OF BAD BLOCK TABLE - DAD D ;HL HAS BAD BLOCK TABLE ENTRY - POP D ;DE HAS FCB ALLOCATION ENTRY -BLKMOV: - MVI B,8 ;DO UP TO 8 BLOCKS -BLKMV: - MVI C,2 ;TWO BYTES PER ALLOCATION ENTRY - CALL BMOVE ;MOVE IN A BLOCK - LDA BADNUM ;GET BAD BLOCK COUNTER - DCR A ;UPDATE - STA BADNUM - RZ ;RETURN IF DONE - DCR B ;ELSE DO ANOTHER BLOCK - JNZ BLKMV - RET - - -COMPNM: -; COMPARE CHARACTER STRINGS AT HL AND DE FOR C BYTES - - LDAX D - CMP M - RNZ - INX H - INX D - DCR C - RZ - JMP COMPNM - - -; RESET USER AREA TO 0 - -PPRMPT: - MVI C,SETUSR - MVI E,0 - CALL BDOS - JMP PRMPT - - -; MOVE UP TO 8 BAD BLOCKS INTO ALLOCATION MAP - -BLKIT: - LDA FILCNT ;GET CURRENT FILE NUMBER - MOV L,A - MVI H,0 - DAD H ;*2 - DAD H ;*4 - DAD H ;*8 - DAD H ;*16 - XCHG - LXI H,BLKTAB - DAD D ;HL POINTS TO START OF BLOCKS - MVI B,8 ;DO UP TO EIGHT BLOCKS - -; MOVE BLOCKS INTO PLACE - - LXI D,FCB3+16 ;START OF ALLOCATION MAP -BLKIT0: - MVI C,2 - CALL BMOVE - DCR B ;TEST IF LAST BLOCK - RZ - LDA BADNUM - DCR A ;TEST IF ACTUAL LAST BLOCK - STA BADNUM - RZ - JMP BLKIT0 - - -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; INITIALIZE BAD FILE NAME -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -BADIT: - MVI A,'A' ;SET INITIAL BAD FILE NAME - STA BADFNM - STA BADFNM+1 - RET - - -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; GENERATE TWO CHARACTERS FOR A FILE NAME -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: - -GETTWO: - LDA BADFNM - INR A - CPI 5BH - JNC ..UPIT - STA BADFNM - LHLD BADFNM - RET -..UPIT: - MVI A,'A' - STA BADFNM - LDA BADFNM+1 - INR A - STA BADFNM+1 - LHLD BADFNM - RET - -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; KEEP A RECORD OF BAD BLOCKS -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: - -SETBAD: - LDA BADNUM ;GET CURRENT NUMBER OF BAD BLOCKS - INR A ;UPDATE IT - STA BADNUM - JZ ZERO ;TOO MANY BAD BLOCKS - LXI H,BLKTAB ;POINT TO BAD RECORD SAVE AREA - DCR A ;FOR NOW TEST WITH LAST ENTRY - ADD A ;FOR TWO BYTE INDEX - MVI D,0 - MOV E,A - DAD D ;POINT TO LAST BLOCK ENTRY - MOV C,M ;GET LOW BYTE - INX H ;POINT TO HIGH BYTE - MOV B,M ;GET HIGH BYTE - LHLD BLKNUM ;GET CURRENT BLOCK NUMBER - MOV A,H ;TEST IF SAME AS LAST - CMP B - JNZ ..NOPE - MOV A,L - CMP C - JNZ ..NOPE - LDA BADNUM ;SET BLOCK COUNTER SAME AS BEFORE - DCR A - STA BADNUM -..NOPE: - LHLD BLKNUM ;GET BACK BLOCK NUMBER - PUSH H ;SAVE IT - POP B ;INTO BC - LXI H,BLKTAB ;POINT TO SAVE AREA - DAD D ;INDEX IN - MOV M,C ;SAVE LOW BYTE - INX H - MOV M,B ;SAVE HIGH BYTE - RET - -;******************************************************** -; LOCAL ENTRY TABLE FOR BIOS ACCESS STARTS HERE -;******************************************************** - -HOME: - LHLD BHOME ;HOME DRIVE - PCHL - -SELDSK: - LHLD BSEL ;SELECT DRIVE - PCHL - -SETTRK: - LHLD BTRACK ;SET TRACK - PCHL - -SETDMA: - LHLD BDMA ;SET DMA ADDRESS - PCHL - -SETSEC: - LHLD BSEC ;SET SECTOR - PCHL - -SECRD: - LHLD BREAD ;READ SECTOR - PCHL - -SECWRT: - LHLD BWRITE ;WRITE SECTOR - PCHL - -SECTRN: - LHLD BSTRAN ;TRANSLATE SECTOR - PCHL - - - -;******************************************************** -; BIOS ADDRESS VECTORS STORED HERE -;******************************************************** - -BCONST: .BLKW 1 ;BIOS CONSOLE STATUS -BCONIN: .BLKW 1 ;BIOS CONSOLE INPUT -BCONOT: .BLKW 1 ;BIOS CONSOLE OUTPUT -BHOME: .BLKW 1 ;HOME THE DRIVE -BSEL: .BLKW 1 ;SELECT THE DRIVE -BTRACK: .BLKW 1 ;SET TRACK TO R/W -BSEC: .BLKW 1 ;SET SECTOR TO R/W -BDMA: .BLKW 1 ;SET DMA ADDRESS -BREAD: .BLKW 1 ;READ SECTOR -BWRITE: .BLKW 1 ;WRITE SECTOR -BSTRAN: .BLKW 1 ;GET SECTOR TRANSLATION - - -;******************************************************** -; THE DPB FOR THE SELECTED DRIVE IS COPIED TO HERE -;******************************************************** - -DPB1: -SPT: .BYTE 0,0 ;SECTORS PER TRACK -BSH: .BYTE 0 ;BLOCK SHIFT FACTOR -BLM: .BYTE 0 ;RECORDS/BLOCK-1 -EXM: .BYTE 0 ;EXTENT MASK -DSM: .BYTE 0,0 ;BLOCKS/DISK -DRM: .BYTE 0,0 ;DIRECTORY ENTRIES-1 -AL0: .BYTE 0 ;RESRVED DATA BLOCKS FOR DIR. #0 -AL1: .BYTE 0 ; ' ' ' ' ' #1 -CKS: .BYTE 0,0 ;CHECKSUM VECTOR SIZE -OFF: .BYTE 0,0 ;RESERVED TRACKS - - -DPB2: .BLKB 15 -DPB3: .BLKB 15 - -XLATE1: .BLKB 2 -XLATE2: .BLKB 2 - - -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; CARRIAGE RETURN & LINE FEED OUTPUT -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: - -CRLF: - MVI E,CR - CALL OUTPUT - MVI E,LF - CALL OUTPUT - RET - -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; OUTPUT A SPACE CHARACTER TO DISPLAY -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: - -SPACE: - MVI E,' ' - CALL OUTPUT - RET - - -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; OUTPUT THE ACCUMULATOR TO SYTEM DISPLAY -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: - -COUT: -; CHARACTER OUTPUT ENTRY - - MOV E,A - CALL OUTPUT - RET - - -DONEIT: -DONAM: - JMP ZERO - - - - -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; PRINT A FORM FEED (FOR LIST DEVICE) -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::: - -FORMF: - MVI E,FF - CALL OUTPUT - RET - - - -OUTPUT: - PUSH PSW - PUSH B - PUSH D - PUSH H - LDA LISTO - ORA A - JZ CONIT - MVI C,LIST - CALL BDOS - POP H - POP D - POP B - POP PSW - RET - -CONIT: - MOV A,E ;SAVE CONSOLE CHAR - PUSH PSW - MVI C,PRTCON - CALL BDOS - POP PSW ;GET BACK CONSOLE CHAR - MOV E,A ;PUT IN E - LDA LSTER ;SEE IF LIST ECHO - ORA A - JNZ RETRN ;IF NOT JUST RETURN - MVI C,LIST ;ELSE ECHO IT - CALL BDOS -RETRN: - POP H - POP D - POP B - POP PSW - RET - - -;******************************************************** -; ROUTINE TO DUMP HEX AND ASCII SECTOR DATA TO DISPLAY -;******************************************************** - -DUMP: - CALL CRLF ;DROP DOWN A LINE - LXI H,TRAKNR ;PRINT TRACK NUMBER - CALL MSG - LHLD CURTRK ;GET TRACK TO DUMP - CALL PHLD - CALL SPACE -DUMP1: - LXI H,SECNUM ;PRINT SECTOR # INFO - CALL MSG - LDA CURSEC ;GET THE SECTOR # - CALL HXOUT ;PRINT IT - LXI H,FILDAT ;FILE DATA MESSAGE - CALL MSG ;SET IT UP - CALL CRLF - CALL CRLF - LXI H,DIRBUF ;GET BUFFER AREA TO DUMP - SHLD DMPBUF - MVI B,8 ;8 DUMPED LINES PER SECTOR -BLKRD: - MVI C,16 ;DUMP 16 BYTES PER LINE - PUSH H ;SAVE STARTING HL -NXTONE: - MOV A,M ;GET BYTE TO DUMP - CALL HXOUT ;PRINT IT IN HEX - CALL SPACE -UPDH: - INX H ;POINT TO NEXT BYTE - DCR C ;UPDATE LINE BYTE COUNT - JNZ NXTONE ;IF LINE NOT DONE - -; NOW PRINT 'DECODED' DATA TO RIGHT OF DUMP - -DECODE: - MVI C,16 ;SET FOR 16 BYTES - POP H ;GET BACK START OF THIS LINE - PUSH H ;AND RESAVE FOR FILE DATA - -DECOD0: - MOV A,M ;GET BYTE - ANI 7FH ;STRIP HIGH BIT - CPI ' ' ;SEE IF PRINTABLE - JNC OKCHRS ;IF PRINTABLE -DOT: - MVI A,'.' ;LOAD A DOT -OKCHRS: CALL COUT ;PRINT IT - INX H ;POINT TO NEXT BYTE - DCR C ;UPDATE CHAR. COUNTER - JNZ DECOD0 ;DO NEXT - -; PRINT FILE DATA - -CONTD: - SHLD DMPBUF ;UPDATE DUMP BUFFER - POP H ;GET BACK POINTER - MOV A,B ;GET LINE COUNTER - RAR ;SEE IF ENTRY LINE - JC DOCRLF - MOV A,M ;GET ERASE BYTE - CPI 0E5H - JZ DOCRLF ;NOT A VALID FILE - CALL FDAT0 ;PRINT FILE DATA - -DOCRLF: CALL CRLF - MOV A,B - RAR ;SEE IF DIRECTORY LINE - JC NOTSO - LHLD DIRNUM ;GET DIRECTORY NUMBER - INX H ;UPDATE IT - SHLD DIRNUM -NOTSO: - LHLD DMPBUF ;GET UPDATED BUFFER POINTER - DCR B ;UPDATE LINE COUNTER (8 PER SECTOR) - JZ HOLDR - JMP BLKRD ;ELSE DUMP REST OF SECTOR - -; WAIT A SHORT WHILE SO USER CAN READ - -HOLDR: - MVI B,2 ;WAIT A WHILE HERE -HLOP: - LXI H,0 -HLOP0: - DCX H - MOV A,H - ORA L - JNZ HLOP0 - DCR B - JNZ HLOP -TSTCON: - CALL DHOLD - RET - - -;******************************************************** -; UPDATE FILE DATA FIELDS FOR DISPLAY -;******************************************************** - -FDAT0: - PUSH H ;SAVE DIRECTORY POINTER - CALL SPACE - LHLD DIRNUM ;GET CURRENT DIRECTORY NUMBER - CALL PHLD ;PRINT ENTRY NUMBER - CALL SPACE - POP H - PUSH H - MOV A,M ;GET USER NUMBER - ANI 0FH - CALL HXOUT ;PRINT IT - CALL SPACE - CALL SPACE - POP H ;GET POINTER BACK - PUSH H - LXI D,12 ;GET EXTENT # - DAD D - MOV A,M - CALL HXOUT - CALL SPACE - POP H - LXI D,15 - DAD D - MOV A,M - CALL HXOUT - RET - - - -;******************************************************** -; PRINT THE ACCUMULATOR CONTENTS AS HEX DATA -;******************************************************** - -HXOUT: - PUSH B ;SAVE BC - MOV B,A - RLC ;DO HIGH NIBBLE FIRST - RLC - RLC - RLC - ANI 0FH ;ONLY THIS NOW - ADI 30H ;TRY A NUMBER - CPI 3AH ;TEST IT - JC OUT1 ;IF CY SET PRINT 'NUMBER' - ADI 07H ;MAKE IT AN ALPHA - -OUT1: - MOV C,A - CALL COUT ;SCREEN IT - MOV A,B ;NEXT NIBBLE - ANI 0FH ;JUST THIS - ADI 30H ;TRY A NUMBER - CPI 3AH ;TEST IT - JC OUT2 ;PRINT 'NUMBER' - ADI 07H ;MAKE IT ALPHA - -OUT2: - MOV C,A - CALL COUT ;SCREEN IT - POP B ;RESTORE BC - RET - - -;******************************************************** -; PRINT THE HL REGS AS HEX DATA -;******************************************************** - -PHLD: - MOV A,H ;GET HI BYTE - CALL HXOUT ;DO HEX OUT ROUTINE - MOV A,L ;GET LOW BYTE - CALL HXOUT ;HEX IT - CALL DHOLD - RET - -;******************************************************** -; PRINT A MESSAGE STRING UNTIL BIT 7 IS SET IN CHAR -;******************************************************** - -MSG: - MOV A,M - CALL COUT - MOV A,M - ANI 80H - INX H - JZ MSG - RET - - -; RENAME ORIGINAL FILE, THEN READ IT IN - -KEEPIT: - -; SEE IF FILE EXISTS - - MVI C,OPENF ;OPEN FUNCTION FOR WSO.COM - LXI D,FCB3 - CALL BDOS - INR A ;TEST RESULT - JNZ GETWSO ;WE HAVE IT SO USE IT - - -; NO WSO.COM CREATED YET SO NOW TEST FOR WS.COM - - CALL CLEARF ;CLEAR FCB - LXI H,OLDNAM ;PUT IN WS.COM - LXI D,FCB3+1 - MVI C,8 - CALL BMOVE - LXI D,FCB3 ;NOW OPEN IT - MVI C,OPENF - CALL BDOS - INR A - JZ OPFAIL ;IF NO FILE - -; O.K. RENAME WS.COM FOR BACKUP USE - - CALL CLEARF - LXI H,OLDNAM - LXI D,FCB3+1 - MVI C,8 - CALL BMOVE ;INSERT WS.COM AS OLD - LXI H,NEWNAM - LXI D,FCB3+16 - MVI C,16 - CALL BMOVE ;INSERT WSO.COM AS NEW - LXI D,FCB3 - MVI C,RENAME ;HAVE CP/M RENAME IT - CALL BDOS - INR A - JZ RENFAL - CALL CLEARF - LXI H,NEWNAM+1 ;OMIT ZERO LEADER - LXI D,FCB3+1 - MVI C,8 - CALL BMOVE - MVI C,OPENF ;NOW OPEN WSO.COM - LXI D,FCB3 - CALL BDOS - INR A - JZ WOPFAL - - -; NOW READ IN THE ENTIRE FILE - -GETWSO: - LXI H,FILBUF ;START OF WS BUFFER -RDLOP: - XCHG ;PUT INTO DE - PUSH D ;SAVE DMA LOCATION - MVI C,DMAF ;SET DMA FUNCTION - CALL BDOS ;TELL BDOS - MVI C,READF ;NOW READ A RECORD - LXI D,FCB3 ;FOR FILE IN FCB - CALL BDOS - ORA A ;TEST FOR END OF FILE - JNZ DONEIT ;WE HAVE THE FILE - - LHLD RRECS ;UPDATE RECORD COUNTER - INX H - SHLD RRECS - POP H ;GET LAST DMA ADDRESS - LXI D,80H - DAD D ;MAKE IT THE NEXT DMA ADDRESS - JMP RDLOP ;GET NEXT RECORD - -;************************************************ -;* SAVE THE FILE IN FCB -;************************************************ - - -SAVFIL: -GO0: - MVI C,PRINTS ;TELL USER WE WANT FILE NAME INFO - LXI D,MESS11 - CALL BDOS -SINP: - LXI D,INBUFF ;POINT TO NAME BUFFER - MVI C,GETBUF ;LOAD READ BUFFER FUNCTION - CALL BDOS - LDA INBUFF+1 ;SEE CHARS ENTERED - ORA A - JZ GO0 - - LXI H,INBUFF+2 ;POINT TO NAME IN BUFFER - MOV B,A ;GET # OF CHARACTERS IN NAME - MVI C,8 ;ALLOW FOR UP TO 8 -NXTCHR: - MOV A,M ;GET CHARACTER - CPI 30H ;SEE IF VALID - JC GO0 ;WE DON'T WANT THIS NAME - DCR C ;COUNT DOWN - DCR B ;NEXT CHARACTER - JNZ NXTCHR - - -; CLEAR OUT FCB NEXT - - CALL CLEARF - - -; PUT NAME IN FCB & SAVE THE IMAGE NEXT - -FILFCB: - LXI H,INBUFF+2 ;POINT TO SAVE NAME - LXI D,FCB3+1 ;POINT TO FCB NAME LOC - LDA INBUFF+1 ;GET NUMBER OF CHARACTERS - CPI 9 ;TEST MAX LENGTH - JC FILOK - MVI A,8 -FILOKº - MOV C,A ;PUT CHAR. COUNT IN C -MOVLOP: - MOV A,M ;GET USER NAME - STAX D ;MAKE FILE NAME - INX H - INX D - DCR C - JNZ MOVLOP - -; NOW TEST IF SAME AS WSO.COM - - JMP DONAM - - -;********************************************************** -;* TEST TO SEE IF FILE EXISTS -;********************************************************** - -DMATCH: - LDA TEST - MOV E,A - MVI C,SLDISK - CALL BDOS - MVI C,DMAF ;SET UP DMA AREA - LXI D,TMPBUF ;POINT DMA BUFFER - CALL BDOS - - LXI D,FCB3 - MVI C,SEARCH ;SEARCH FIRST FUNCTION - CALL BDOS - CPI 0FFH - RZ - - LXI D,NMATCH ;POINT TO FILE MATCH MESS. - MVI C,PRINTS ;TELL USER OF MATCH - CALL BDOS - MVI C,GETCON ;NOW GET ANSWER - CALL BDOS - CPI 7FH ;DUMMY TEST - RNZ ;SHOW A MATCH WAS FORUND - - -MAKE1: - MVI C,MAKEF ;NOW MAKE FILE IN FCB NAME FIELD - LXI D,FCB3 - CALL BDOS ;DO IT - CPI 0FFH ;SEE IF MAKE FAILED - JZ FAIL ;IF SO SHOW FAILURE - - -;************************************************************* -;* NOW WRITE THE FILE TO DISK -;************************************************************* - - LXI H,FILBUF - -WRTLOP: - XCHG ;PUT DMA ADDRESS INTO DE - MVI C,DMAF ;SET DMA FUNCTION - PUSH D ;SAVE DMA ADDRESS - CALL BDOS - - MVI C,WRITEF ;WRITE RECORD FUNCTION - LXI D,FCB3 ;POINT FCB - CALL BDOS - CPI 0 - JNZ FAIL1 ;IF FAILURE SHOW IT - - LHLD RRECS ;GET RECORDS - DCX H - SHLD RRECS - MOV A,H - ORA L - JZ CLOSE1 ;CLOSE OPERATION - - POP H ;GET BACK DMA ADDRESS - LXI D,80H ;ADD A RECORD LENGTH - DAD D ;UPDATE POINTER - JMP WRTLOP - -CLOSE1: - MVI C,CLOSEF ;CLOSE FUNCTION - LXI D,FCB3 ;THIS FCB - CALL BDOS ;DO IT - CPI 0FFH - JZ FAIL2 ;SHOW IF FAILED - LXI D,MESS11 ;ELSE SHOW WE ARE DONE - MVI C,PRINTS - CALL BDOS - JMP ZERO - - -;***************************************************** -;* FILE I/O MESSAGES FOLLOW -;***************************************************** - -FAIL: - LXI D,MAKFAL - MVI C,PRINTS - CALL BDOS - JMP ZERO - -FAIL1: - LXI D,WRTFAL - MVI C,PRINTS - CALL BDOS - JMP ZERO - -FAIL2: - LXI D,CLSFAL - MVI C,PRINTS - CALL BDOS - JMP ZERO - -OPFAIL: - LXI D,OPNFAL - MVI C,PRINTS - CALL BDOS - JMP ZERO - - -;***************************************************** -;* USER PROMPTING MESSAGES FOLLOW -;***************************************************** - - -PRMPT: - XRA A - STA DMPSRC - LXI SP,STACK - CALL CRLF - MVI A,1 - STA DMPFLG - STA REMFLG - - XRA A - STA DMPSEC - MVI A,'*' - CALL COUT - -CONLOP: - MVI C,GETCON - CALL BDOS - CPI 3 - JZ ZERO - CPI CR - JNZ CONLOP - JMP GETOPT ;SEE WHATS NEXT - - -;********************************************************** -; CLEAR FCB INCASE OF FILE RE-NAME -;********************************************************** - -CLEARF: -; FIRST CLEAR OUT NAME FIELD - - LXI H,FCB3+1 ;POINT TO NAME - MVI B,8 ;8 POSSIBLE CHARS - MVI A,' ' ;A SPACE -PAD: - MOV M,A ;CLEAR OUT ALL 8 NAME BYTES - INX H - DCR B - JNZ PAD -CLEARU: -; NOW CLEAR OUT CONTROL FIELDS - - XRA A ;PREPARE TO ZERO FCB FIELDS - LXI H,FCB3+12 ;POINT TO CONTROL FIELDS - MVI B,36-12 ;GET LENGTH TO CLEAR -PAD1: MOV M,A ;FILL BYTE - INX H - DCR B - JNZ PAD1 - RET - - -;***************************************************** -; FILE I/O ERROR MESSAGES -;***************************************************** - -MAKFAL: - .BYTE CR,LF,LF - .ASCII \MAKE FILE FAILED$\ - -WRTFAL: - .BYTE CR,LF,LF - .ASCII \WRITE FILE FAILED$\ - -CLSFAL: - .BYTE CR,LF,LF - .ASCII \CLOSE FILE FAILED$\ - -OPNFAL: - .BYTE CR,LF,LF - .ASCII \CAN'T FIND THAT FILE $\ - -WOPFAL: - LXI D,WOPEN - MVI C,PRINTS - CALL BDOS - JMP ZERO - -WOPEN: - .BYTE CLEAR,TAB,TAB,TAB,TAB - .ASCII \CAN'T OPEN WSO.COM$\ - -NMATCH: - .BYTE CR,LF,LF - .ASCII \A File With That (Seed) Name Already Exists\ - .BYTE CR,LF - .ASCII \You Must Use Another Name, Enter 'CR' when Ready $\ - - -RENFAL: - LXI D,REFAL - MVI C,PRINTS - CALL BDOS - JMP ZERO - -REFAL: - .BYTE CR,LF,LF - .ASCII \FAILED TO RENAME FILE $\ - -ATTFAL: - LXI D,ATTFL - MVI C,PRINTS - JMP ZERO - -ATTFL: - .BYTE CR,LF,LF - .ASCII \FAILED TO SET ATTRIBUTES $\ - -REDFIL: - LXI D,BADRED - MVI C,PRINTS - CALL BDOS - JMP ZERO - -BADRED: - .BYTE CR,LF,LF - .ASCII \BIOS READ FAILURE$\ - - -WRITF: - LXI D,ERASR - MVI C,PRINTS - CALL BDOS - JMP ZERO - -ERASR: - .BYTE CR,LF,LF - .ASCII \DISK WRITE ERROR ON ERASE $\ - -DHOLD: - LXI H,RETST ;POINT TO RETURN - PUSH H ;MAKE IT STACK - LHLD BCONST ;CONSOLE STATUS TEST - PCHL -RETST: - ORA A ;SEE IF KEY PRESSED - RZ ;RETURN IF NOT - LXI H,RETST1 - PUSH H - LHLD BCONIN - PCHL -RETST1: - CPI ' ' - JZ AGAIN - CPI 27 - JZ PRMPT -AGAIN: - LXI H,RETST2 - PUSH H - LHLD BCONST - PCHL -RETST2: - ORA A - JZ AGAIN - LXI H,RETST3 - PUSH H - LHLD BCONIN - PCHL -RETST3: - CPI 27 - JZ PRMPT - RET - - -ZERO: - LDA DSKQ - ORA A - JNZ FREQUE - JMP 0 - - - - -;*************************************************** -; PROGRAM STORAGE AREA FOLLOWS -;*************************************************** - - -OLDNAM: - .BYTE ' ',' ',' ',' ',' ',' ',' ',' ' - -EXTENS: - .ASCII \BAD\ - -HUH: - .ASCII \???BAD\ - -NEWNAM: - .BYTE 0 - .BYTE ' ',' ',' ',' ',' ',' ',' ',' ' - .ASCII \ \ - .BYTE 0,0,0,0,0,0,0 - - -FCB3: - .BYTE 0 - .BYTE ' ',' ',' ',' ',' ',' ',' ',' ' - .ASCII \ \ - .BYTE 0,0,0,0,0,0,0,0,0,0,0,0 - .BYTE 0,0,0,0,0,0,0,0,0,0,0,0 - .BYTE 0,0,0,0,0,0,0,0,0,0,0,0 - - - -;******************************************************** -; USER PROMPTING MESSAGES FOLLOW -;******************************************************** - -MESS1: - .BYTE CLEAR - .ASCII \CP/M Disk Utility Functions Ver. 1.04\ - .BYTE CR,LF - .ASCII \Enter a Drive To Run Tests On A: to P: $\ - - -MESS2: - .BYTE CLEAR,TAB,TAB,TAB,TAB - .ASCII \Program Options\ - .BYTE CR,LF,LF - .ASCII \1...Dump Directory on Screen\ - .BYTE CR,LF - .ASCII \2...Display All Invalid Directory Entries\ - .BYTE CR,LF - .ASCII \3...Rename All Invalid Directory Entries\ - .BYTE CR,LF - .ASCII \4...Remove All Invalid Directory Entries\ - .BYTE CR,LF - .ASCII \5...Test Entire Disk Surface\ - .BYTE CR,LF - .ASCII \6...Remove Bad Blocks On Drive\ - .BYTE CR,LF - .ASCII \7...Select Another Drive\ - .BYTE CR,LF - .ASCII \8...Read System Tracks\ - .BYTE CR,LF - .ASCII \9...Unerase All Erased Files\ - .BYTE CR,LF - .ASCII \10..Disk to Disk Copy\ - .BYTE CR,LF - .ASCII \11..Dump Disk on Screen\ - .BYTE CR,LF - .ASCII \Enter to Quit\ - .BYTE CR,LF,LF - .ASCII \Enter Your Choice... $\ - -MESS3: - .BYTE CR,LF,LF - .ASCII \Do You Want to ECHO this on the Printer (Y/N) $\ - - -MESS4: - .BYTE CLEAR - .ASCIi \All Bad Files Will be Renamed in Increasing Sequence\ - .BYTE CR,LF - .ASCII \From a Seed Name You Enter, With a Default Extension of BAD\ - .BYTE CR,LF - .ASCII \NOTE: Files With Bad Allocation Parameters Will be Bypassed\ - .BYTE CR,LF - .ASCII \You Will use Option 4 to Remove Them ( Remove Option)\ - .BYTE CR,LF - .ASCII \Please Enter Seed Name of 5 Chars. $\ - - -MESS7: - .BYTE CLEAR - .ASCII \All data on selected disk will be DESTROYED\ - .BYTE CR,LF - .ASCII \Enter 'Y' if O.K. to continue, or 'N' if not $\ - - -MESS8: - .BYTE CR,LF,LF - .ASCII \TRACK\ - .BYTE CR,LF,LF+80H,EOL - - -MESS9: - .BYTE ' ',' ',' ',' ',' '+80H,EOL - - -MESS10: - .BYTE CR,LF - .ASCII \TRACK SECTOR TRACK SECTOR\ - .BYTE CR,LF+80H,EOL - -MESS11: - .BYTE CLEAR - .ASCII \Please Enter Name for this File $\ - - -MESS12: - .BYTE CR,LF,LF - .ASCII \You may not use the SYSTEM DRIVE for this function $\ - -MESS13: - .BYTE CLEAR - .ASCII \Please enter drive to copy from ( A: to P:) $\ - -MESS14: - .BYTE CR,LF - .ASCII \Please enter drive to copy to ( A: to P:) $\ - -MESS15: - .BYTE CR,LF,LF - .ASCII \Sorry but those drives have different characteristics $\ - -MESS16: - .BYTE CR,LF,LF,LF - .ASCII \The destination drive did not copy the data correctly.\ - .BYTE CR,LF - .ASCII \The copy operation will terminate now $\ - -MESS17: - .BYTE CLEAR - .ASCII \Enter starting track to dump in 4 hex digits (eg: 0000) $\ -SECNUM: - .ASCIS \SECTOR # \ - - -TRAKNR: - .ASCIS \TRACK # \ - - -FILDAT: - .ASCIS \--------------------------------------- DIR# USR EX RW\ - - -BDAT: - .ASCIS \ DIR# USR EX RW\ - - -SIZVIL: - .ASCIS \ File Allocation Map Not in Data Area\ - - - -;******************************************************** -; PROGRAM STORAGE AREA FOLLOWS -;******************************************************** - -;CONSOLE INPUT BUFFER & SINGLE CHARACTER STORAGE - -ANS: - .BLKB 1 ;ONE BYE FOR CONSOLE INPUT DATA -ANS1: - .BLKB 1 - - -INBUFF: - .BYTE 16 ;16 CHARACTER BUFFER - .BLKB 18 - - -;PROGRAM STORAGE - -RRECS: .BLKW 1 ;RECORS READ IN (TO WRITE BACK) - -BADFNM: .BYTE 'A','A' ;INITIAL BAD FILE NAME -TEST: .BYTE 0 ;DRIVE TO TEST -CURTRK: .BLKB 2 ;CURRENT TRACK TO READ/WRITE -CURSEC: .BLKB 2 ;CURRENT SECTOR TO READ/WRITE -CURDMA: .BLKB 2 ;CURRENT DMA -DIRENT: .BLKB 2 ;DIRECTORY ENTRIES -DMALOC: .BLKB 2 ;DMA STORAGE -DIRLEN: .BLKB 2 ;LENGTH OF DIRECTORY -DPHADD: .BLKB 2 ;DPH VECTOR ADDRESS -XLATE: .BLKB 2 ;XLATE TABLE ADDRESS -LISTO: .BYTE 0 ;0 = CONSOLE, 1 = LIST -DMPFLG: .BYTE 1 ;DUMP FLAG 0 = DUMP -DIRPTR: .BLKB 2 ;CURRENT DIRECTORY ENTRY -LSTER: .BLKB 1 ;0 TO LIST, 1 IF NOT -SECTR: .BLKB 1 ;SECTOR # -RECCNT: .BLKB 2 ;RECORDS TO READ/WRITE -DMPREC: .BLKB 2 ;RECORDS TO DUMP -DMPSEC: .BLKB 2 ;SECTOR TO DUMP -DMPBUF: .BLKB 2 ;BUFFER TO DUMP -DMPTRK: .BLKB 2 ;TRACK TO DUMP -NUMSEC: .BLKB 2 ;NUMBER OF SECTORS TO R/W -SCNFLG: .BLKB 1 ;SPACE IN NAME FLAG -SPCERR: .BLKB 1 ;ERROR IN SPACE POSITION OF FILE NAME -DIRNUM: .BLKB 2 ;CURRENT DIRECTORY ENTRY BEING R/W -VILFLG: .BLKB 1 ;DISK SIZE VIOLATION FLAG -SECCNT: .BLKB 2 ;DISK SECTOR COUNTER FOR REMOVE -REMFLG: .BLKB 1 ;FILE REMOVAL FLAG -MAXREC: .BLKB 2 ;RECORDS ON DISK -CURREC: .BLKB 2 ;CURRENT RECORD COUNTER -RECNUM: .BLKB 2 ;CURRENT WORKING RECORD -RECPB: .BLKB 1 ;RECORDS PER BLOCK -RPBNUM: .BLKB 1 ;CURRENT RECORD IN BLOCK -BLKNUM: .BLKB 2 ;CURRENT BLOCK -BADNUM: .BLKB 2 ;NUMBER OF BAD RECORDS -FILNUM: .BLKB 1 ;NUMBER OF BAD FILES TO CREATE -FILCNT: .BLKB 1 ;BAD FILES CREATED -BLKPTR: .BLKB 2 ;POINTER TO CURRENT BLOCK ENTRY -SYSSEC: .BLKB 1 ;NUMBER OF SYSTEM TRACK SECTORS -DRVONE: .BLKB 1 ;DRIVE TO COPY FROM -DRVTWO: .BLKB 1 ;DRIVE TO COPY TO -CDMA: .BLKB 2 ;COPY DMA ADDRESS -MAXTRK: .BLKB 2 ;TOTAL TRACKS ON DRIVE - -.ASCII \TRACKS REMAINING====================\ - -REMTRK: .BLKB 2 ;REMAINING TRACKS ON DRIVE - - -NAMCNT: .BYTE '@',' ',' ' ;FILE NAME COUNTER - -TESTBF: .BLKB 12 ;TEST NAME GOES HERE - - -;******************************************************** -; F.C.B USED TO FIXUP BAD FILE NAMES -;******************************************************** - -BADNAM: - .ASCII \JUNKY \ - - - -FIXFCB: - .BYTE 0 - .BLKB 36 - - - .BLKW 256 -STACK: - .BLKB 2 - - -DIRBUF: .BLKB 128 -READBF: .BLKB 128 -WRITBF: .BLKB 128 - -.ASCII \BAD BLOCKS\ - -BLKTAB: - -FILBUF == BLKTAB+512 - -COPBF == FILBUF+1024 -COPBF1 == COPBF+(128*150) - - - .END - diff --git a/software/CPM/CPM10_DISKUTILFUNC5/DUF05.COM b/software/CPM/CPM10_DISKUTILFUNC5/DUF05.COM deleted file mode 100644 index 80fdef7..0000000 Binary files a/software/CPM/CPM10_DISKUTILFUNC5/DUF05.COM and /dev/null differ diff --git a/software/CPM/CPM10_DISKUTILFUNC5/DUF05.PDF b/software/CPM/CPM10_DISKUTILFUNC5/DUF05.PDF deleted file mode 100644 index 4012b98..0000000 Binary files a/software/CPM/CPM10_DISKUTILFUNC5/DUF05.PDF and /dev/null differ diff --git a/software/CPM/CPM11_MAC80/BUTTONS.LIB b/software/CPM/CPM11_MAC80/BUTTONS.LIB deleted file mode 100644 index 99dd8a9..0000000 --- a/software/CPM/CPM11_MAC80/BUTTONS.LIB +++ /dev/null @@ -1,15 +0,0 @@ -; MACRO LIBRARY FOR PEDESTRIAN PUSHBUTTONS -; -CWINP EQU 00H ;INPUT PORT FOR CROSSWALK -; -PUSH? MACRO IFTRUE -;; "PUSH?" JUMPS TO LABEL "IFTRUE" WHEN ANY ONE -;; OF THE CROSSWALK SWITCHES IS DEPRESSED. THE -;; VALUE HAS BEEN LATCHED, AND READING THE PORT -;; CLEARS THE LATCHED VALUES - IN CWINP ;;READ THE CROSSWALK SWITCHES - ANI (1 SHL CWCNT) - 1 ;;BUILD MASK - JNZ IFTRUE ;;ANY SWITCHES SET? -;; CONTINUE ON FALSE CONDITION - ENDM - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/COMPARE.LIB b/software/CPM/CPM11_MAC80/COMPARE.LIB deleted file mode 100644 index 6aedabc..0000000 --- a/software/CPM/CPM11_MAC80/COMPARE.LIB +++ /dev/null @@ -1,59 +0,0 @@ -; MACRO LIBRARY FOR 8-BIT COMPARISON OPERATION -; -TEST? MACRO X,Y -;; UTILTITY MACRO TO GENERATE CONDITION CODES - IF NOT NUL X ;;THEN LOAD X - LDA X ;;X ASSUMED TO BE IN MEMORY - ENDIF - IRPC ?Y,Y ;;Y MAY BE CONSTANT OPERAND -TDIG? SET '&?Y'-'0' ;;FIRST CHAR DIGIT? - EXITM ;;STOP IRPC AFTER FIRST CHAR - ENDM - IF TDIG? <= 9 ;;Y NUMERIC? - SUI Y ;;YES, SO SUB IMMEDIATE - ELSE - LXI H,Y ;;Y NOT NUMERIC - SUB M ;;SO SUB FROM MEMORY - ENDM -; -LSS MACRO X,Y,TL -;; X LSS THAN Y TEST, -;; TRANSFER TO TL (TRUE LABEL) IF TRUE, -;; CONTINUE IF TEST IS FALSE - TEST? X,Y ;;SET CONDITION CODES - JC TL - ENDM -; -LEQ MACRO X,Y,TL -;; X LESS THAN OR EQUAL TO Y TEST - LSS X,Y,TL - JZ TL - ENDM -; -EQL MACRO X,Y,TL -;; X EQUAL TO Y TEST - TEST? X,Y - JZ TL - ENDM -; -NEQ MACRO X,Y,TL -;; X NOT EQUAL TO Y TEST - TEST? X,Y - JNZ TL - ENDM -; -GEQ MACRO X,Y,TL -;; X GREATER THAN OR EQUAL TO Y TEST - TEST? X,Y - JNC TL - ENDM -; -GTR MACRO X,Y,TL -;; X GREATER THAN Y TEST - LOCAL FL ;;FALSE LABEL - TEST? X,Y - JC FL - DCR A - JNC TL -FL: ENDM - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/DISK.DOC b/software/CPM/CPM11_MAC80/DISK.DOC deleted file mode 100644 index ee9a6da..0000000 --- a/software/CPM/CPM11_MAC80/DISK.DOC +++ /dev/null @@ -1,24 +0,0 @@ - File: Contents: - MAC.COM "MAC" Macro Assembler - SAMPLE.ASM Sample program to test MAC execution - - I8085.LIB Simple macros for 8085 RIM/SIM instructions - Z80.LIB Macro lirary for Z80 operation codes - Z80.DOC Documentation for the Z80.LIB file - - INTER.LIB Traffic light intersection library (see manual) - TREADLES.LIB Library for traffic treadles - BUTTONS.LIB Library for pedestrian pushbuttons - - SIMPIO.LIB Simple BDOS I/O Library - SEQIO.LIB Sequential file I/O library - - STACK.LIB Simple stack machine library - DSTACK.LIB Complete stack machine library - - COMPARE.LIB Library for simple 8-bit comparison operations - NCOMPARE.LIB 8-bit comparisons with negation - WHEN.LIB Macros for the WHEN construct (see manual) - DOWHILE.LIB Macros for the DOWHILE contstruct - SELECT.LIB Macros for the SELECT construct - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/DOWHILE.LIB b/software/CPM/CPM11_MAC80/DOWHILE.LIB deleted file mode 100644 index 930588f..0000000 --- a/software/CPM/CPM11_MAC80/DOWHILE.LIB +++ /dev/null @@ -1,41 +0,0 @@ -; MACRO LIBRARY FOR "DOWHILE" CONSTRUCT -; -GENDTST MACRO TST,X,Y,NUM -;; GENERATE A "DOWHILE" TEST - TST X,Y,,ENDD&NUM - ENDM -; -GENDLAB MACRO LAB,NUM -;; PRODUCE THE LABEL LAB & NUM -;; FOR DOWHILE ENTRY OR EXIT -LAB&NUM: - ENDM -; -GENDJMP MACRO NUM -;; GENERATE JUMP TO DOWHILE TEST - JMP DTEST&NUM - ENDM -; -DOWHILE MACRO XV,REL,YV -;; INITIALIZE COUNTER -DOCNT SET 0 ;NUMBER OF DOWHILES -;; -DOWHILE MACRO X,R,Y -;; GENERATE THE DOWHILE ENTRY - GENDLAB DTEST,%DOCNT -;; GENERATE THE CONDITIONAL TEST - GENDTST R,X,Y,%DOCNT -DOLEV SET DOCNT ;;NEXT ENDD TO GENERATE -DOCNT SET DOCNT+1 - ENDM - DOWHILE XV,REL,YV - ENDM -; -ENDDO MACRO -;; GENERATE THE JUMP TO THE TEST - GENDJMP %DOLEV -;; GENERATE THE END OF A DOWHILE - GENDLAB ENDD,%DOLEV -DOLEV SET DOLEV-1 - ENDM - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/DSTACK.LIB b/software/CPM/CPM11_MAC80/DSTACK.LIB deleted file mode 100644 index afee6c9..0000000 --- a/software/CPM/CPM11_MAC80/DSTACK.LIB +++ /dev/null @@ -1,468 +0,0 @@ -; MACRO LIBRARY FOR A ZERO ADDRESS MACHINE -; ***************************************** -; * BEGIN TRACE/DUMP UTILITIES * -; ***************************************** -BDOS EQU 0005H ;SYSTEM ENTRY -RCHAR EQU 1 ;READ A CHARACTER -WCHAR EQU 2 ;WRITE CHARACTER -WBUFF EQU 9 ;WRITE BUFFER -TRAN EQU 100H ;TRANSIENT PROGRAM AREA -DATA EQU 1100H ;DATA AREA -CR EQU 0DH ;CARRIAGE RETURN -LF EQU 0AH ;LINE FEED -; -DEBUGT SET 0 ;;TRACE DEBUG SET FALSE -DEBUGP SET 0 ;;PRINT DEBUG SET FALSE -; -PRN MACRO PR -;; PRINT MESSAGE 'PR' AT CONSOLE - IF DEBUGP ;;PRINT DEBUG ON? - LOCAL PMSG,MSG ;;LOCAL MESSAGE - JMP PMSG ;;AROUND MESSAGE -MSG: DB CR,LF ;;RETURN CARRIAGE - DB '&PR$' ;;LITERAL MESSAGE -PMSG: PUSH H ;;SAVE TOP ELEMENT OF STACK - LXI D,MSG ;;LOCAL MESSAGE ADDRESS - MVI C,WBUFF ;;WRITE BUFFER 'TIL $ - CALL BDOS ;;PRINT IT - POP H ;;RESTORE TOP OF STACK - ENDIF ;;END TEST DEBUGP - ENDM -; -UGEN MACRO -;; GENERATE UTILITIES FOR TRACE OR DUMP - LOCAL PSUB - JMP PSUB ;;JUMP PAST SUBROUTINES -@CH: ;;WRITE CHARACTER IN REG-A - MOV E,A - MVI C,WCHAR - JMP BDOS ;;RETURN THRU BDOS -;; -@NB: ;;WRITE NIBBLE IN REG-A - ADI 90H - DAA - ACI 40H - DAA - JMP @CH ;;RETURN THRU @CH -;; -@HX: ;;WRITE HEX VALUE IN REG-A - PUSH PSW ;;SAVE LOW BYTE - RRC - RRC - RRC - RRC - ANI 0FH ;;MASK HIGH NIBBLE - CALL @NB ;;PRINT HIGH NIBBLE - POP PSW - ANI 0FH - JMP @NB ;;PRINT LOW NIBBLE -;; -@AD ;;WRITE ADDRESS VALUE IN HL - PUSH H ;;SAVE VALUE - MVI A,' ' ;;LEADING BLANK - CALL @CH ;;AHEAD OF ADDRESS - POP H ;;HIGH BYTE TO A - MOV A,H - PUSH H ;;COPY BACK TO STACK - CALL @HX ;;WRITE HIGH BYTE - POP H - MOV A,L ;;LOW BYTE - JMP @HX ;;WRITE LOW BYTE -; -@IN: ;;READ HEX VALUE TO HL FROM CONSOLE - MVI A,' ' ;;LEADING SPACE - CALL @CH ;;TO CONSOLE - LXI H,0 ;;STARTING VALUE -@IN0: PUSH H ;;SAVE IT FOR CHAR READ - MVI C,RCHAR ;;READ CHARACTER FUNCTION - CALL BDOS ;;READ TO ACCUMULATOR - POP H ;;VALUE BEING BUILT IN HL - SUI '0' ;;NORMALIZE TO BINARY - CPI 10 ;;DECIMAL? - JC @IN1 ;;CARRY IF 0,1,...,9 -;; MAY BE HEXADECIMAL A,...,F - SUI 'A'-'0'-10 - CPI 16 ;;A THROUGH F? - RNC ;;RETURN WITH ASSUMED CR -@IN1: ;;IN RANGE, MULTIPLY BY 4 AND ADD - REPT 4 - DAD H ;;SHIFT 4 - ENDM - ORA L ;;ADD DIGIT - MOV L,A ;;AND REPLACE VALUE - JMP @IN0 ;;FOR ANOTHER DIGIT -;; -PSUB: -UGEN MACRO -;; REDEF TO INCLUDE ONCE - ENDM - UGEN ;;GENERATE FIRST TIME - ENDM -; ***************************************** -; * END OF TRACE/DUMP UTILITIES * -; * BEGIN TRACE(ONLY) UTILITIES * -; ***************************************** -TRACE MACRO CODE,MNAME -;; TRACE MACRO GIVEN BY MNAME, -;; AT LOCATION GIVEN BY CODE - LOCAL PSUB - UGEN ;;GENERATE UTILITIES - JMP PSUB -@T1: DS 2 ;;TEMP FOR REG-1 -@T2: DS 2 ;;TEMP FOR REG-2 -;; -@TR: ;;TRACE MACRO CALL -;; BC=CODE ADDRESS, DE=MESSAGE - SHLD @T1 ;;STORE TOP REG - POP H ;;RETURN ADDRESS - XTHL ;;REG-2 TO TOP - SHLD @T2 ;;STORE TO TEMP - PUSH PSW ;;SAVE FLAGS - PUSH B ;;SAVE RET ADDRESS - MVI C,WBUFF ;;PRINT BUFFER FUNC - CALL BDOS ;;PRINT MACRO NAME - POP H ;;CODE ADDRESS - CALL @AD ;;PRINTED - LHLD @T1 ;;TOP OF STACK - CALL @AD ;;PRINTED - LHLD @T2 ;;TOP-1 - CALL @AD ;;PRINTED - POP PSW ;;FLAGS RESTORED - POP D ;;RETURN ADDRESS - LHLD @T2 ;;TOP-1 - PUSH H ;;RESTORED - PUSH D ;;RETURN ADDRESS - LHLD @T1 ;;TOP OF STACK - RET -;; -PSUB: ;;PAST SUBROUTINES -;; -TRACE MACRO C,M -;; REDEFINED TRACE, USES @TR - LOCAL PMSG,MSG - JMP PMSG -MSG: DB CR,LF ;;CR,LF - DB '&M$' ;;MAC NAME -PMSG: - LXI B,C ;;CODE ADDRESS - LXI D,MSG ;;MACRO NAME - CALL @TR ;;TO TRACE IT - ENDM -;; BACK TO ORIGINAL MACRO LEVEL - TRACE CODE,MNAME - ENDM -; -TRT MACRO F -;; TURN ON FLAG "F" -DEBUG&F SET 1 ;;PRINT/TRACE ON - ENDM -; -TRF MACRO F -;; TURN OFF FLAG "F" -DEBUG&F SET 0 ;;TRACE/PRINT OFF - ENDM -; -?TR MACRO M -;; CHECK DEBUGT TOGGLE BEFORE TRACE - IF DEBUGT - TRACE %$,M - ENDM -; ***************************************** -; * END TRACE (ONLY) UTILITIES * -; * BEGIN DUMP(ONLY) UTILITIES * -; ***************************************** -DMP MACRO VNAME,N -;; DUMP VARIABLE VNAME FOR -;; N ELEMENTS (DOUBLE BYTES) - LOCAL PSUB ;;PAST SUBROUTINES - UGEN ;;GEN INLINE ROUTINES - JMP PSUB ;;PAST LOCAL SUBROUTINES -@DM: ;;DUMP UTILITY PROGRAM -;; DE=MSG ADDRESS, C=ELEMENT COUNT -;; HL=BASE ADDRESS TO PRINT - PUSH H ;;BASE ADDRESS - PUSH B ;;ELEMENT COUNT - MVI C,WBUFF ;;WRITE BUFFER FUNC - CALL BDOS ;;MESSAGE WRITTEN -@DM0: POP B ;;RECALL COUNT - POP H ;;RECALL BASE ADDRESS - MOV A,C ;;END OF LIST? - ORA A - RZ ;;RETURN IF SO - DCR C ;;DECREMENT COUNT - MOV E,M ;;NEXT ITEM (LOW) - INX H - MOV D,M ;;NEXT ITEM (HIGH) - INX H ;;READY FOR NEXT ROUND - PUSH H ;;SAVE PRINT ADDRESS - PUSH B ;;SAVE COUNT - XCHG ;;DATA READY - CALL @AD ;;PRINT ITEM VALUE - JMP @DM0 ;;FOR ANOTHER VALUE -;; -@DT: ;;DUMP TOP OF STACK ONLY - PRN <(TOP)=> ;;"(TOP)=" - PUSH H - CALL @AD ;;VALUE OF HL - POP H ;;TOP RESTORED - RET -;; -PSUB: -;; -DMP MACRO ?V,?N -;; REDEFINE DUMP TO USE @DM UTILITY - LOCAL PMSG,MSG -;; SPECIAL CASE IF NULL PARAMETERS - IF NUL VNAME -;; DUMP THE TOP OF THE STACK ONLY - CALL @DT - EXITM - ENDIF -;; OTHERWISE DUMP VARIABLE NAME - JMP PMSG -MSG: DB CR,LF ;;CRLF - DB '&?V=$' ;;MESSAGE -PMSG: ADR ?V ;;HL=ADDRESS -ACTIVE SET 0 ;;CLEAR ACTIVE FLAG - LXI D,MSG ;;MESSAGE TO PRINT - IF NUL ?N ;;USE LENGTH 1 - MVI C,1 - ELSE - MVI C,?N - ENDIF - CALL @DM ;;TO PERFORM THE DUMP - ENDM ;;END OF REDEFINITION - DMP VNAME,N - ENDM -; -; ***************************************** -; * END DUMP (ONLY) UTILITIES, * -; * BEGIN STACK MACHINE OPCODES * -; ***************************************** -ACTIVE SET 0 ;ACTIVE REGISTER FLAG -; -SIZ MACRO SIZE - ORG TRAN ;;SET TO TRANSIENT AREA -;; CREATE A STACK WHEN "XIT" ENCOUNTERED -@STK SET SIZE ;;SAVE FOR DATA AREA - LXI SP,STACK - ENDM -; -SAVE MACRO -;; CHECK TO ENSURE "ENTER" PROPERLY SET UP - IF STACK ;;IS IT PRESENT? - ENDIF -SAVE MACRO ;;REDEFINE AFTER INITIAL REFERENCE - IF ACTIVE ;;ELEMENT IN HL - PUSH H ;;SAVE IT - ENDIF -ACTIVE SET 1 ;;SET ACTIVE - ENDM - SAVE - ENDM -; -REST MACRO -;; RESTORE THE TOP ELEMENT - IF NOT ACTIVE - POP H ;;RECALL TO HL - ENDIF -ACTIVE SET 1 ;;MARK AS ACTIVE - ENDM -; -CLEAR MACRO -;; CLEAR THE TOP ACTIVE ELEMENT - REST ;;ENSURE ACTIVE -ACTIVE SET 0 ;;CLEARED - ENDM -; -DCL MACRO VNAME,SIZE -;; LABEL THE DECLARATION -VNAME: - IF NUL SIZE - DS 2 ;;ONE WORD REQ'D - ELSE - DS SIZE*2 ;;DOUBLE WORDS - ENDM -; -LIT MACRO VAL -;; LOAD LITERAL VALUE TO TOP OF STACK - SAVE ;;SAVE IF ACTIVE - LXI H,VAL ;;LOAD LITERAL - ?TR LIT - ENDM -; -ADR MACRO BASE,INX,CON -;; LOAD ADDRESS OF BASE, INDEXED BY INX, -;; WITH CONSTANT OFFSET GIVEN BY CON - SAVE ;;PUSH IF ACTIVE - IF NUL INX&CON - LXI H,BASE ;;ADDRESS OF BASE - EXITM ;;SIMPLE ADDRESS - ENDIF -;; MUST BE INX AND/OR CON - IF NUL INX - LXI H,CON*2 ;;CONSTANT - ELSE - LHLD INX ;;INDEX TO HL - DAD H ;;DOUBLE PRECISION INX - IF NOT NUL CON - LXI D,CON*2 ;;DOUBLE CONST - DAD D ;;ADDED TO INX - ENDIF ;;NOT NUL CON - ENDIF ;;NUL INX - LXI D,BASE ;;READY TO ADD - DAD D ;;BASE+INX*2+CON*2 - ENDM -; -VAL MACRO B,I,C -;; GET VALUE OF B+I+C TO HL -;; CHECK SIMPLE CASE OF B ONLY - IF NUL I&C - SAVE ;;PUSH IF ACTIVE - LHLD B ;;LOAD DIRECTLY - ELSE -;; "ADR" PUSHES ACTIVE REGISTERS - ADR B,I,C ;;ADDRESS IN HL - MOV E,M ;;LOW ORDER BYTE - INX H - MOV D,M ;;HIGH ORDER BYTE - XCHG ;;BACK TO HL - ENDIF - ?TR VAL ;;TRACE SET? - ENDM -; -STO MACRO B,I,C -;; STORE THE VALUE OF THE TOP OF STACK -;; LEAVING THE TOP ELEMENT ACTIVE - IF NUL I&C - REST ;;ACTIVATE STACK - SHLD B ;;STORED DIRECTLY TO B - ELSE - ADR B,I,C - POP D ;;VALUE IS IN DE - MOV M,E ;;LOW BYTE - INX H - MOV M,D ;;HIGH BYTE - ENDIF - CLEAR ;;MARK EMPTY - ?TR STO ;;TRACE? - ENDM -; -SUM MACRO - REST ;;RESTORE IF SAVED -;; ADD THE TOP TWO STACK ELEMENTS - POP D ;;TOP-1 TO DE - DAD D ;;BACK TO HL - ?TR SUM - ENDM -; -DIF MACRO -;; COMPUTE DIFFERENCE BETWEEN TOP ELEMENTS - REST ;;RESTORE IF SAVED - POP D ;;TOP-1 TO DE - MOV A,E ;;TOP-1 LOW BYTE TO A - SUB L ;;LOW ORDER DIFFERENCE - MOV L,A ;;BACK TO L - MOV A,D ;;TOP-1 HIGH BYTE - SBB H ;;HIGH ORDER DIFFERENCE - MOV H,A ;;BACK TO H -;; CARRY FLAG MAY BE SET UPON RETURN - ?TR DIF - ENDM -; -LSR MACRO LEN -;; LOGICAL SHIFT RIGHT BY LEN - REST ;;ACTIVATE STACK - REPT LEN ;;GENERATE INLINE - XRA A ;;CLEAR CARRY - MOV A,H - RAR ;;ROTATE WITH HIGH 0 - MOV H,A - MOV A,L - RAR - MOV L,A ;;BACK WITH HIGH BIT - ENDM - ENDM -; -GEQ MACRO LAB -;; JUMP TO LAB IF (TOP-1) IS GREATER OR -;; EQUAL TO (TOP) ELEMENT. - DIF ;;COMPUTE DIFFERENCE - CLEAR ;;CLEAR ACTIVE - ?TR GEQ - JNC LAB ;;NO CARRY IF GREATER - ORA H ;;BOTH BYTES ZERO? - JZ LAB ;;ZERO IF EQUAL -;; DROP THROUGH IF NEITHER - ENDM -; -DUP MACRO -;; DUPLICATE THE TOP ELEMENT IN THE STACK - REST ;;ENSURE ACTIVE - PUSH H - ?TR DUP - ENDM -; -BRN MACRO ADDR -;; BRANCH TO ADDRESS - JMP ADDR - ENDM -; -XIT MACRO - ?TR XIT ;;TRACE ON? - JMP 0 ;;RESTART AT 0000 - ORG DATA ;;START DATA AREA - DS @STK*2 ;;OBTAINED FROM "SIZ" -STACK: ENDM -; -; ***************************************** -; * MEMORY MAPPED I/O SECTION * -; ***************************************** -; INPUT VALUES WHICH ARE READ AS IF IN MEMORY -ADC0 EQU 1080H ;A-D CONVERTER 0 -ADC1 EQU 1082H ;A-D CONVERTER 1 -ADC2 EQU 1084H ;A-D CONVERTER 2 -ADC3 EQU 1086H ;A-D CONVERTER 3 -; -DAC0 EQU 1090H ;D-A CONVERTER 0 -DAC1 EQU 1092H ;D-A CONVERTER 1 -DAC2 EQU 1094H ;D-A CONVERTER 2 -DAC3 EQU 1096H ;D-A CONVERTER 3 -; -RWTRACE MACRO MSG,ADR -;; READ OR WRITE TRACE WITH MESSAGE -;; GIVEN BY "MSG" TO/FROM "ADR" - PRN - ENDM -; -RDM MACRO ?C -;; READ A-D CONVERTER NUMBER "?C" - SAVE ;;CLEAR THE STACK - IF DEBUGP ;;STOP EXECUTION IN DDT - RWTRACE ,% ADC&?C - UGEN ;;ENSURE @IN IS PRESENT - CALL @IN ;;VALUE TO HL - SHLD ADC&?C ;;SIMULATE MEMORY INPUT - ELSE -;; READ FROM MEMORY MAPPED INPUT ADDRESS - LHLD ADC&?C - ENDIF - ?TR RDM ;;TRACING? - ENDM -; -WRM MACRO ?C -;; WRITE D-A CONVERTER NUMBER "?C" - REST ;;RESTORE STACK - IF DEBUGP ;;TRACE THE OUTPUT - RWTRACE ,% DAC&?C - UGEN ;;INCLUDE SUBROUTINES - CALL @AD ;;WRITE THE VALUE - ENDIF - SHLD DAC&?C - ?TR WRM ;;TRACING OUTPUT? - CLEAR ;;REMOVE THE VALUE - ENDM -; ***************************************** -; * END OF MACRO LIBRARY * -; ***************************************** - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/I8085.LIB b/software/CPM/CPM11_MAC80/I8085.LIB deleted file mode 100644 index 5bd6bab..0000000 --- a/software/CPM/CPM11_MAC80/I8085.LIB +++ /dev/null @@ -1,17 +0,0 @@ -; INTEL 8085 MACRO LIBRARY -; -; THE SIM (SET INTERRUPT MASK), -; AND RIM (READ INTERRUPT MASK) -; ARE DEFINED BY THE FOLLOWING MACROS: -; -SIM MACRO -;; SET INTERRUPT MASK FROM REG-A VALUE - DB 30H ;;OPCODE FOR SIM - ENDM -; -RIM MACRO -;; READ INTERRUPT MASK TO REG-A - DB 20H ;;OPCODE FOR RIM - ENDM -; - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/INTER.LIB b/software/CPM/CPM11_MAC80/INTER.LIB deleted file mode 100644 index 47588b0..0000000 --- a/software/CPM/CPM11_MAC80/INTER.LIB +++ /dev/null @@ -1,80 +0,0 @@ -; MACRO LIBRARY FOR BASIC INTERSECTION -; -; GLOBAL DEFINITIONS FOR DEBUG PROCESSING -TRUE EQU 0FFFFH ;VALUE OF TRUE -FALSE EQU NOT TRUE;VALUE OF FALSE -DEBUG SET FALSE ;INITIALLY FALSE -BDOS EQU 5 ;ENTRY TO CP/M BDOS -RCHAR EQU 1 ;READ CHARACTER FUNCTION -WBUFF EQU 9 ;WRITE BUFFER FUNCTION -CR EQU 0DH ;CARRIAGE RETURN -LF EQU 0AH ;LINE FEED -; -; INPUT/OUTPUT PORTS FOR LIGHT AND CLOCK -LIGHT EQU 00H ;TRAFFIC LIGHT CONTROL -CLOCK EQU 03H ;24 HOUR CLOCK (0,1,...,23) -; -; BIT POSITIONS FOR TRAFFIC LIGHT CONTROL -NSBITS EQU 4 ;NORTH SOUUTH BITS -EWBITS EQU 0 ;EAST WEST BITS -; -; CONSTANT VALUES FOR THE LIGHT CONTROL -OFF EQU 0 ;TURN LIGHT OFF -RED EQU 1 ;VALUE FOR RED LIGHT -YELLOW EQU 2 ;VALUE FOR YELLOW LIGHT -GREEN EQU 3 ;GREEN LIGHT -; -SETLITE MACRO DIR,COLOR -;; SET LIGHT GIVEN BY "DIR" TO COLOR GIVEN BY "COLOR" - IF DEBUG ;;PRINT INFO AT CONSOLE - LOCAL SETMSG,PASTMSG - MVI C,WBUFF ;;WRITE BUFFER FUNCTION - LXI D,SETMSG - CALL BDOS ;;WRITE THE TRACE INFO - JMP PASTMSG -SETMSG: DB CR,LF - DB '&DIR CHANGING TO &COLOR$' -PASTMSG: - EXITM - ENDIF - MVI A,COLOR SHL DIR&BITS ;;READIED - OUT LIGHT ;;SENT IN PROPER BIT POSITION - ENDM -; -TIMER MACRO SECONDS -;; CONSTRUCT INLINE TIME-OUT LOOP - LOCAL T1,T2,T3 ;;LOOP ENTRIES - MVI D,4*SECONDS ;;BASIC LOOP CONTROL -T1: MVI B,250 ;;250MSEC *4 = 1 SEC -T2: MVI C,182 ;;182*5.5USEC = 1MSEC -T3: DCR C ;;1 CY = .5 USEC - JNZ T3 ;;+10 CY = 5.5 USEC - DCR B ;;COUNT 250,249... - JNZ T2 ;;LOOP ON B REGISTER - DCR D ;;BASIC LOOP CONTROL - JNZ T1 ;;LOOP ON D REGISTER -;; ARRIVE HERE WITH APPROXIMATELY "SECONDS" -;; TIMEOUT, CONTINUE PROCESSING. - ENDM -; -CLOCK? MACRO LOW,HIGH,IFTRUE -;; CHECK FOR REAL-TIME CLOCK GREATER THAN OR -;; EQUAL TO "LOW." AND LESS THAN "HIGH." -;; CONTINUE AT "IFTRUE" WHEN BETWEEN THESE -;; TIMES. - LOCAL IFFALSE ;;ALTERNATE TO TRUE CASE - IN CLOCK ;;READ REAL-TIME CLOCK - IF NOT NUL HIGH ;;CHECK HIGH CLOCK - CPI HIGH ;;EQUAL OR GREATER? - JNC IFFALSE ;;SKIP TO END IF SO - ENDIF - CPI LOW ;;LESS THAN LOW VALUE? - JNC IFTRUE ;;SKIP TO LABEL IF NOT -IFFALSE: - ENDM -; -RETRY MACRO GOLABEL -;; CONTINUE EXECUTION AT "GOLABEL" - JMP GOLABEL - ENDM - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/MAC.COM b/software/CPM/CPM11_MAC80/MAC.COM deleted file mode 100644 index cb0ac80..0000000 Binary files a/software/CPM/CPM11_MAC80/MAC.COM and /dev/null differ diff --git a/software/CPM/CPM11_MAC80/NCOMPARE.LIB b/software/CPM/CPM11_MAC80/NCOMPARE.LIB deleted file mode 100644 index c092361..0000000 --- a/software/CPM/CPM11_MAC80/NCOMPARE.LIB +++ /dev/null @@ -1,77 +0,0 @@ -; MACRO LIBRARY FOR 8-BIT COMPARISON OPERATION -; -TEST? MACRO X,Y -;; UTILTITY MACRO TO GENERATE CONDITION CODES - IF NOT NUL X ;;THEN LOAD X - LDA X ;;X ASSUMED TO BE IN MEMORY - ENDIF - IRPC ?Y,Y ;;Y MAY BE CONSTANT OPERAND -TDIG? SET '&?Y'-'0' ;;FIRST CHAR DIGIT? - EXITM ;;STOP IRPC AFTER FIRST CHAR - ENDM - IF TDIG? <= 9 ;;Y NUMERIC? - SUI Y ;;YES, SO SUB IMMEDIATE - ELSE - LXI H,Y ;;Y NOT NUMERIC - SUB M ;;SO SUB FROM MEMORY - ENDM -; -LSS MACRO X,Y,TL,FL -;; X LSS THAN Y TEST, -;; IF TL IS PRESENT, ASSUME TRUE TEST -;; IF TL IS ABSENT, THEN INVERT TEST - IF NUL TL - GEQ X,Y,FL - ELSE - TEST? X,Y ;;SET CONDITION CODES - JC TL - ENDM -; -LEQ MACRO X,Y,TL,FL -;; X LESS THAN OR EQUAL TO Y TEST - IF NUL TL - GEQ X,Y,FL - ELSE - LSS X,Y,TL - JZ TL - ENDM -; -EQL MACRO X,Y,TL,FL -;; X EQUAL TO Y TEST - IF NUL TL - NEQ X,Y,FL - ELSE - TEST? X,Y - JZ TL - ENDM -; -NEQ MACRO X,Y,TL,FL -;; X NOT EQUAL TO Y TEST - IF NUL TL - EQL X,Y,FL - ELSE - TEST? X,Y - JNZ TL - ENDM -; -GEQ MACRO X,Y,TL,FL -;; X GREATER THAN OR EQUAL TO Y TEST - IF NUL TL - LSS X,Y,FL - ELSE - TEST? X,Y - JNC TL - ENDM -; -GTR MACRO X,Y,TL,FL -;; X GREATER THAN Y TEST - IF NUL TL - LEQ X,Y,FL - ELSE - LOCAL GFL ;;FALSE LABEL - TEST? X,Y - JC GFL - DCR A - JNC TL -GFL: ENDM - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/NSWP.COM b/software/CPM/CPM11_MAC80/NSWP.COM deleted file mode 100644 index 00af4f5..0000000 Binary files a/software/CPM/CPM11_MAC80/NSWP.COM and /dev/null differ diff --git a/software/CPM/CPM11_MAC80/PIP.COM b/software/CPM/CPM11_MAC80/PIP.COM deleted file mode 100644 index b03787d..0000000 Binary files a/software/CPM/CPM11_MAC80/PIP.COM and /dev/null differ diff --git a/software/CPM/CPM11_MAC80/READ.ME b/software/CPM/CPM11_MAC80/READ.ME deleted file mode 100644 index 8d26568..0000000 --- a/software/CPM/CPM11_MAC80/READ.ME +++ /dev/null @@ -1,2 +0,0 @@ -This is the Digital Research MAC, macro assembler. - diff --git a/software/CPM/CPM11_MAC80/SAMPLE.ASM b/software/CPM/CPM11_MAC80/SAMPLE.ASM deleted file mode 100644 index a09b450..0000000 --- a/software/CPM/CPM11_MAC80/SAMPLE.ASM +++ /dev/null @@ -1,11 +0,0 @@ - ORG 100H ;TRANSIENT PROGRAM AREA -BDOS EQU 0005H ;BDOS ENTRY POINT -WCHAR EQU 2 ;WRITE CHARACTER FUNCTION -; ENTER WITH CCP'S RETURN ADDRESS IN THE STACK -; WRITE A SINGLE CHARACTER (?) AND RETURN - MVI C,WCHAR ;WRITE CHARACTER FUNCTION - MVI C,'?' ;CHARACTER TO WRITE - CALL BDOS ;WRITE THE CHARACTER - RET ;RETURN TO THE CCP - END 100H ;START ADDRESS IS 100H - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/SELECT.LIB b/software/CPM/CPM11_MAC80/SELECT.LIB deleted file mode 100644 index 28df1f8..0000000 --- a/software/CPM/CPM11_MAC80/SELECT.LIB +++ /dev/null @@ -1,74 +0,0 @@ -; MACRO LIBRARY FOR "SELECT" CONSTRUCT -; -; LABEL GENERATORS -GENSLXI MACRO NUM -;; LOAD HL WITH ADDRESS OF CASE LIST - LXI H,SELV&NUM - ENDM -; -GENCASE MACRO NUM,ELT -;; GENERATE JMP TO END OF CASES - IF ELT GT 0 - JMP ENDS&NUM ;;PAST ADDR LIST - ENDIF -;; GENERATE LABEL FOR THIS CASE -CASE&NUM&@&ELT: - ENDM -; -GENELT MACRO NUM,ELT -;; GENERATE ONE ELEMENT OF CASE LIST - DW CASE&NUM&@&ELT - ENDM -; -GENSLAB MACRO NUM,ELTS -;; GENERATE CASE LIST -SELV&NUM: -ECNT SET 0 ;;COUNT ELEMENTS - REPT ELTS ;;GENERATE DW'S - GENELT NUM,%ECNT -ECNT SET ECNT+1 - ENDM ;;END OF DW'S -;; GENERATE END OF CASE LIST LABEL -ENDS&NUM: - ENDM -; -SELNEXT MACRO -;; GENERATE THE NEXT CASE - GENCASE %CCNT,%ECNT -;; INCREMENT THE CASE ELEMENT COUNT -ECNT SET ECNT+1 - ENDM -; -SELECT MACRO VAR -;; GENERATE CASE SELECTION CODE -CCNT SET 0 ;;COUNT "SELECTS" -SELECT MACRO V ;;REDEFINITION OF SELECT -;; SELECT ON V OR ACCUMULATOR CONTENTS - IF NOT NUL V - LDA V ;;LOAD SELECT VARIABLE - ENDIF - GENSLXI %CCNT ;;GENERATE THE LXI H,SELV# - MOV E,A ;;CREATE DOUBLE PRECISION - MVI D,0 ;;V IN D,E PAIR - DAD D ;;SINGLE PREC INDEX - DAD D ;;DOUBLE PREC INDEX - MOV E,M ;;LOW ORDER BRANCH ADDR - INX H ;;TO HIGH ORDER BYTE - MOV D,M ;;HIGH ORDER BRANCH INDEX - XCHG ;;READY BRANCH ADDRESS IN HL - PCHL ;;GONE TO THE PROPER CASE -ECNT SET 0 ;;ELEMENT COUNTER RESET - SELNEXT ;;SELECT CASE 0 - ENDM -;; INVOKE REDEFINED SELECT THE FIRST TIME - SELECT VAR - ENDM -; -ENDSEL MACRO -;; END OF SELECT, GENERATE CASE LIST - GENCASE %CCNT,%ECNT ;;LAST CASE - GENSLAB %CCNT,%ECNT ;;CASE LIST -;; INCREMENT "SELECT" COUNT -CCNT SET CCNT+1 - ENDM - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/SEQIO.LIB b/software/CPM/CPM11_MAC80/SEQIO.LIB deleted file mode 100644 index 7fd4bf5..0000000 --- a/software/CPM/CPM11_MAC80/SEQIO.LIB +++ /dev/null @@ -1,439 +0,0 @@ -; SEQUENTIAL FILE I/O LIBRARY -; -FILERR SET 0000H ;REBOOT AFTER ERROR -@BDOS EQU 0005H ;BDOS ENTRY POINT -@TFCB EQU 005CH ;DEFAULT FILE CONTROL BLOCK -@TBUF EQU 0080H ;DEFAULT BUFFER ADDRESS -; -; BDOS FUNCTIONS -@MSG EQU 9 ;SEND MESSAGE -@OPN EQU 15 ;FILE OPEN -@CLS EQU 16 ;FILE CLOSE -@DIR EQU 17 ;DIRECTORY SEARCH -@DEL EQU 19 ;FILE DELETE -@FRD EQU 20 ;FILE READ OPERATION -@FWR EQU 21 ;FILE WRITE OPERATION -@MAK EQU 22 ;FILE MAKE -@REN EQU 23 ;FILE RENAME -@DMA EQU 26 ;SET DMA ADDRESS -; -@SECT EQU 128 ;SECTOR SIZE -EOF EQU 1AH ;END OF FILE -CR EQU 0DH ;CARRIAGE RETURN -LF EQU 0AH ;LINE FEED -TAB EQU 09H ;HORIZONTAL TAB -; -@KEY EQU 1 ;KEYBOARD -@CON EQU 2 ;CONSOLE DISPLAY -@RDR EQU 3 ;READER -@PUN EQU 4 ;PUNCH -@LST EQU 5 ;LIST DEVICE -; -; KEYWORDS FOR "FILE" MACRO -INFILE EQU 1 ;INPUT FILE -OUTFILE EQU 2 ;OUTPUTFILE -SETFILE EQU 3 ;SETUP NAME ONLY -; -; THE FOLLOWING MACROS DEFINE SIMPLE SEQUENTIAL -; FILE OPERATIONS: -; -FILLNAM MACRO FC,C -;; FILL THE FILE NAME/TYPE GIVEN BY FC FOR C CHARACTERS -@CNT SET C ;;MAX LENGTH - IRPC ?FC,FC ;;FILL EACH CHARACTER -;; MAY BE END OF COUNT OR NUL NAME - IF @CNT=0 OR NUL ?FC - EXITM - ENDIF - DB '&?FC' ;;FILL ONE MORE -@CNT SET @CNT-1 ;;DECREMENT MAX LENGTH - ENDM ;;OF IRPC ?FC -;; -;; PAD REMAINDER - REPT @CNT ;;@CNT IS REMAINDER - DB ' ' ;;PAD ONE MORE BLANK - ENDM ;;OF REPT - ENDM -; -FILLDEF MACRO FCB,?FL,?LN -;; FILL THE FILE NAME FROM THE DEFAULT FCB -;; FOR LENGTH ?LN (9 OR 12) - LOCAL PSUB - JMP PSUB ;;JUMP PAST THE SUBROUTINE -@DEF: ;;THIS SUBROUTINE FILLS FROM THE TFCB (+16) - MOV A,M ;;GET NEXT CHARACTER TO A - STAX D ;;STORE TO FCB AREA - INX H - INX D - DCR C ;;COUNT LENGTH DOWN TO 0 - JNZ @DEF - RET -;; END OF FILL SUBROUTINE -PSUB: -FILLDEF MACRO ?FCB,?F,?L - LXI H,@TFCB+?F ;;EITHER @TFCB OR @TFCB+16 - LXI D,?FCB - MVI C,?L ;;LENGTH = 9,12 - CALL @DEF - ENDM - FILLDEF FCB,?FL,?LN - ENDM -; -FILLNXT MACRO -;; INITIALIZE BUFFER AND DEVICE NUMBERS -@NXTB SET 0 ;;NEXT BUFFER LOCATION -@NXTD SET @LST+1 ;;NEXT DEVICE NUMBER -FILLNXT MACRO - ENDM - ENDM -; -FILLFCB MACRO FID,DN,FN,FT,BS,BA -;; FILL THE FILE CONTROL BLOCK WITH DISK NAME -;; FID IS AN INTERNAL NAME FOR THE FILE, -;; DN IS THE DRIVE NAME (A,B..), OR BLANK -;; FN IS THE FILE NAME, OR BLANK -;; FT IS THE FILE TYPE -;; BS IS THE BUFFER SIZE -;; BA IS THE BUFFER ADDRESS - LOCAL PFCB -;; -;; SET UP THE FILE CONTROL BLOCK FOR THE FILE -;; LOOK FOR FILE NAME = 1 OR 2 -@C SET 1 ;;ASSUME TRUE TO BEGIN WITH - IRPC ?C,FN ;;LOOK THROUGH CHARACTERS OF NAME - IF NOT ('&?C' = '1' OR '&?C' = '2') -@C SET 0 ;;CLEAR IF NOT 1 OR 2 - ENDM -;; @C IS TRUE IF FN = 1 OR 2 AT THIS POINT - IF @C ;;THEN FN = 1 OR 2 -;; FILL FROM DEFAULT AREA - IF NUL FT ;;TYPE SPECIFIED? -@C SET 12 ;;BOTH NAME AND TYPE - ELSE -@C SET 9 ;;NAME ONLY - ENDIF - FILLDEF FCB&FID,(FN-1)*16,@C ;;TO SELECT THE FCB - JMP PFCB ;;PAST FCB DEFINITION - DS @C ;;SPACE FOR DRIVE/FILENAME/TYPE - FILLNAM FT,12-@C ;;SERIES OF DB'S - ELSE - JMP PFCB ;;PAST INITIALIZED FCB - IF NUL DN - DB 0 ;;USE DEFAULT DRIVE IF NAME IS ZERO - ELSE - DB '&DN'-'A'+1 ;;USE SPECIFIED DRIVE - ENDIF - FILLNAM FN,8 ;;FILL FILE NAME -;; NOW GENERATE THE FILE TYPE WITH PADDED BLANKS - FILLNAM FT,3 ;;AND THREE CHARACTER TYPE - ENDIF -FCB&FID EQU $-12 ;;BEGINNING OF THE FCB - DB 0 ;;EXTENT FIELD 00 FOR SETFILE -;; NOW DEFINE THE 3 BYTE FIELD, AND DISK MAP - DS 20 ;;X,X,RC,DM0...DM15,CR FIELDS -;; - IF FID&TYP<=2 ;;IN/OUTFILE -;; GENERATE CONSTANTS FOR INFILE/OUTFILE - FILLNXT ;;@NXTB=0 ON FIRST CALL - IF BS+0<@SECT -;; BS NOT SUPPLIED, OR TOO SMALL -@BS SET @SECT ;;DEFAULT TO ONE SECTOR - ELSE -;; COMPUTE EVEN BUFFER ADDRESS -@BS SET (BS/@SECT)*@SECT - ENDIF -;; -;; NOW DEFINE BUFFER BASE ADDRESS - IF NUL BA -;; USE NEXT ADDRESS AFTER @NXTB -FID&BUF SET BUFFERS+@NXTB -;; COUNT PAST THIS BUFFER -@NXTB SET @NXTB+@BS - ELSE -FID&BUF SET BA - ENDIF -;; FID&BUF IS BUFFER ADDRESS -FID&ADR: - DW FID&BUF -;; -FID&SIZ EQU @BS ;;LITERAL SIZE -FID&LEN: - DW @BS ;;BUFFER SIZE -FID&PTR: - DS 2 ;;SET IN INFILE/OUTFILE -;; SET DEVICE NUMBER -@&FID SET @NXTD ;;NEXT DEVICE -@NXTD SET @NXTD+1 - ENDIF ;;OF FID&TYP<=2 TEST -PFCB: ENDM -; -FILE MACRO MD,FID,DN,FN,FT,BS,BA -;; CREATE FILE USING MODE MD: -;; INFILE = 1 INPUT FILE -;; OUTFILE = 2 OUTPUT FILE -;; SETFILE = 3 SETUP FCB -;; (SEE FILLFCB FOR REMAINING PARAMETERS) - LOCAL PSUB,MSG,PMSG - LOCAL PND,EOD,EOB,PNC -;; CONSTRUCT THE FILE CONTROL BLOCK -;; -FID&TYP EQU MD ;;SET MODE FOR LATER REF'S - FILLFCB FID,DN,FN,FT,BS,BA - IF MD=3 ;;SETUP FCB ONLY, SO EXIT - EXITM - ENDIF -;; FILE CONTROL BLOCK AND RELATED PARAMETERS -;; ARE CREATED INLINE, NOW CREATE IO FUNCTION - JMP PSUB ;;PAST INLINE SUBROUTINE - IF MD=1 ;;INPUT FILE -GET&FID: - ELSE -PUT&FID: - PUSH PSW ;;SAVE OUTPUT CHARACTER - ENDIF - LHLD FID&LEN ;;LOAD CURRENT BUFFER LENGTH - XCHG ;;DE IS LENGTH - LHLD FID&PTR ;;LOAD NEXT TO GET/PUT TO HL - MOV A,L ;;COMPUTE CUR-LEN - SUB E - MOV A,H - SBB D ;;CARRY IF NEXT -;; SKIP ALL BUT OUTPUT FILES - IF ?F&TYP=2 - LOCAL EOB?,PEOF,MSG,PMSG -;; WRITE ALL PARTIALLY FILLED BUFFERS -EOB?: ;;ARE WE AT THE END OF A BUFFER? - LHLD ?F&PTR ;;NEXT TO FILL - MOV A,L ;;ON BUFFER BOUNDARY? - ANI (@SECT-1) AND 0FFH - JNZ PEOF ;;PUT EOF IF NOT 00 - IF @SECT>255 -;; CHECK HIGH ORDER BYTE ALSO - MOV A,H - ANI (@SECT-1) SHR 8 - JNZ PEOF ;;PUT EOF IF NOT 00 - ENDIF -;; ARRIVE HERE IF END OF BUFFER, SET LENGTH -;; AND WRITE ONE MORE BYTE TO CLEAR BUFFS - SHLD ?F&LEN ;;SET TO SHORTER LENGTH -PEOF: MVI A,EOF ;;WRITE ANOTHER EOF - PUSH PSW ;;SAVE ZERO FLAG - CALL PUT&?F - POP PSW ;;RECALL ZERO FLAG - JNZ EOB? ;;NON ZERO IF MORE -;; BUFFERS HAVE BEEN WRITTEN, CLOSE FILE - MVI C,@CLS - LXI D,FCB&?F ;;READY FOR CALL - CALL @BDOS - INR A ;;255 IF ERR BECOMES 00 - JNZ PMSG -;; FILE CANNOT BE CLOSED - MVI C,@MSG - LXI D,MSG - CALL @BDOS - JMP PMSG ;;ERROR MESSAGE PRINTED -MSG: DB CR,LF - DB 'CANNOT CLOSE &?F' - DB '$' -PMSG: - ENDIF - ENDM ;;OF THE IRP - ENDM -; -ERASE MACRO FID -;; DELETE THE FILE(S) GIVEN BY FID - IRP ?F, - MVI C,@DEL - LXI D,FCB&?F - CALL @BDOS - ENDM ;;OF THE IRP - ENDM -; -DIRECT MACRO FID -;; PERFORM DIRECTORY SEARCH FOR FILE -;; SETS ZERO FLAG IF NOT PRESENT - LXI D,FCB&FID - MVI C,@DIR - CALL @BDOS - INR A ;00 IF NOT PRESENT - ENDM -; -RENAME MACRO NEW,OLD -;; RENAME FILE GIVEN BY "OLD" TO "NEW" - LOCAL PSUB,REN0 -;; INCLUDE THE RENAME SUBROUTINE ONCE - JMP PSUB -@RENS: ;;RENAME SUBROUTINE, HL IS ADDRESS OF - ;;OLD FCB, DE IS ADDRESS OF NEW FCB - PUSH H ;;SAVE FOR RENAME - LXI B,16 ;;B=00,C=16 - DAD B ;;HL = OLD FCB+16 -REN0: LDAX D ;;NEW FCB NAME - MOV M,A ;;TO OLD FCB+16 - INX D ;;NEXT NEW CHAR - INX H ;;NEXT FCB CHAR - DCR C ;;COUNT DOWN FROM 16 - JNZ REN0 -;; OLD NAME IN FIRST HALF, NEW IN SECOND HALF - POP D ;;RECALL BASE OF OLD NAME - MVI C,@REN ;;RENAME FUNCTION - CALL @BDOS - RET ;;RENAME COMPLETE -PSUB: -RENAME MACRO N,O ;;REDEFINE RENAME - LXI H,FCB&O ;;OLD FCB ADDRESS - LXI D,FCB&N ;;NEW FCB ADDRESS - CALL @RENS ;;RENAME SUBROUTINE - ENDM - RENAME NEW,OLD - ENDM -; -GET MACRO DEV -;; READ CHARACTER FROM DEVICE - IF @&DEV <= @LST -;; SIMPLE INPUT - MVI C,@&DEV - CALL @BDOS - ELSE - CALL GET&DEV - ENDM -; - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/SIMPIO.LIB b/software/CPM/CPM11_MAC80/SIMPIO.LIB deleted file mode 100644 index 33fdb15..0000000 --- a/software/CPM/CPM11_MAC80/SIMPIO.LIB +++ /dev/null @@ -1,26 +0,0 @@ -; MACRO LIBRARY FOR SIMPLE I/O -BDOS EQU 0005H ;BDOS ENTRY -CONIN EQU 1 ;CONSOLE INPUT FUNCTION -MSGOUT EQU 9 ;PRINT MESSAGE TIL $ -CR EQU 0DH ;CARRIAGE RETURN -LF EQU 0AH ;LINE FEED -; -READ MACRO VAR -;; READ A SINGLE CHARACTER INTO VAR - MVI C,CONIN ;CONSOLE INPUT FUNCTION - CALL BDOS ;CHARACTER IS IN A - STA VAR - ENDM -; -WRITE MACRO MSG -;; WRITE MESSAGE TO CONSOLE - LOCAL MSGL,PMSG - JMP PMSG -MSGL: DB CR,LF ;;LEADING CRLF - DB '&MSG' ;;INLINE MESSAGE - DB '$' ;;MESSAGE TERMINATOR -PMSG: MVI C,MSGOUT ;;PRINT MESSAGE TIL $ - LXI D,MSGL - CALL BDOS - ENDM - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/STACK.LIB b/software/CPM/CPM11_MAC80/STACK.LIB deleted file mode 100644 index af7f8e4..0000000 --- a/software/CPM/CPM11_MAC80/STACK.LIB +++ /dev/null @@ -1,56 +0,0 @@ -SIZ MACRO SIZE -;; SET "ORG" AND CREATE STACK - LOCAL STACK ;;LABEL ON THE STACK - ORG 100H ;;AT BASE OF TPA - LXI SP,STACK - JMP STACK ;;PAST STACK - DS SIZE*2 ;;DOUBLE PRECISION -STACK: ENDM -; -DUP MACRO -;; DUPLICATE TOP OF STACK - PUSH H - ENDM -; -SUM MACRO -;; ADD THE TOP TWO STACK ELEMENTS - POP D ;;TOP-1 TO DE - DAD D ;;BACK TO HL - ENDM -; -LSR MACRO LEN -;; LOGICAL SHIFT RIGHT BY LEN - REPT LEN ;;GENERATE INLINE - XRA A ;;CLEAR CARRY - MOV A,H - RAR ;;ROTATE WITH HIGH 0 - MOV H,A - MOV A,L - RAR - MOV L,A ;;BACK WITH HIGH BIT - ENDM - ENDM -; -ADC0 EQU 1080H ;A-D CONVERTER 0 -ADC1 EQU 1082H ;A-D CONVERTER 1 -ADC2 EQU 1084H ;A-D CONVERTER 2 -ADC3 EQU 1086H ;A-D CONVERTER 3 -; -DAC0 EQU 1090H ;D-A CONVERTER 0 -DAC1 EQU 1092H ;D-A CONVERTER 1 -DAC2 EQU 1094H ;D-A CONVERTER 2 -DAC3 EQU 1096H ;D-A CONVERTER 3 -; -RDM MACRO ?C -;; READ A-D CONVERTER NUMBER "?C" - PUSH H ;;CLEAR THE STACK -;; READ FROM MEMORY MAPPED INPUT ADDRESS - LHLD ADC&?C - ENDM -; -WRM MACRO ?C -;; WRITE D-A CONVERTER NUMBER "?C" - SHLD DAC&?C ;;VALUE WRITTEN - POP H ;;RESTORE STACK - ENDM - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/TREADLES.LIB b/software/CPM/CPM11_MAC80/TREADLES.LIB deleted file mode 100644 index eb13a1e..0000000 --- a/software/CPM/CPM11_MAC80/TREADLES.LIB +++ /dev/null @@ -1,21 +0,0 @@ -; MACRO LIBRARY FOR STREET TREADLES -; -TRINP EQU 01H ;TREADLE INPUT PORT -TROUT EQU 01H ;TREADLE OUTPUT PORT -; -TREAD? MACRO TR,IFTRUE -;; "TREAD?" IS INVOKED TO CHECK IF -;; TREADLE GIVEN BY TR HAS BEEN SENSED. -;; IF SO, THE LATCH IS CLEARED AND CONTROL -;; TRANSFERS TO THE LABEL "IFTRUE" - LOCAL IFFALSE ;;IN CASE NOT SET -;; - IN TRINP ;;READ TREADLE SWITCHES - ANI 1 SHL TR ;;MASK PROPER BIT - JZ IFFALSE ;;SKIP RESET IF 0 - MVI A,1 SHL TR ;;TO RESET THE BIT - OUT TROUT ;;CLEAR IT - JMP IFTRUE ;;GO TO TRUE LABEL -IFFALSE: - ENDM - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/WHEN.LIB b/software/CPM/CPM11_MAC80/WHEN.LIB deleted file mode 100644 index c4651dd..0000000 --- a/software/CPM/CPM11_MAC80/WHEN.LIB +++ /dev/null @@ -1,36 +0,0 @@ -; MACRO LIBRARY FOR "WHEN" CONSTRUCT -; -; "WHEN" COUNTERS -; LABEL GENERATORS -GENWTST MACRO TST,X,Y,NUM -;; GENERATE A "WHEN" TEST (NEGATED FORM), -;; INVOKE MACRO "TST" WITH PARAMETERS -;; X,Y WITH JUMP TO ENDW & NUM - TST X,Y,,ENDW&NUM - ENDM -; -GENLAB MACRO LAB,NUM -;; PRODUCE THE LABEL "LAB" & "NUM" -LAB&NUM: - ENDM -; -; "WHEN" MACROS FOR START AND END -; -WHEN MACRO XV,REL,YV -;; INITIALIZE COUNTERS FIRST TIME -WCNT SET 0 ;;NUMBER OF WHENS -WHEN MACRO X,R,Y - GENWTST R,X,Y,%WCNT -WLEV SET WCNT ;;NEXT ENDW TO GENERATE -WCNT SET WCNT+1 ;;NUMBER OF "WHEN"S - ENDM - WHEN XV,REL,YV - ENDM -; -ENDW MACRO -;; GENERATE THE ENDING CODE FOR A "WHEN" - GENLAB ENDW,%WLEV -WLEV SET WLEV-1 ;;COUNT CURRENT LEVEL DOWN -;; WLEV MUST NOT GO BELOW 0 (NOT CHECKED) - ENDM - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/Z80.DOC b/software/CPM/CPM11_MAC80/Z80.DOC deleted file mode 100644 index a16455b..0000000 --- a/software/CPM/CPM11_MAC80/Z80.DOC +++ /dev/null @@ -1,402 +0,0 @@ - Z-80 Macro Library Documentation - -------------------------------- - -I. - The purpose of this library is to enable the assembly of the Z-80 - instruction set on a CP/M sytem using the CP/M MAC macro assembler. - - This library is invoked with the pseudo-op: - - " MACLIB Z80 " - -II. - The following symbols and notations are used in the individual macro - descriptions; - - r - Any of the 8 bit registers: A, B, C, D, E, H, L, or M - rr - Any of the 16 bit register pairs: BC, DE, HL, or SP - nn - 8 bit immediate data (0 through 255) - d - 8 bit signed displacment (-128 through +127) - nnnn - 16 bit address or immediate data (0 through 65535) - b - bit number (0-7, 7 is most significant, 0 is least) - addr - 16 bit address within PC+127 through PC-128 - m(zzz) - Memory at address "zzz" - -III. - - MACLIB ver. Zilog ver TDL ver --------------- ------------- ------------- - -LDX r,d LD r,(IX+d) MOV r,d(IX) - Load register from indexed memory (with IX) - -LDY r,d LD r,(IY+d) MOV r,d(IY) - Load register from indexed memory (with IY) - -STX r,d LD (IX+d),r MOV d(IX),r - Store register to indexed memory (with IX) - -STY r,d LD (IY+d),r MOV d(IY),r - Store register to indexed memory (with IY) - -MVIX nn,d LD (IX+d),nn MVI d(IX) - Move immediate to indexed memory (with IX) - -MVIY nn,d LD (IY+d),nn MVI d(IY) - Move immediate to indexed memory (with IY) - -LDAI LD A,I LDAI - Move I to A - -LDAR LD A,R LDAR - Move R to A - -STAI LD I,A STAI - Move A to I - -STAR LD R,A STAR - Move A to R - -LXIX nnnn LD IX,nnnn LXI IX,nnnn - Load IX immediate (16 bits) - -LXIY nnnn LD IY,nnnn LXI IY,nnnn - Load IY immediate (16 bits) - -LBCD nnnn LD BC,(nnnn) LBCD nnnn - Load BC direct (from memory at nnnn) - -LDED nnnn LD DE,(nnnn) LDED nnnn - Load DE direct - -LSPD nnnn LD SP,(nnnn) LSPD nnnn - Load SP direct - -LIXD nnnn LD IX,(nnnn) LIXD nnnn - Load IX direct - -LIYD nnnn LD IY,(nnnn) LIYD nnnn - Load IY direct - -SBCD nnnn LD (nnnn),BC SBCD nnnn - Store BC direct (to memory at nnnn) - -SDED nnnn LD (nnnn),DE SDED nnnn - Store DE direct - -SSPD nnnn LD (nnnn),SP SSPD nnnn - Store SP direct - -SIXD nnnn LD (nnnn),IX SIXD nnnn - Store IX direct - -SIYD nnnn LD (nnnn),IY SIYD nnnn - Store IY direct - -SPIX LD SP,IX SPIX - Copy IX to the SP - -SPIY LD SP,IY SPIY - Copy IY to the SP - -PUSHIX PUSH IX PUSH IX - Push IX into the stack - -PUSHIY PUSH IY PUSH IY - Push IY into the stack - -POPIX POP IX POP IX - Pop IX from the stack - -POPIY POP IY POP IY - Pop IY from the stack - -EXAF EX AF,AF' EXAF - Exchange AF and the alternate, AF' - -EXX EXX EXX - Exchange BC DE HL with BC' DE' HL' - -XTIX EX (SP),IX XTIX - Exchange IX with the top of the stack - -XTIY EX (SP),IY XTIY - Exchange IY with the top of the stack - -LDI LDI LDI - Move m(HL) to m(DE), increment DE and HL, decrement BC - -LDIR LDIR LDIR - Repeat LDI until BC = 0 - -LDD LDD LDD - Move m(HL) to m(DE), decrement HL, DE, and BC - -LDDR LDDR LDDR - Repeat LDD until BC = 0 - -CCI CPI CCI - Compare A with m(HL), increment HL, decrement BC - -CCIR CPIR CCIR - Repeat CCI until BC = 0 or A = m(HL) - -CCD CPD CCD - Compare A with m(HL), decrement HL and BC - -CCDR CPDR CCDR - Repeat CCD until BC = 0 or A = m(HL) - -ADDX d ADD (IX+d) ADD d(IX) - Indexed add to A - -ADDY d ADD (IY+d) ADD d(IY) - Indexed add to A - -ADCX d ADC (IX+d) ADC d(IX) - Indexed add with carry - -ADCY d ADC (IY+d) ADC d(IY) - Indexed add with carry - -SUBX d SUB (IX+d) SUB d(IX) - Indexed subtract - -SUBY d SUB (IY+d) SUB d(IY) - Indexed Subtract - -SBCX d SBC (IX+d) SBB d(IX) - Indexed subtract with "borrow" - -SBCY d SBC (IY+d) SBB d(IY) - Indexed subtract with borrow - -ANDX d AND (IX+d) ANA d(IX) - Indexed logical and - -ANDY d AND (IY+d) ANA d(IY) - Indexed logical and - -XORX d XOR (IX+d) XRA d(IX) - Indexed logical exclusive or - -XORY d XOR (IY+d) XRA d(IY) - Indexed logical exclusive or - -ORX d OR (IX+d) ORA d(IX) - Indexed logical or - -ORY d OR (IY+d) ORA d(IY) - Indexed logical exclusive or - -CMPX d CP (IX+d) CMP d(IX) - Indexed compare - -CMPY d CP (IY+d) CMP d(IY) - Index compare - -INRX d INC (IX+d) INR d(IX) - Increment memory at m(IX+d) - -INRY d INC (IY+d) INR d(IY) - Increment memory at m(IY+d) - -DCRX d INC (IX+d) INR d(IX) - Decrement memory at m(IX+d) - -DCRY d DEC (IY+d) DCR d(IY) - Decrement memory at m(IX+d) - -NEG NEG NEG - Negate A (two's complement) - -IM0 IM0 IM0 - Set interrupt mode 0 - -IM1 IM1 IM1 - Set interrupt mode 1 - -IM2 IM2 IM2 - Set interrupt mode 2 - -DADC rr ADC HL,rr DADC rr - Add with carry rr to HL - -DSBC rr SBC HL,rr DSBC rr - Subtract with "borrow" rr from HL - -DADX rr ADD IX,rr DADX rr - Add rr to IX (rr may be BC, DE, SP, IX) - -DADY rr ADD IY,rr DADY rr - Add rr to IY (rr may be BC, DE, SP, IY) - -INXIX INC IX INX IX - Increment IX - -INXIY INC IY INX IY - Increment IY - -DCXIX DEC IX DCX IX - Decrement IX - -DCXIY DEC IY DCX IY - Decrement IY - -BIT b,r BIT b,r BIT b,r - Test bit b in register r - -SETB b,r SET b,r SET b,r - Set bit b in register r - -RES b,r RES b,r RES b,r - Reset bit b in register r - -BITX b,d BIT b,(IX+d) BIT b,d(IX) - Test bit b in memory at m(IX+d) - -BITY b,d BIT b,(IY+d) BIT b,d(IY) - Test bit b in memory at m(IY+d) - -SETX b,d SET b,(IX+d) SET b,d(IX) - Set bit b in memory at m(IX+d) - -SETY b,d SET b,(IY+d) SET b,d(IY) - Set bit b in memory at m(IY+d) - -RESX b,d RES b,(IX+d) RES b,d(IX) - Reset bit b in memory at m(IX+d) - -RESY b,d RES b,(IY+d) RES b,d(IY) - Reset bit b in memory at m(IY+d) - -JR addr JR addr-$ JMPR addr - Jump relative unconditional - -JRC addr JR C,addr-$ JRC addr - Jump relative if Carry indicator true - -JRNC addr JR NC,addr-$ JRNC addr - Jump relative if carry indicator false - -JRZ addr JR Z,addr-$ JRC addr - Jump relative if Zero indicator true - -JRNZ addr JR NZ,addr-$ JRNZ addr - Jump relative if Zero indicator false - -DJNZ addr DJNZ addr-$ DJNZ addr - Decrement B, jump relative if non-zero - -PCIX JMP (IX) PCIX - Jump to address in IX ie, Load PC from IX - -PCIY JMP (IY) PCIY - Jump to address in IY - -RETI RETI RETI - Return from interrupt - -RETN RETN RETN - Return from non-maskable interrupt - -INP r IN r,(C) INP r - Input from port C to register r - -OUTP r OUT (C),r OUTP r - Output from register r to port (C) - -INI INI INI - Input from port (C) to m(HL), increment HL, decrement b - -INIR INIR INIR - Input from port (C) to m(HL), increment HL, decrement B, repeat if B <> 0 - -OUTI OTI OUTI - Output from m(HL) to port (C), increment HL, decrement B - -OUTIR OTIR OUTIR - Repeat OUTI until B = 0 - -IND IND IND - Input from port (C) to m(HL), decrement HL & B - -INDR INDR INDR - Repeat IND until B = 0 - -OUTD OTD OUTD - Output from m(HL) to port (C), decrement HL & B - -OUTDR OTDR OUTDR - Repeat OUTD until B = 0 - -RLCR r RLC r RLCR r - Rotate left circular register - -RLCX d RLC (IX+d) RLCR d(IX) - Rotate left circular indexed memory - -RLCY d RLC (IY+d) RLCR d(IY) - Rotate left circular indexed memory - -RALR r RL r RALR r - Rotate left arithmetic register - -RALX d RL (IX+d) RALR d(IX) - Rotate left arithmetic indexed memory - -RALY d RL (IY+d) RALR d(IY) - Rotate left arithmetic indexed memory - -RRCR r RRC r RRCR r - Rotate right circular register - -RRCX d RRC (IX+d) RRCR d(IX) - Rotate right circular indexed - -RRCY d RRC (IY+d) RRCR d(IY) - Rotate right circular indexed - -RARR r RR r RARR r - Rotate right arithmetic register - -RARX d RR (IX+d) RARR d(IX) - Rotate right arithmetic indexed memory - -RARY d RR (IY+d) RARR d(IY) - Rotate right arithmetic indexed memory - -SLAR r SLA r SLAR r - Shift left register - -SLAX d SLA (IX+d) SLAR d(IX) - Shift left indexed memory - -SLAY d SLA (IY+d) SLAR d(IY) - Shift left indexed memory - -SRAR r SRA r SRAR r - Shift right arithmetic register - -SRAX d SRA (IX+d) SRAR d(IX) - Shift right arithmetic indexed memory - -SRAY d SRA (IY+d) SRAR d(IY) - Shift right arithmetic indexed memory - -SRLR r SRL r SRLR r - Shift right logical register - -SRLX d SRL (IX+d) SRLR d(IX) - Shift right logical indexed memory - -SRLY d SRL (IY+d) SRLR d(IY) - Shift right logical indexed memory - -RLD RLD RLD - Rotate left digit - -RRD RRD RRD - Rotate right digit - - \ No newline at end of file diff --git a/software/CPM/CPM11_MAC80/Z80.LIB b/software/CPM/CPM11_MAC80/Z80.LIB deleted file mode 100644 index fecefd0..0000000 --- a/software/CPM/CPM11_MAC80/Z80.LIB +++ /dev/null @@ -1,601 +0,0 @@ -; -; Z-80 MACRO LIBRARY -; -; THE FOLLOWING MACROS ENABLE ASSEMBLING Z-80 INSTRUCTIONS -; WITH THE DIGITAL RESEARCH MACRO ASSEMBLER. -; -; INVOKE WITH "MACLIB Z80" -; -; -; -; MACRO FORMATS -; ----- ------- -; -; -; MACRO ZILOG TDL -; ----- ----- --- -; -; LDX R,D LD R,(IX+D) MOV R,D(IX) -; LDY R,D LD R,(IY+D) MOV R,D(IY) -; STX R,D LD (IX+D),R MOV D(IX),R -; STY R,D LD (IY+D),R MOV D(IY),R -; MVIX NN,D LD (IX+D),NN MVI D(IX) -; MVIY NN,D LD (IY+D),NN MVI D(IY) -; LDAI LD A,I LDAI -; LDAR LD A,R LDAR -; STAI LD I,A STAI -; STAR LD R,A STAR -; LXIX NNNN LD IX,NNNN LXI IX,NNNN -; LXIY NNNN LD IY,NNNN LXI IY,NNNN -; LBCD NNNN LD BC,(NNNN) LBCD NNNN -; LDED NNNN LD DE,(NNNN) LDED NNNN -; LSPD NNNN LD SP,(NNNN) LSPD NNNN -; LIXD NNNN LD IX,(NNNN) LIXD NNNN -; LIYD NNNN LD IY,(NNNN) LIYD NNNN -; SBCD NNNN LD (NNNN),BC SBCD NNNN -; SDED NNNN LD (NNNN),DE SDED NNNN -; SSPD NNNN LD (NNNN),SP SSPD NNNN -; SIXD NNNN LD (NNNN),IX SIXD NNNN -; SIYD NNNN LD (NNNN),IY SIYD NNNN -; SPIX LD SP,IX SPIX -; SPIY LD SP,IY SPIY -; PUSHIX PUSH IX PUSH IX -; PUSHIY PUSH IY PUSH IY -; POPIX POP IX POP IX -; POPIY POP IY POP IY -; EXAF EX AF,AF' EXAF -; EXX EXX EXX -; XTIX EX (SP),IX XTIX -; XTIY EX (SP),IY XTIY -; LDI LDI LDI -; LDIR LDIR LDIR -; LDD LDD LDD -; LDDR LDDR LDDR -; CCI CPI CCI -; CCIR CPIR CCIR -; CCD CPD CCD -; CCDR CPDR CCDR -; ADDX D ADD (IX+D) ADD D(IX) -; ADDY D ADD (IY+D) ADD D(IY) -; ADCX D ADC (IX+D) ADC D(IX) -; ADCY D ADC (IY+D) ADC D(IY) -; SUBX D SUB (IX+D) SUB D(IX) -; SUBY D SUB (IY+D) SUB D(IY) -; SBCX D SBC (IX+D) SBB D(IX) -; SBCY D SBC (IY+D) SBB D(IY) -; ANDX D AND (IX+D) ANA D(IX) -; ANDY D AND (IY+D) ANA D(IY) -; XORX D XOR (IX+D) XRA D(IX) -; XORY D XOR (IY+D) XRA D(IY) -; ORX D OR (IX+D) ORA D(IX) -; ORY D OR (IY+D) ORA D(IY) -; CMPX D CP (IX+D) CMP D(IX) -; CMPY D CP (IY+D) CMP D(IY) -; INRX D INC (IX+D) INR D(IX) -; INRY D INC (IY+D) INR D(IY) -; DCRX D INC (IX+D) INR D(IX) -; DCRY D DEC (IY+D) DCR D(IY) -; NEG NEG NEG -; IM0 IM0 IM0 -; IM1 IM1 IM1 -; IM2 IM2 IM2 -; DADC RR ADC HL,RR DADC RR -; DSBC RR SBC HL,RR DSBC RR -; DADX RR ADD IX,RR DADX RR -; DADY RR ADD IY,RR DADY RR -; INXIX INC IX INX IX -; INXIY INC IY INX IY -; DCXIX DEC IX DCX IX -; DCXIY DEC IY DCX IY -; BIT B,R BIT B,R BIT B,R -; SETB B,R SET B,R SET B,R -; RES B,R RES B,R RES B,R -; BITX B,D BIT B,(IX+D) BIT B,D(IX) -; BITY B,D BIT B,(IY+D) BIT B,D(IY) -; SETX B,D SET B,(IX+D) SET B,D(IX) -; SETY B,D SET B,(IY+D) SET B,D(IY) -; RESX B,D RES B,(IX+D) RES B,D(IX) -; RESY B,D RES B,(IY+D) RES B,D(IY) -; JR ADDR JR ADDR-$ JMPR ADDR -; JRC ADDR JR C,ADDR-$ JRC ADDR -; JRNC ADDR JR NC,ADDR-$ JRNC ADDR -; JRZ ADDR JR Z,ADDR-$ JRC ADDR -; JRNZ ADDR JR NZ,ADDR-$ JRNZ ADDR -; DJNZ ADDR DJNZ ADDR-$ DJNZ ADDR -; PCIX JMP (IX) PCIX -; PCIY JMP (IY) PCIY -; RETI RETI RETI -; RETN RETN RETN -; INP R IN R,(C) INP R -; OUTP R OUT (C),R OUTP R -; INI INI INI -; INIR INIR INIR -; OUTI OTI OUTI -; OUTIR OTIR OUTIR -; IND IND IND -; INDR INDR INDR -; OUTD OTD OUTD -; OUTDR OTDR OUTDR -; RLCR R RLC R RLCR R -; RLCX D RLC (IX+D) RLCR D(IX) -; RLCY D RLC (IY+D) RLCR D(IY) -; RALR R RL R RALR R -; RALX D RL (IX+D) RALR D(IX) -; RALY D RL (IY+D) RALR D(IY) -; RRCR R RRC R RRCR R -; RRCX D RRC (IX+D) RRCR D(IX) -; RRCY D RRC (IY+D) RRCR D(IY) -; RARR R RR R RARR R -; RARX D RR (IX+D) RARR D(IX) -; RARY D RR (IY+D) RARR D(IY) -; SLAR R SLA R SLAR R -; SLAX D SLA (IX+D) SLAR D(IX) -; SLAY D SLA (IY+D) SLAR D(IY) -; SRAR R SRA R SRAR R -; SRAX D SRA (IX+D) SRAR D(IX) -; SRAY D SRA (IY+D) SRAR D(IY) -; SRLR R SRL R SRLR R -; SRLX D SRL (IX+D) SRLR D(IX) -; SRLY D SRL (IY+D) SRLR D(IY) -; RLD RLD RLD -; RRD RRD RRD -; -; -; -; @CHK MACRO USED FOR CHECKING 8 BIT DISPLACMENTS -; -@CHK MACRO ?DD ; USED FOR CHECKING RANGE OF 8-BIT DISP.S - IF (?DD GT 7FH) AND (?DD LT 0FF80H) - 'DISPLACEMENT RANGE ERROR - Z80 LIB' - ENDIF - ENDM -LDX MACRO ?R,?D - @CHK ?D - DB 0DDH,?R*8+46H,?D - ENDM -LDY MACRO ?R,?D - @CHK ?D - DB 0FDH,?R*8+46H,?D - ENDM -STX MACRO ?R,?D - @CHK ?D - DB 0DDH,70H+?R,?D - ENDM -STY MACRO ?R,?D - @CHK ?D - DB 0FDH,70H+?R,?D - ENDM -MVIX MACRO ?N,?D - @CHK ?D - DB 0DDH,36H,?D,?N - ENDM -MVIY MACRO ?N,?D - @CHK ?D - DB 0FDH,36H,?D,?N - ENDM -LDAI MACRO - DB 0EDH,57H - ENDM -LDAR MACRO - DB 0EDH,5FH - ENDM -STAI MACRO - DB 0EDH,47H - ENDM -STAR MACRO - DB 0EDH,4FH - ENDM - -LXIX MACRO ?NNNN - DB 0DDH,21H - DW ?NNNN - ENDM -LXIY MACRO ?NNNN - DB 0FDH,21H - DW ?NNNN - ENDM -LDED MACRO ?NNNN - DB 0EDH,5BH - DW ?NNNN - ENDM -LBCD MACRO ?NNNN - DB 0EDH,4BH - DW ?NNNN - ENDM -LSPD MACRO ?NNNN - DB 0EDH,07BH - DW ?NNNN - ENDM -LIXD MACRO ?NNNN - DB 0DDH,2AH - DW ?NNNN - ENDM -LIYD MACRO ?NNNN - DB 0FDH,2AH - DW ?NNNN - ENDM -SBCD MACRO ?NNNN - DB 0EDH,43H - DW ?NNNN - ENDM -SDED MACRO ?NNNN - DB 0EDH,53H - DW ?NNNN - ENDM -SSPD MACRO ?NNNN - DB 0EDH,73H - DW ?NNNN - ENDM -SIXD MACRO ?NNNN - DB 0DDH,22H - DW ?NNNN - ENDM -SIYD MACRO ?NNNN - DB 0FDH,22H - DW ?NNNN - ENDM -SPIX MACRO - DB 0DDH,0F9H - ENDM -SPIY MACRO - DB 0FDH,0F9H - ENDM -PUSHIX MACRO - DB 0DDH,0E5H - ENDM -PUSHIY MACRO - DB 0FDH,0E5H - ENDM -POPIX MACRO - DB 0DDH,0E1H - ENDM -POPIY MACRO - DB 0FDH,0E1H - ENDM -EXAF MACRO - DB 08H - ENDM -EXX MACRO - DB 0D9H - ENDM -XTIX MACRO - DB 0DDH,0E3H - ENDM -XTIY MACRO - DB 0FDH,0E3H - ENDM - -LDI MACRO - DB 0EDH,0A0H - ENDM -LDIR MACRO - DB 0EDH,0B0H - ENDM -LDD MACRO - DB 0EDH,0A8H - ENDM -LDDR MACRO - DB 0EDH,0B8H - ENDM -CCI MACRO - DB 0EDH,0A1H - ENDM -CCIR MACRO - DB 0EDH,0B1H - ENDM -CCD MACRO - DB 0EDH,0A9H - ENDM -CCDR MACRO - DB 0EDH,0B9H - ENDM - -ADDX MACRO ?D - @CHK ?D - DB 0DDH,86H,?D - ENDM -ADDY MACRO ?D - @CHK ?D - DB 0FDH,86H,?D - ENDM -ADCX MACRO ?D - @CHK ?D - DB 0DDH,8EH,?D - ENDM -ADCY MACRO ?D - @CHK ?D - DB 0FDH,8EH,?D - ENDM -SUBX MACRO ?D - @CHK ?D - DB 0DDH,96H,?D - ENDM -SUBY MACRO ?D - @CHK ?D - DB 0FDH,96H,?D - ENDM -SBCX MACRO ?D - @CHK ?D - DB 0DDH,9EH,?D - ENDM -SBCY MACRO ?D - @CHK ?D - DB 0FDH,9EH,?D - ENDM -ANDX MACRO ?D - @CHK ?D - DB 0DDH,0A6H,?D - ENDM -ANDY MACRO ?D - @CHK ?D - DB 0FDH,0A6H,?D - ENDM -XORX MACRO ?D - @CHK ?D - DB 0DDH,0AEH,?D - ENDM -XORY MACRO ?D - @CHK ?D - DB 0FDH,0AEH,?D - ENDM -ORX MACRO ?D - @CHK ?D - DB 0DDH,0B6H,?D - ENDM -ORY MACRO ?D - @CHK ?D - DB 0FDH,0B6H,?D - ENDM -CMPX MACRO ?D - @CHK ?D - DB 0DDH,0BEH,?D - ENDM -CMPY MACRO ?D - @CHK ?D - DB 0FDH,0BEH,?D - ENDM -INRX MACRO ?D - @CHK ?D - DB 0DDH,34H,?D - ENDM -INRY MACRO ?D - @CHK ?D - DB 0FDH,34H,?D - ENDM -DCRX MACRO ?D - @CHK ?D - DB 0DDH,035H,?D - ENDM -DCRY MACRO ?D - @CHK ?D - DB 0FDH,35H,?D - ENDM - -NEG MACRO - DB 0EDH,44H - ENDM -IM0 MACRO - DB 0EDH,46H - ENDM -IM1 MACRO - DB 0EDH,56H - ENDM -IM2 MACRO - DB 0EDH,5EH - ENDM - - -BC EQU 0 -DE EQU 2 -HL EQU 4 -IX EQU 4 -IY EQU 4 -DADC MACRO ?R - DB 0EDH,?R*8+4AH - ENDM -DSBC MACRO ?R - DB 0EDH,?R*8+42H - ENDM -DADX MACRO ?R - DB 0DDH,?R*8+09H - ENDM -DADY MACRO ?R - DB 0FDH,?R*8+09H - ENDM -INXIX MACRO - DB 0DDH,23H - ENDM -INXIY MACRO - DB 0FDH,23H - ENDM -DCXIX MACRO - DB 0DDH,2BH - ENDM -DCXIY MACRO - DB 0FDH,2BH - ENDM - -BIT MACRO ?N,?R - DB 0CBH,?N*8+?R+40H - ENDM -SETB MACRO ?N,?R - DB 0CBH,?N*8+?R+0C0H - ENDM -RES MACRO ?N,?R - DB 0CBH,?N*8+?R+80H - ENDM - -BITX MACRO ?N,?D - @CHK ?D - DB 0DDH,0CBH,?D,?N*8+46H - ENDM -BITY MACRO ?N,?D - @CHK ?D - DB 0FDH,0CBH,?D,?N*8+46H - ENDM -SETX MACRO ?N,?D - @CHK ?D - DB 0DDH,0CBH,?D,?N*8+0C6H - ENDM -SETY MACRO ?N,?D - @CHK ?D - DB 0FDH,0CBH,?D,?N*8+0C6H - ENDM -RESX MACRO ?N,?D - @CHK ?D - DB 0DDH,0CBH,?D,?N*8+86H - ENDM -RESY MACRO ?N,?D - @CHK ?D - DB 0FDH,0CBH,?D,?N*8+86H - ENDM - -JR MACRO ?N - DB 18H,?N-$-1 - ENDM -JRC MACRO ?N - DB 38H,?N-$-1 - ENDM -JRNC MACRO ?N - DB 30H,?N-$-1 - ENDM -JRZ MACRO ?N - DB 28H,?N-$-1 - ENDM -JRNZ MACRO ?N - DB 20H,?N-$-1 - ENDM -DJNZ MACRO ?N - DB 10H,?N-$-1 - ENDM - -PCIX MACRO - DB 0DDH,0E9H - ENDM -PCIY MACRO - DB 0FDH,0E9H - ENDM - -RETI MACRO - DB 0EDH,4DH - ENDM -RETN MACRO - DB 0EDH,45H - ENDM - -INP MACRO ?R - DB 0EDH,?R*8+40H - ENDM -OUTP MACRO ?R - DB 0EDH,?R*8+41H - ENDM -INI MACRO - DB 0EDH,0A2H - ENDM -INIR MACRO - DB 0EDH,0B2H - ENDM -IND MACRO - DB 0EDH,0AAH - ENDM -INDR MACRO - DB 0EDH,0BAH - ENDM -OUTI MACRO - DB 0EDH,0A3H - ENDM -OUTIR MACRO - DB 0EDH,0B3H - ENDM -OUTD MACRO - DB 0EDH,0ABH - ENDM -OUTDR MACRO - DB 0EDH,0BBH - ENDM - - -RLCR MACRO ?R - DB 0CBH, 00H + ?R - ENDM -RLCX MACRO ?D - @CHK ?D - DB 0DDH, 0CBH, ?D, 06H - ENDM -RLCY MACRO ?D - @CHK ?D - DB 0FDH, 0CBH, ?D, 06H - ENDM -RALR MACRO ?R - DB 0CBH, 10H+?R - ENDM -RALX MACRO ?D - @CHK ?D - DB 0DDH, 0CBH, ?D, 16H - ENDM -RALY MACRO ?D - @CHK ?D - DB 0FDH, 0CBH, ?D, 16H - ENDM -RRCR MACRO ?R - DB 0CBH, 08H + ?R - ENDM -RRCX MACRO ?D - @CHK ?D - DB 0DDH, 0CBH, ?D, 0EH - ENDM -RRCY MACRO ?D - @CHK ?D - DB 0FDH, 0CBH, ?D, 0EH - ENDM -RARR MACRO ?R - DB 0CBH, 18H + ?R - ENDM -RARX MACRO ?D - @CHK ?D - DB 0DDH, 0CBH, ?D, 1EH - ENDM -RARY MACRO ?D - @CHK ?D - DB 0FDH, 0CBH, ?D, 1EH - ENDM -SLAR MACRO ?R - DB 0CBH, 20H + ?R - ENDM -SLAX MACRO ?D - @CHK ?D - DB 0DDH, 0CBH, ?D, 26H - ENDM -SLAY MACRO ?D - @CHK ?D - DB 0FDH, 0CBH, ?D, 26H - ENDM -SRAR MACRO ?R - DB 0CBH, 28H+?R - ENDM -SRAX MACRO ?D - @CHK ?D - DB 0DDH, 0CBH, ?D, 2EH - ENDM -SRAY MACRO ?D - @CHK ?D - DB 0FDH, 0CBH, ?D, 2EH - ENDM -SRLR MACRO ?R - DB 0CBH, 38H + ?R - ENDM -SRLX MACRO ?D - @CHK ?D - DB 0DDH, 0CBH, ?D, 3EH - ENDM -SRLY MACRO ?D - @CHK ?D - DB 0FDH, 0CBH, ?D, 3EH - ENDM -RLD MACRO - DB 0EDH, 6FH - ENDM -RRD MACRO - DB 0EDH, 67H - ENDM - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/AMD9511X.CMD b/software/CPM/CPM12_PASCALMTP_v561/AMD9511X.CMD deleted file mode 100644 index 885d83e..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/AMD9511X.CMD +++ /dev/null @@ -1,3 +0,0 @@ -AMDIO -FPRTNS - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/AMDIO.SRC b/software/CPM/CPM12_PASCALMTP_v561/AMDIO.SRC deleted file mode 100644 index 5ec0b9b..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/AMDIO.SRC +++ /dev/null @@ -1,35 +0,0 @@ -MODULE AMDIOROUTINE; -(*----------------------------------------------------------*) -(* THIS MODULE CONTAINS TWO "ASSEMBLY" LANGUAGE SUBROUTINES *) -(* WHICH ARE CALLED FROM THE FPRTNS MODULE AND IF LOADED *) -(* THE TRAN9511 MODULE. *) -(* *) -(* THESE ROUTINES ARE SPECIFIC TO PASCAL/MT+ AND PASS *) -(* PARAMETERS BACK AND FORTH THROUGH REGISTERS *) -(* *) -(* THE USER SHOULD CHANGE THE PORT NUMBERS AS NECESSARY *) -(* FOR THEIR PARTICULAR HARDWARE IMPLEMENTATION OF THE 9511 *) -(*----------------------------------------------------------*) - -PROCEDURE @O95D; (* OUTPUT A-REG TO 9511 DATA PORT *) -BEGIN - INLINE("OUT / $88) (* CHANGE TO YOUR 9511 DATA PORT NUMBER *) -END; - -PROCEDURE @O95C; (* OUTPUT A-REG TO 9511 CONTROL PORT *) -BEGIN - INLINE("OUT / $89) (* CHANGE TO YOUR 9511 CTRL PORT NUMBER *) -END; - -PROCEDURE @I95D; (* INPUT A-REG FROM 9511 DATA PORT *) -BEGIN - INLINE("IN / $88) (* CHANGE TO YOUR 9511 DATA PORT (SAME AS @O95D) *) -END; - -PROCEDURE @I95C; (* INPUT A-REG FROM 9511 CONTROL PORT *) -BEGIN - INLINE("IN / $89) (* CHANGE TO YOUR 9511 CTRL PORT (SAME AS @O95C) *) -END; - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/APUSUB.MAC b/software/CPM/CPM12_PASCALMTP_v561/APUSUB.MAC deleted file mode 100644 index 83736a4..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/APUSUB.MAC +++ /dev/null @@ -1,99 +0,0 @@ - -;---------------------------------------------------------------; -; ; -; 9511 SUBROUTINES FOR TRAN9511 ; -; ; -;---------------------------------------------------------------; - - PUBLIC @AMD - EXTRN @I95D ;DATA PORT INPUT - EXTRN @O95D ;DATA PORT OUTPUT - EXTRN @I95C ;CTRL PORT INPUT - EXTRN @O95C ;CTRL PORT OUTPUT - -; PROCEDURE @AMD(FUNC:INTEGER; VAR R:REAL; VAR STAT:INTEGER); - -@AMD: - POP H ;RET ADR - SHLD RETADR - POP H ;ADDR OF APU STAT - POP D ;ADDR OF REAL - POP B ;FUNCTION - -; ROUTINE FOR FLOATING POINT DERIVED FUNCTIONS -; ENTER WITH: -; BC = COMMAND -; M(DE) = FUNCTION( M(DE) ) -; M(HL) = APU STAT - PUSH B - CALL PSHD ;PUSH ARGUMENT - POP B - MOV A,C ;ISSUE COMMAND - CALL APUCS - CALL POPSTAT ;GET DATA AND RETURN STATUS IN A-REG - MOV M,A ;STORE APU STATUS - INX H - MVI M,0 ;ZERO HIGH BYTE - LHLD RETADR - PCHL - -;---------------------------------------------------------------; -; ; -; 9511 UTILITY ROUTINES ; -; NOTE THESE CALL @IN95 AND @OUT95 IN AMDIO ; -; ; -;---------------------------------------------------------------; - -PSHD: INX D - INX D - INX D - MVI B,4 - -PSD10: LDAX D - CALL APUWS - DCX D - DCR B - JNZ PSD10 - INX D - RET - -APULOOP: - PUSH PSW -APUX2A: CALL @I95C - ORA A - JM APUX2A - POP PSW - RET - -APURS: CALL APULOOP - CALL @I95D - RET - -APUCS: CALL APULOOP - CALL @O95C - RET - - -APUWS: CALL APULOOP - CALL @O95D - RET - -POPSTAT: - PUSH D - MVI B,4 -PPS10: CALL APURS - STAX D - INX D - DCR B - JNZ PPS10 - POP D -RDSTAT: CALL @I95C - ORA A - JM RDSTAT - RET - - - DSEG -RETADR: DS 2 - END - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/ATWNB.SRC b/software/CPM/CPM12_PASCALMTP_v561/ATWNB.SRC deleted file mode 100644 index ec9d6b7..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/ATWNB.SRC +++ /dev/null @@ -1,95 +0,0 @@ -MODULE WRITEBYTES; -(* - * [PASLIB] @WNB - Write next byte to file - * Revisions: - * 10/21/81 Last update - * - *) - -(*$I fibdef.lib*) - -VAR - @LFB : EXTERNAL ^FIB; - RESULTIO: EXTERNAL INTEGER; - -EXTERNAL FUNCTION @BDOS(FUNC:INTEGER; PARM:WORD):INTEGER; -EXTERNAL PROCEUDRE @DFLT; - -(*$E-*) -PROCEDURE WRITEBYTE(CH:CHAR); -VAR - I : INTEGER; -BEGIN - WITH @LFB^ DO - BEGIN - IF FSECINX = 128 THEN (* TIME TO WRITE *) - BEGIN - RESULTIO := @BDOS(26,WRD(ADDR(FSECTOR))); - RESULTIO := @BDOS(21,WRD(ADDR(FCB))); - FSECINX := 0 - END; - FSECTOR[FSECINX] := CH; - FSECINX := FSECINX + 1 - END (* WITH *) -END; (* WRITEBYTE *) -(*$E+*) - - -PROCEDURE @WNB; -LABEL 1; -VAR - SRCADR : ^CHAR; - CH : CHAR; - N,I : INTEGER; - -BEGIN - RESULTIO := 0; (* DEFAULT *) - MOVE(@LFB^.FBUFADR,SRCADR,2); - IF @LFB^.OPTION > FRANDOM THEN (* CONSOLE/TERM I/O *) - BEGIN - WITH @LFB^ DO - FOR N := 1 TO IOSIZE DO - BEGIN - CH := SRCADR^; - if ((ch = chr($0a)) and - (not ((option=ftrmio) or - (option=fauxio)))) then - goto 1; - IF OPTION = FLSTOUT THEN - BEGIN - I := @BDOS(5,WRD(CH)); (* WRITE IT TO THE PRINTER *) - IF CH = CHR($0D) THEN (* WE MUST ECHO LF *) - I := @BDOS(5,WRD($0A)) - END - ELSE - BEGIN - if option = fconio then - i := @bdos(2,wrd(ch)) - else if option = ftrmio then - i := @bdos(6,wrd(ch)) - else (* must be fauxio *) - i := @bdos(4,wrd(ch)); - - IF OPTION = FCONIO THEN - IF CH=CHR($0D) THEN - (* WE MUST ECHO CR/LF FOR CR *) - I := @BDOS(2,WRD($0A)) - END; -1: SRCADR := SRCADR + 1 - END; - EXIT - END; - - (* WE GET HERE ONLY IF NON-CONSOLE I/O *) - - FOR N := 1 TO @LFB^.IOSIZE DO - BEGIN - WRITEBYTE(SRCADR^); - SRCADR := SRCADR + 1 - END; - @DFLT; - -END; - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/BCDREALS.ERL b/software/CPM/CPM12_PASCALMTP_v561/BCDREALS.ERL deleted file mode 100644 index 6170601..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/BCDREALS.ERL and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/CALC.SRC b/software/CPM/CPM12_PASCALMTP_v561/CALC.SRC deleted file mode 100644 index 6074d42..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/CALC.SRC +++ /dev/null @@ -1,110 +0,0 @@ -(* AS OF 10/21/79 *) -(*$C3*) - -PROGRAM CALCULATE; - -CONST - RCONST = -2.5; - RCONST1= 65535.5; - -VAR R1,R2,TEMP:REAL; - X : ARRAY [1..2] OF REAL; - CH1,OP:CHAR; - - - -FUNCTION SUBREAL(R1,R2:REAL) : REAL; - -BEGIN - SUBREAL := R1 - R2 -END; - - - -PROCEDURE ADDREAL(VAR R1:REAL; R2:REAL); -BEGIN - R1 := R1 + R2 -END; - -PROCEDURE TF(B:BOOLEAN); -BEGIN - IF B THEN - WRITELN('TRUE') - ELSE - WRITELN('FALSE') -END; - -PROCEDURE CALC; -BEGIN - CASE OP OF - 'S': WRITELN(SIN(R1)); - 'C': WRITELN(COS(R1)); - 'A': WRITELN(ARCTAN(R1)); - 'L': WRITELN(LN(R1)); - 'E': WRITELN(EXP(R1)); - '+': BEGIN ADDREAL(X[1],X[2]); WRITELN(X[1]:10:3) END; - '-': WRITELN(SUBREAL(X[1],X[2]):10:2); - '*': WRITELN(R1 * R2); - '/': WRITELN(R1 / R2); - 'M': WRITELN(-R1); - '=': TF(R1 = R2); - 'N': TF(R1 <> R2); - '$': WRITELN(SQRT(R1):10:3,SQRT(R2):10:3); - '<': TF(R1 < R2); - '>': TF(R1 > R2); - 'Z': TF(R1 <= R2); - 'G': TF(R1 >=R2); - '1': WRITELN(SQR(R1),' ',SQR(R2)); - '2': WRITELN(R1 + 1); - '3': WRITELN(1+R1); - '4': WRITELN(TRUNC(R1)); - '5': WRITELN(ROUND(R1)); - '6': WRITELN(RCONST); - '7': WRITELN(RCONST1); - '8': BEGIN R1 := -2.234; X[1] := 3.456; WRITELN(R1,' ',X[1]); END; - - END; -END; (* CALCULATOR *) - -PROCEDURE MENU; -BEGIN - WRITE('S:SIN '); - WRITE('C:COS '); - WRITE('A:ARCTAN '); - WRITE('L:LN '); - WRITE('E:EXP '); - WRITE('1:SQR '); - WRITELN('$:SQRT '); - WRITELN('+, -, *, / ARITHMETIC OPERATORS'); - WRITELN('M:NEGATE'); - WRITE('= : EQUAL '); - WRITELN('N : NOT EQUAL'); - WRITE('<:LESS THAN '); - WRITELN('>:GREATER THAN '); - WRITELN('Z:LESS THAN OR EQUAL TO'); - WRITELN('G:GREATER THAN OR EQUAL TO'); - WRITE('4:TRUNC '); - WRITELN('5:ROUND'); -END; - -BEGIN (* MAIN PROGRAM *) - REPEAT - WRITE('ENTER FIRST OPERAND? '); - READ(R1); - X[1] := R1; - WRITELN('R1=',R1); WRITELN; - WRITE('ENTER SECOND OPERAND? '); - READ(R2); - X[2] := R2; - WRITELN('R2=',R2); WRITELN; - WRITELN('ENTER OPERATOR:'); - MENU; - WRITE('? '); - READ(OP); - WRITELN; - CALC; - WRITELN('TYPE TO STOP'); - READ(CH1); - UNTIL CH1 = CHR(27) -END. - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/CHN.MAC b/software/CPM/CPM12_PASCALMTP_v561/CHN.MAC deleted file mode 100644 index 06fe08c..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/CHN.MAC +++ /dev/null @@ -1,72 +0,0 @@ -;---------------------------------------------------------------------- -; [PASLIB] CHN.MAC: Load program and jump to it. -; @CHN -; NOTE: The body of this routine is actually executed at -; 80H+SYSBASE. This allows the routine to reside anywhere and to -; be moved to 80H+SYSBASE just before execution. @CHN also uses -; the default file control block. -; Revisions: -; 8/15/80 Last MGL update -; -; -;---------------------------------------------------------------------- - - PUBLIC @CHN - - EXTRN @MVL - - INCLUDE BCONFIG.LIB - -SYSBASE SET 0 - -@CHN:: -RTPCHAIN: - POP H - POP D ;GET FCB ADDRESS - LXI B,33 - LXI H,5CH+SYSBASE - PUSH H - PUSH D - PUSH B - CALL @MVL## ;MOVE FCB TO DEFAULT AREA - LXI SP,100H - - LXI H,100H+SYSBASE - PUSH H ;SAVE READ-IN LOCATION (ON THE NEW STACK) -; -; NOW MOVE THE REAL WORKHORSE ROUTINE TO 80H -; - LXI D,RTPCHN1 - LXI H,80H - LXI B,RTNLEN - PUSH H - PUSH D - PUSH B - CALL @MVL## - JMP 80H+SYSBASE ;AND GO FINISH IT OFF -; -; NOTE: THIS CODE ACTUALLY IS MOVED TO 80H+SYSBASE -; PRIOR TO EXECUTION -; - -RTPCHN1: - POP D ;GET ADDR OF I/O BUFFER - PUSH D ;SAVE IT AGAIN - MVI C,26 ;SETDMA CALL TO BDOS - CALL BDOS ; - POP H ;NOW BUMP IT BY 128 - LXI D,128 ; - DAD D ; - PUSH H ;SAVE IT AGAIN - LXI D,5CH+SYSBASE ;GET FCB ADDRESS - MVI C,20 ;REQUEST A READ - CALL BDOS ; - CPI 1 ;END OF FILE? - JNZ 80H+SYSBASE ;(RTPCHN1) RELOCATED - POP H ;WHEN DONE FLUSH THE STACK - JMP 100H+SYSBASE ;AND OFF TO THE NEWLY LOADED PROGRAM - -RTNLEN EQU $-RTPCHN1 - - END - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/CPMRD.SRC b/software/CPM/CPM12_PASCALMTP_v561/CPMRD.SRC deleted file mode 100644 index 8cf6b3e..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/CPMRD.SRC +++ /dev/null @@ -1,26 +0,0 @@ -MODULE CPMRD; -(* - * [PASLIB] @CPMRD - Read line from console. - * Revisions: - * - * - *) - -TYPE - IOBUF = RECORD - MAXLEN : BYTE; - RETLEN : BYTE; - IOBUF : ARRAY [0..254] OF CHAR - END; - -EXTERNAL FUNCTION @BDOS(FUNC,PARM:INTEGER):INTEGER; - -PROCEDURE @CPMRD(VAR BUF:IOBUF); -VAR - RESULT : INTEGER; -BEGIN - RESULT := @BDOS(10,ADDR(BUF)) -END; - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/CWT.MAC b/software/CPM/CPM12_PASCALMTP_v561/CWT.MAC deleted file mode 100644 index 7cb8dc2..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/CWT.MAC +++ /dev/null @@ -1,56 +0,0 @@ -;---------------------------------------------------------------------- -; [PASLIB] CWT.MAC: Wait for end-of-line character. -; @CWT -; Revisions: -; 9/6/80 Last MGL update -; -; -;---------------------------------------------------------------------- - - PUBLIC @CWT ;WAIT FOR CR - - EXTRN @GETCHR - EXTRN @LFB - -FEOLN EQU 59 ;BOOLEAN; -FBUFFER EQU 194 ;ARRAY [0..0] OF BYTE -OPTION EQU 56 ;(FREAD,FWRITE,...FLSTOUT) -FCONIO EQU 4 ;USED BY THIS MODULE - -@CWT: - LHLD @LFB - LXI D,FEOLN - DAD D - MOV A,M - RAR - JC ITSEOLN ;BR IF LAST THING WAS A CR - - CALL @GETCHR - POP B - JMP @CWT - -ITSEOLN: - MVI M,0 ;TURN EOLN OFF - LHLD @LFB - LXI D,OPTION - DAD D - MOV A,M - CPI FCONIO - RNC ;IF CONSOLE THEN WE ARE DONE - - CALL @GETCHR ;GOBBLE BLANK AND PUT LF IN BUFFER - POP B - - LHLD @LFB - LXI D,FBUFFER - DAD D - MOV A,M - CPI 0AH ;LF TO GOBBLE? - RNZ ;RETURN IF DONE - - CALL @GETCHR ;GOBBLE LF AND PUT NEXT CHAR IN BUFFER - POP B - RET - - END - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/DBUGHELP.TXT b/software/CPM/CPM12_PASCALMTP_v561/DBUGHELP.TXT deleted file mode 100644 index cfddffc..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/DBUGHELP.TXT +++ /dev/null @@ -1,23 +0,0 @@ -Pascal/MT+ SYMBOLIC DEBUGGER (c) 1983 by Digital Research, Inc. - - = [^] or with optional +/- offset - = or $ - = or : - -Display commands: - -D? Where ? is one of: - I - INTEGER C - CHAR L - BOOLEAN R - REAL - B - BYTE W - WORD S - STRING X - EXTENDED - V - var by name -PN Display procedure names -VN Display all var names associated with this procedure -SB Set breakpoint -RB Remove breakpoint -E+ Entry/Exit display on -E- Entry/Exit display off -BE Begin execution at start of user program -GO Continue execution from breakpont -TR Execute one Pascal statement and return -T Execute Pascal statements and return - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/DEBUGGER.ERL b/software/CPM/CPM12_PASCALMTP_v561/DEBUGGER.ERL deleted file mode 100644 index 88c6d37..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/DEBUGGER.ERL and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/DIS8080.COM b/software/CPM/CPM12_PASCALMTP_v561/DIS8080.COM deleted file mode 100644 index 37f2a5e..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/DIS8080.COM and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/DIV.MAC b/software/CPM/CPM12_PASCALMTP_v561/DIV.MAC deleted file mode 100644 index 80b8ddd..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/DIV.MAC +++ /dev/null @@ -1,325 +0,0 @@ -;---------------------------------------------------------------------- -; [PASLIB] DIV.MAC: Signed and unsigned integer division and modulus. -; @DIV, @MOD, @XDIVD, @UDV, @UMD -; Revisions: -; 11/14/81 Last MGL update. -; 12/16/82 Fixed SPR problem in @MOD (CHW) -; -; -;---------------------------------------------------------------------- - - PUBLIC @DIV ;SIGNED DIV - PUBLIC @MOD ;SIGNED MOD - PUBLIC @UDV ;UNSIGNED DIV - PUBLIC @UMD ;UNSIGNED MOD - PUBLIC @XDIVD ;USED BY WRITE INTEGER - PUBLIC @GZF ;GET DIVIDE BY ZERO BOOLEAN FLAG ROUTINE - - EXTRN @HLT - EXTRN @WRS ;FOR ERROR MESSAGE - EXTRN @LFB ;FOR ERROR MESSAGE - EXTRN OUTPUT ;FOR ERROR MESSAGE - - DSEG -DIVZFLAG: DS 1 ;= 1 IF PREV DIVIDE WAS DIVIDE BY 0 -modsign: ds 1 ;= FF if result to be negative (12/16/82) - CSEG - -@GZF: - POP H - LDA DIVZFLAG ;PUT INTO CARRY - RAR ;AND PUSH IT (CARRY IS LOW ORDER BIT OF PSW) - PUSH PSW ;PUT FLAG ON STACK - PCHL ;AND EXIT - -DIVPOS: - XCHG - LXI H,0 - -;*************************************************** -;SUBR :DHLDEBYBC -;PURP :DIVIDE HLDE BY BC -;ENTRY :HL=DIVIDEND HIGH WORD,DE=DIVIDEND LOW WORD -; :BC=DIVISOR -;EXIT :HL=QUOTIENT,DE=REMAINDER -; :IF BC=0 THEN ERROR=ZERODIVISOR -; :NOTE THE QUOTIENT MUST BE BETWEEN 0,65535 -; : EXAMPLE: 70000/1 IS ILLEGAL BUT 70000/2 IS LEGAL -;USED :ALL -;CALLS :@DHLDEBYBC -;MACROS:NEGBC -;*************************************************** -@DHLDEBYBC: - XRA A - STA DIVZFLAG ;INITIALLY NO ERRORS - - MOV A,C - ORA B - JNZ CONT0 ;JIF NOT ZERO - ;ELSE ERROR EXIT - JMP ZDIV1 -; -CONT0: ;DIVISOR<>0 - MOV A,B - CMA - MOV B,A - MOV A,C - CMA - MOV C,A - INX B - ;TAKE NEGATIVE OF BC SO DAD B WILL - ;SET HL=HL-BC - MVI A,17 ;16 BITS + 1 -NEXTBIT: - DCR A - JNZ CONT1 ;JIF NOT DONE - ;ELSE EXIT - XCHG ;HL=QOUTIENT,DE=REMAINDER - JMP DIVXIT -; -;NOT DONE -;SHIFT HL LEFT CY=BIT 15 -CONT1: DAD H - JC DIV2 ;JIF BIT 15=1 -; -;SHIFT DE LEFT AND INTO HL (HL BIT0=DE BIT 15) - XCHG - DAD H - XCHG ;DE SHIFTED CY=DE BIT 15 - - JNC DIV0 ;JIF BIT15=0 (HL BIT0=0 ALREADY) - INR L ;ELSE SET IT TO 1 -; -;IF ABS(BC)>=HL THEN HL=HL-ABS(BC) AND E=E+1 -;?? -DIV0: - PUSH H ;SAVE HL - DAD B - JC DIV1 ;JIF ABS(BC) >= HL - ; ELSE GOTO NEXTBIT - POP H ;DISCARD SUBSTRACTION - JMP NEXTBIT - -; -; WELL ABS(BC) < HL SO INR E AND SET HL=HL-ABS(BC) -; -DIV1: - INR E - INX SP - INX SP ;DROP THE SAVED HL FROM THE STACK - JMP NEXTBIT -; -; -;ARRIVE HERE IF NEXTBIT=1 -DIV2: - XCHG - DAD H - XCHG ;SHIFT DE LEFT - JNC DIV3 ;JIF BIT 15=0 - INR L ;ELSE SET BIT0 OF HL=1 -; -;NOW HL=HL-ABS(BC) AND E=E+1 -DIV3: - DAD B - INR E - JMP NEXTBIT ;CONTINUE ON -; -DIVXIT: - XCHG - RET - -ZDIV1: - lxi h,output ;make it portable! - shld @lfb - lxi h,div0msg - push h - lxi h,-1 - push h - push h - call @wrs -; MVI C,9 -; LXI D,DIV0MSG -; CALL 5 - CALL @HLT - -DIV0MSG: - db div0len - db 13,10,'Divide by zero',13,10 -div0len equ $-div0msg-1 - - RET - -@XDIVD: - XRA A - STA DIVZFLAG - ORA C - JNZ Y10 ;CHECK FIRST BYTE, IF NOT ZERO BRANCH - ORA B - JZ Y99 ;IF NEXT BYTE 0 THEN DIVIDE BY 0 - XRI 80H - JZ Y99 ;MAKE SURE ITS NOT 32768 -Y10: MOV A,B - ANA A - JM Y50 ;BR IF DENOMINATOR NEGATIVE, ILLEGAL -Y20: ORA D - JM Y40 ;BR IF NUMERATOR NEGATIVE -Y30: XCHG - CALL DIVPOS - RET -Y40: ;COME HERE WHEN NUMERATOR IS NEGATIVE - MOV A,L - CPI 1 ;IF WE ARE ENTERED VIA MOD BRANCH - JZ ISMOD - - MOV A,E - CMA - MOV L,A - MOV A,D - CMA - MOV H,A - INX H ;TAKE TWOS COMPLEMENT OF NUMERATOR - CALL DIVPOS - MOV A,E - CMA - MOV E,A - MOV A,D - CMA - MOV D,A - INX D ;TAKE TWOS COMP OF QUOTIENT - RET - -ISMOD: -; LXI H,0FFFFH ;SIGN EXTEND - mov a,d - cma - mov d,a - mov a,e - cma - mov e,a - inx d - lxi h,0 - CALL @DHLDEBYBC ;GO DO THE DIVIDE - RET ;AND EXIT - -Y50: - XRA A - SUB C - MOV C,A - MVI A,00H - SBB B - MOV B,A - MOV A,D - ANA A - JM Y80 - JNZ Y60 - ORA E - JZ Y80 -Y60: XCHG - CALL DIVPOS - MOV A,E - CMA - MOV E,A - MOV A,D - CMA - MOV D,A - INX D -Y70: - - MOV A,L - SUB C - MOV L,A - MOV A,H - SBB B - MOV H,A - INX H - RET -Y80: - XRA A - SUB E - MOV L,A - MVI A,00H - SBB D - MOV H,A - CALL DIVPOS - XRA A - SUB L - MOV L,A - MVI A,00H - SBB H - MOV H,A - RET -Y99: - JMP ZDIV1 - - MVI A,1 - STA DIVZFLAG - - LXI D,0FFFFH - LXI H,0 - RET - - - -@DIV: - POP H - POP B - POP D - PUSH H - MVI L,0 ;SIGNAL NOT MOD - CALL @XDIVD - POP H - PUSH D - PCHL - - - -@MOD: - POP H - POP B - POP D - PUSH H - mvi a,0 - sta modsign - mvi a,128 - ana d - jz mod1 - mvi a,255 - sta modsign -mod1: - MVI L,1 ;SIGNAL MOD - CALL @XDIVD - lda modsign - cpi 255 - jnz mod2 - mov a,h - cma - mov h,a - mov a,l - cma - mov l,a - inx h -mod2: - XTHL - PCHL - -@UDV: ;UNSIGNED DIVIDE - POP D ;RET ADR - POP B ;DIVIDEND - POP H ;DIVISOR - PUSH D - CALL DIVPOS - XCHG - XTHL - PCHL - -@UMD: ;UNSIGNED MOD - POP D - POP B - POP H - PUSH D - CALL DIVPOS - XTHL - PCHL - END - - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/FIBDEF.LIB b/software/CPM/CPM12_PASCALMTP_v561/FIBDEF.LIB deleted file mode 100644 index 61fb546..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/FIBDEF.LIB +++ /dev/null @@ -1,25 +0,0 @@ -{ modified for 5.5 to add fauxio } - - { FIB LAYOUT } - - -TYPE - OPTTYPE = (notopen,fwrite,frdwr,frandom,fconio,ftrmio,flstout,fauxio); - - FIB=RECORD - FNAME : STRING[16]; { d:filename.ext } - FCB : PACKED ARRAY [0..34] OF CHAR; { CP/M FILE CONTROL BLOCK } - BUFLEN : INTEGER; { SIZE OF FBUFFER } - BUFIDX : INTEGER; { CURRENT INDEX INTO FBUFFER } - OPTION : OPTTYPE; - IOSIZE : INTEGER; { SIZE OF NEXT TRANSFER } - FEOLN : BOOLEAN; { TRUE IF TEXT FILE AT END-OF-LINE } - FEOF : BOOLEAN; { TRUE IF AT END-OF-FILE } - FBUFADR: WORD; { POINTER TO FBUFFER } - FSECINX: 0..128; { INDEX INTO FSECTOR +1 FOR OVERFLOW } - FTEXT : BOOLEAN; { TRUE IF THIS IS A TEXT FILE! } - NOSECTRS:BOOLEAN; { TRUE IF NO MORE DISK DATA AVAILABLE } - FSECTOR: PACKED ARRAY [0..127] OF CHAR; { 1 SECTOR BUFFER FOR CP/M } - FBUFFER: PACKED ARRAY [0..0 ] OF CHAR; - END; - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/FPREALS.ERL b/software/CPM/CPM12_PASCALMTP_v561/FPREALS.ERL deleted file mode 100644 index 5257c4c..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/FPREALS.ERL and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/FPRTNS.ERL b/software/CPM/CPM12_PASCALMTP_v561/FPRTNS.ERL deleted file mode 100644 index d0f395d..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/FPRTNS.ERL and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/FULLHEAP.ERL b/software/CPM/CPM12_PASCALMTP_v561/FULLHEAP.ERL deleted file mode 100644 index 4a68e25..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/FULLHEAP.ERL and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/GET.SRC b/software/CPM/CPM12_PASCALMTP_v561/GET.SRC deleted file mode 100644 index e05b08f..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/GET.SRC +++ /dev/null @@ -1,48 +0,0 @@ -MODULE GETREC; -(* - * [PASLIB] GET - Pascal GET operation. - * Revisions: - * 7/22/83 Added test for ftrmio to prevent interpretation of incoming - * characters (SP) - * - * - *) - -(*$I fibdef.lib*) - -VAR - @LFB: EXTERNAL ^FIB; - -EXTERNAL PROCEDURE @RNB; - -PROCEDURE GET(VAR F:FIB; SZ:INTEGER); -VAR - IS_EOLN : BOOLEAN; -BEGIN - F.FEOLN := FALSE; (* DEFAULT IS THAT WE RESET IT *) - - @LFB := ADDR(F); - IF F.FEOF THEN - BEGIN - F.FEOLN := TRUE; - EXIT - END; - - @RNB; (* GO READ FROM THE FILE/CONSOLE *) - - IF (F.FTEXT) and (f.option<>ftrmio) THEN - (* TEXT FILE, EOLN/EOF MUST BE SET *) - BEGIN - F.FEOF := (F.FBUFFER[0] = CHR($1A)) OR (F.FEOF); - IS_EOLN := (F.FBUFFER[0] = CHR($0D)); - IF (IS_EOLN) OR (F.FEOF) THEN - F.FEOLN := TRUE; - IF (IS_EOLN) AND (F.OPTION = FRDWR) THEN (* GOBBLE LF *) - @RNB; - IF F.FEOF OR F.FEOLN THEN - F.FBUFFER[0] := ' '; - END -END; - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/HLT.MAC b/software/CPM/CPM12_PASCALMTP_v561/HLT.MAC deleted file mode 100644 index 68b1ac3..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/HLT.MAC +++ /dev/null @@ -1,18 +0,0 @@ -;---------------------------------------------------------------------- -; [PASLIB] HLT.MAC: Common termination point. -; @HLT -; Revisions: -; 8/1/80 Last MGL update -; -; -;---------------------------------------------------------------------- - - INCLUDE BCONFIG.LIB - - PUBLIC @HLT - -@HLT: - JMP BOOT - - END - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/INDEXER.DOC b/software/CPM/CPM12_PASCALMTP_v561/INDEXER.DOC deleted file mode 100644 index ca6564b..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/INDEXER.DOC +++ /dev/null @@ -1,9 +0,0 @@ -Indexer inputs a Pascal source file and outputs one of two forms -of index file. The first is the short form: only the procedure -or function declarations are extracted from the source. The -second is the long form: everything between the keyword 'procedure' -or 'function' and the keyword 'begin' is extracted. -Invoke indexer with the following command line: - -INDEXER [SHORT | LONG] - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/INDEXER.PAS b/software/CPM/CPM12_PASCALMTP_v561/INDEXER.PAS deleted file mode 100644 index 2d80e54..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/INDEXER.PAS and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/IOCHK.BLD b/software/CPM/CPM12_PASCALMTP_v561/IOCHK.BLD deleted file mode 100644 index fa20dca..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/IOCHK.BLD +++ /dev/null @@ -1,4 +0,0 @@ -IOCHK.ERL -IOERR.ERL -XBDOS.ERL - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/IOERR.SRC b/software/CPM/CPM12_PASCALMTP_v561/IOERR.SRC deleted file mode 100644 index ead744b..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/IOERR.SRC +++ /dev/null @@ -1,27 +0,0 @@ -(* 5.5 *) -MODULE IOERROR; - -(*$I 80rtp/fibdef.lib*) -(*$M @IOERR*) -(*$M **) - -VAR - @LFB : EXTERNAL ^FIB; - @TMP : ^FIB; (* FOR SAVING @LFB *) - -PROCEDURE @IOERR(CPMFUNC:INTEGER); -BEGIN - @TMP := @LFB; - CASE CPMFUNC OF - - 15 : WRITELN('Unable to open: ',@TMP^.FNAME); - 16 : WRITELN('Unable to close: ',@TMP^.FNAME); - 21 : WRITELN('Error writing to: ',@TMP^.FNAME); - 22 : WRITELN('Unable to create: ',@TMP^.FNAME) - - END; (* CASE *) - @LFB := @TMP -END; - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/LIBMT.COM b/software/CPM/CPM12_PASCALMTP_v561/LIBMT.COM deleted file mode 100644 index 71e465f..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/LIBMT.COM and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/LINKMT.COM b/software/CPM/CPM12_PASCALMTP_v561/LINKMT.COM deleted file mode 100644 index e0e1dcc..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/LINKMT.COM and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/MOD1.SRC b/software/CPM/CPM12_PASCALMTP_v561/MOD1.SRC deleted file mode 100644 index b3ce2ac..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/MOD1.SRC +++ /dev/null @@ -1,13 +0,0 @@ -MODULE OVERLAY1; - -VAR - I : EXTERNAL INTEGER; (* LOCATED IN THE ROOT *) - -PROCEDURE OVL1; (* ONE OF POSSIBLY MANY PROCEDURES IN THIS MODULE *) -BEGIN - WRITELN('In overlay 1, I=',I) -END; - -MODEND. - - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/MOD2.SRC b/software/CPM/CPM12_PASCALMTP_v561/MOD2.SRC deleted file mode 100644 index c12c942..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/MOD2.SRC +++ /dev/null @@ -1,12 +0,0 @@ -MODULE OVERLAY2; - -VAR - I : EXTERNAL INTEGER; (* LOCATED IN THE ROOT *) - -PROCEDURE OVL2; (* ONE OF POSSIBLY MANY PROCEDURES IN THIS MODULE *) -BEGIN - WRITELN('In overlay 2, I=',I) -END; - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/MTERRS.TXT b/software/CPM/CPM12_PASCALMTP_v561/MTERRS.TXT deleted file mode 100644 index e937c50..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/MTERRS.TXT +++ /dev/null @@ -1,134 +0,0 @@ - 1 Error in simple type - 2 Identifier expected - 3 'PROGRAM' expected - 4 ')' expected - 5 ':' expected - 6 Illegal symbol (possibly missing ';' on line above) - 7 Error in parameter list - 8 'OF' expected - 9 '(' expected - 10 Error in type - 11 '[' expected - 12 ']' expected - 13 'END' expected - 14 ';' expected (possibly on line above) - 15 Integer expected - 16 '=' expected - 17 'BEGIN' expected - 18 Error in declaration part - 19 error in - 20 '.' expected - 21 '*' expected - 50 Error in constant - 51 ':=' expected - 52 'THEN' expected - 53 'UNTIL' expected - 54 'DO' expected - 55 'TO' or 'DOWNTO' expected in FOR statement - 56 'IF' expected - 57 'FILE' expected - 58 Error in (bad expression) - 59 Error in variable - 99 MODEND expected -101 Identifier declared twice -102 Low bound exceeds high bound -103 Identifier is not of the appropriate class -104 Undeclared identifier -105 sign not allowed -106 Number expected -107 Incompatible subrange types -108 File not allowed here -109 Type must not be real -110 type must be scalar or subrange -111 Incompatible with part -112 Index type must not be real -113 Index type must be a scalar or a subrange -114 Base type must not be real -115 Base type must be a scalar or a subrange -116 Error in type of standard procedure parameter -117 Unsatisified forward reference -118 Forward reference type identifier in variable declaration -119 Re-specified params not OK for a forward declared procedure -120 Function result type must be scalar, subrange or pointer -121 File value parameter not allowed -122 A forward declared function's result type can't be re-specified -123 Missing result type in function declaration -125 Error in type of standard procedure parameter -126 Number of parameters does not agree with declaration -127 Illegal parameter substitution -128 Result type does not agree with declaration -129 Type conflict of operands -130 Expression is not of set type -131 Tests on equality allowed only -133 File comparison not allowed -134 Illegal type of operand(s) -135 Type of operand must be boolean -136 Set element type must be scalar or subrange -137 Set element types must be compatible -138 Type of variable is not array -139 Index type is not compatible with the declaration -140 Type of variable is not record -141 Type of variable must be file or pointer -142 Illegal parameter solution -143 Illegal type of loop control variable -144 Illegal type of expression -145 Type conflict -146 Assignment of files not allowed -147 Label type incompatible with selecting expression -148 Subrange bounds must be scalar -149 Index type must be integer -150 Assignment to standard function is not allowed -151 Assignment to formal function is not allowed -152 No such field in this record -153 Type error in read -154 Actual parameter must be a variable -155 Control variable cannot be formal or non-local -156 Multidefined case label -157 Too many cases in case statement -158 No such variant in this record -159 Real or string tagfields not allowed -160 Previous declaration was not forward -161 Again forward declared -162 Parameter size must be constant -163 Missing variant in declaration -164 Substition of standard proc/func not allowed -165 Multidefined label -166 Multideclared label -167 Undeclared label -168 Undefined label -169 Error in base set -170 Value parameter expected -171 Standard file was re-declared -172 Undeclared external file -174 Pascal function or procedure expected -183 External declaration not allowed at this nesting level -187 Attempt to open library unsuccessful -191 No private files -193 Not enough room for this operation -194 Comment must appear at top of program -201 Error in real number - digit expected -202 String constant must not exceed source line -203 Integer constant exceeds range -206 Illegal real number -250 Too many scopes of nested identifiers -251 Too many nested procedures or functions -253 Procedure too long -256 Too many external references -257 Too many externals -258 Too many local files -259 Expression too complicated -398 Implementation restriction -399 Implementation restriction -400 Illegal character in text -401 Unexpected end of input -402 Error in writing code file, not enough room -403 Error in reading include file -404 Error in writing list file, not enough room -405 Call not allowed in separate procedure -406 Include file not legal -407 *** HEAP OVERFLOW *** -496 Invalid argument to INLINE pseudo procedure -497 Error in closing code file. -500 Non-ISO extension being used! -599 Implementation Restriction - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.000 b/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.000 deleted file mode 100644 index 1b923c8..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.000 and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.001 b/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.001 deleted file mode 100644 index bb4b307..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.001 and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.002 b/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.002 deleted file mode 100644 index 17381b0..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.002 and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.003 b/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.003 deleted file mode 100644 index 71a8271..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.003 and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.004 b/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.004 deleted file mode 100644 index 893d226..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.004 and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.005 b/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.005 deleted file mode 100644 index 867c947..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.005 and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.006 b/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.006 deleted file mode 100644 index 3c77b80..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.006 and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.COM b/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.COM deleted file mode 100644 index 5a9e5b3..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/MTPLUS.COM and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/OVLMGR.MAC b/software/CPM/CPM12_PASCALMTP_v561/OVLMGR.MAC deleted file mode 100644 index eef2ed9..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/OVLMGR.MAC +++ /dev/null @@ -1,450 +0,0 @@ -;---------------------------------------------------------------------- -; [PASLIB] OVLMGR.MAC: Overlay manager for CP/M Pascal/MT+ (80). -; @OVL, @ -; Written 3/18/81 (MGL) -; Revisions: -; 12/16/81 Last MGL update. -; 7/22/83 Added decrement on incoming @OVS overlay number so user does not -; have to adjust overlay number (SP). -; -; -;---------------------------------------------------------------------- - -;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++; -; equates for pertinant information ; -;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++; - -ovlbase equ 0105h ;base prefix for file name -namelen equ 010Dh ;length of names (6 or 7 characters) -TRUE EQU -1 -FALSE EQU 0 ;FOR CONDITIONAL ASSEMBLY - -RELOAD EQU TRUE ;RELOADING OVERLAY CALLING - -;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++; -; MACRO DEFINITIONS ; -;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++; - -MOVE MACRO SRC,DST,LEN - LOCAL L1 - LXI H,SRC - LXI D,DST - LXI B,LEN -L1: - MOV A,M - INX H - STAX D - INX D - DCX B - MOV A,B - ORA C - JNZ L1 - ENDM - -;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++; -; PUBLIC AND EXTRN SYMBOLS ; -;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++; - - EXTRN @XXXX1 ;address of overlay area table - ;set up by LINKMT >= 5.25.1 - PUBLIC @OVL ;OVERLAY LOADER - PUBLIC @OVS ;OVERLAY DISK SET - (FOR OTHER THAN DEFAULT DISK) - -;###############################################################; -; ; -; MAIN ROUTINE - @OVL ; -; PURPOSE - LOAD OVERLAY AND CALL PROCEDURE ; -;---------------------------------------------------------------; -; ON ENTRY TO @OVL, RETURN ADDRESS POINTS TO OVERLAY CALL ; -; DATA BLOCK: ; -; ; -; +0 : OVERLAY GROUP NUMBER --- 1 BYTE ; -; +1 : OVERLAY PROCEDURE NAME-- 8 BYTES ; -; ; -;###############################################################; - -@OVL: - POP H - MOV A,M - STA OVLGNUM - - INX H - MVI B,8 - LXI D,PROCNAME - -OVL1: - MOV A,M - INX H - STAX D - INX D - DCR B - JNZ OVL1 - - CALL PSH$USR$RET ;SAVE USER'S RETURN ADDRESSES - - CALL LOAD$OVLY ;GO LOAD IT (IF NECESSARY) - - CALL FIND$PROC ;GO SEARCH FOR AND FIND PROCNAME - ;DOES NOT RETURN IF PROC NOT FOUND - - - LXI H,OUR$RET ;PUSH OUR RETURN ADDRESS ON THE STACK - PUSH H - - LHLD PROCADR ;GET ADDRESS OF PROC WITHIN OVERLAY AREA - PCHL ;AND OFF TO USER ROUTINE - -OUR$RET: - CALL POP$USR$RET ;MAY RELOAD OLD OVERLAY GROUP - PCHL ;AND BACK TO THE USER (SIMPLE CASE) - -;###############################################################; -; ; -; MAIN ROUTINE - @OVS ; -; PURPOSE - SET DRIVE NUMBER FOR A SPECIFIC OVERLAY ; -; INPUT - ON STACK : OVLNUM,DRIVE ; -; OVLNUM : 1..50 ; -; DRIVE : '@'..'O' ; -; ; -; PASCAL DEFINITION: ; -; ; -; EXTERNAL PROCEDURE @OVS(OVNUM:INTEGER; DRNUM:CHAR); ; -; ; -;###############################################################; - -@OVS: - POP H ;RET ADR - POP B ;DRIVE NUMBER - POP D ;OVERLAY NUMBER - PUSH H - - MOV A,C - SUI '@' ;MAKE 0..19 - - LXI H,DRIVE$TAB - dcx d ;7/22/83 so user does not have to adjust ovl number. - DAD D - MOV M,A - RET - -;===============================================================; -; SUBROUTINE: CALC$ADDR ; -; PURPOSE : CALC OVERLAY AREA ADDRESS BASED ON OVLGNUM ; -;===============================================================; -CALC$ADDR: - LDA OVLGNUM ;GET REQUESTED GROUP NUMBER - DCR A - RAR - RAR - RAR ;DIVIDE BY 8 - ANI 1EH - MOV E,A - MVI D,0 - LHLD @XXXX1 ;GET ADDR OF OVERLAY AREA TABLE - DAD D ;POINT TO TABLE ENTRY - MOV E,M - INX H - MOV D,M - XCHG ;HL NOW POINTS TO OVERLAY AREA - SHLD OVLAREA ;SAVE IT FOR LATER - RET - -;===============================================================; -; SUBROUTINE: PSH$USR$RET ; -; PURPOSE : SAVE CONTENTS OF HL, OVERLAY AREA ADDR ; -; AND OVERLAY GROUP NUMBER ON USR$RET STACK ; -;===============================================================; - PUBLIC PSH$USR$RET - -PSH$USR$RET: - PUSH H - CALL CALC$ADDR - MOV B,H - MOV C,L - POP D - - LHLD USR$SP ;GET STACK POINTER - DCX H - MOV M,D ;STORE RET ADDR - DCX H - MOV M,E - DCX H - MOV M,B ;STORE OVERLAY AREA ADDR - DCX H - MOV M,C - DCX H - LDAX B ;GET OVERLAY NUMBER - MOV M,A - SHLD USR$SP - RET - -;===============================================================; -; SUBROUTINE: POP$USR$RET ; -; PURPOSE : POP RET ADDR, OVERLAY AREA ADDR AND NUMBER ; -; IF RELOAD IS SET TO TRUE THEN THIS ROUTINE ; -; WILL CALL LOAD$OVLY TO RE-LOAD PREVIOUS ; -; OVERLAY IF NECESSARY ; -;===============================================================; - PUBLIC POP$USR$RET - -POP$USR$RET: - LHLD USR$SP - MOV A,M - STA OVLGNUM ;SAVE OVERLAY GROUP NUMBER - INX H - MOV E,M - INX H - MOV D,M - INX H ;DE NOW CONTAINS OVERLAY AREA ADDRESS - XCHG - SHLD OVLAREA - XCHG - MOV E,M - INX H - MOV D,M ;DE NOW CONTAINS CALLERS RETURN ADDRESS - INX H - SHLD USR$SP - XCHG ;PUT REAL ADDR INTO HL -;---------------------------------------------------------------- - IF RELOAD ; THEN RELOAD OLD OVERLAY IF NECESSARY - PUSH H - LDA OVLGNUM - ORA A - CNZ LOAD$OVLY ;ELSE GO LOAD IT IN AGAIN (IF NECESSARY) - POP H ;GET RET ADDR BACK AGAIN - ENDIF -;---------------------------------------------------------------- - RET ;BACK TO MAIN @OVL ROUTINE - - -;===============================================================; -; SUBROUTINE: LOAD$OVLY ; -; PURPOSE : USING OVLADDR AND OVLBASE LOAD THE OVERLAY ; -;===============================================================; - -LOAD$OVLY: - CALL CALC$ADDR ;SETS OVLAREA AND HL-REG - LDA OVLGNUM ;GET GROUP NUMBER BACK AGAIN - CMP M ;IS REQUESTED OVERLAY IN THE AREA? - RZ ;RETURN IF ALREADY LOADED -; -; IF NOT LOADED THEN CONSTRUCT NAME AND LOAD IT -; - MOVE OVLBASE,MYFCB+1,8 - - LDA OVLGNUM - DCR A - MOV E,A - MVI D,0 - LXI H,DRIVE$TAB - DAD D - MOV A,M ;GET DRIVE NUMBER FROM TABLE - STA MYFCB ;FOR NOW DEFAULT DRIVE ONLY - - MVI A,'0' - STA MYFCB+9 - LDA OVLGNUM - RAR - RAR - RAR - RAR - CALL CV2HX ;CONVERT HIGH NIBBLE - STA MYFCB+10 - LDA OVLGNUM - CALL CV2HX ;CONVERT LOW NIBBLE - STA MYFCB+11 - - LXI H,MYFCB+12 - MVI B,23 ;NUMBER OF EXTRA BYTES -LO2: - MVI M,0 - INX H - DCR B - JNZ LO2 - - LXI D,80H ;SET DEFAULT DMA ADDRESS - MVI C,26 - CALL 5 - - LXI D,MYFCB - MVI C,15 ;FILE OPEN - CALL 5 ;GO OPEN THE FILE - CPI 255 - JZ NO$FILE ;BR IF FILE NOT FOUND -; -; OK, NOW LOAD IT UNTIL EOF -; - LHLD OVLAREA ;GET OVERLAY AREA ADDRESS - SHLD DMAPTR - -LO3: - LHLD DMAPTR - XCHG - MVI C,26 - CALL 5 ;SET DMA - - LHLD DMAPTR - LXI D,128 - DAD D - SHLD DMAPTR - - LXI D,MYFCB - MVI C,20 ;SEQUENTIAL READ - CALL 5 - - ORA A - JZ LO3 ;IF MORE TO DO THEN GO-ON - - RET ;ELSE ALL DONE, EXIT -; -; INTERNAL ROUTINE - CV2HX -; LOW ORDER 4-BITS OF A-REG CONTAIN BINARY NUMBER -; RETURN ASCII CHAR IN A-REG -; -CV2HX: - ANI 0FH - ADI '0' - CPI 03AH - RC ;RETURN IF A VAILD DIGIT - ADI 7 - RET - -;===============================================================; -; SUBROUTINE: FIND$PROC ; -; PURPOSE : GIVEN PROCEDURE NAME IN PROCNAME ; -; RETURN ADDRESS OF THIS PROCEDURE IN ; -; PROCADR ; -;===============================================================; - -FIND$PROC: - - LHLD OVLAREA ;GET ADDR OF OVERLAY AREA - INX H - MOV E,M - INX H - MOV D,M ;POINT TO TABLE - XCHG - -FP1: - MOV A,M - ORA A - JZ NO$PROC - - LXI D,PROCNAME - LDA NAMELEN - MOV B,A - PUSH H ;SAVE ADDR OF TABLE ENTRY - -FP2: - LDAX D - CMP M - JNZ FP3 ;BR IF NO MATCH - - INX H - INX D - DCR B - JNZ FP2 ;BR IF MORE TO COMPARE -; -; WE FOUND IT...... -; - POP H ;GET BASE ADDR OF TABLE ENTRY - LXI D,8 ;BYPASS NAME - DAD D - MOV E,M - INX H - MOV D,M - XCHG - SHLD PROCADR - RET ;AND EXIT - -FP3: - POP H - LXI D,10 - DAD D - JMP FP1 - -;===============================================================; -; ERROR MESSAGE PRINTING ROUTINES ; -;===============================================================; - -NO$FILE: ;***OVERLAY FILE NOT FOUND*** - - MOVE MYFCB+1,NFMSG1+2,8 ;MOVE IN NAME - MOVE MYFCB+9,NFMSG1+11,3 ;MOVE IN EXTENSION - LDA MYFCB - ADI '@' - STA NFMSG1 - LXI D,NFMSG - CPI '@' - JNZ WMSG - LXI H,' ' - SHLD NFMSG1 ;CHANGE "@:" TO " " - -WMSG: MVI C,9 ;PRINT STRING - CALL 5 - MVI C,0 ;INITIALIZE - CALL 5 - -NFMSG: - DB 13,10,'Unable to open overlay file: ' -NFMSG1: DB '@: . ',13,10,'$' - -NO$PROC: ;***PROCEDURE NAME NOT FOUND*** - - MOVE MYFCB+1,NPMSG2+2,8 ;MOVE IN NAME - MOVE MYFCB+9,NPMSG2+11,3 ;MOVE IN EXTENSION - LDA MYFCB - ADI '@' - STA NPMSG2 - CPI '@' - JNZ NP1 - LXI H,' ' - SHLD NPMSG2 -NP1: - MOVE PROCNAME,NPMSG1,8 - LXI D,NPMSG - JMP WMSG - -NPMSG: - DB 13,10,'Procedure: "' -NPMSG1: DB ' " not found in overlay: ' -NPMSG2: DB '@: . ',13,10,'$' - -;***************************************************************; -; ; -; DATA AREA FOR OVERLAY MANAGER ; -; ; -;***************************************************************; -; -; NOTE THIS TABLE MUST BE IN THE CSEG AREA BECAUSE IS MUST -; BE INITIALIZED VIA DB AND LINKMT WILL NOT SUPPORT INITIALIZED -; DATA IN THE DSEG -; - -DRIVE$TAB: ;DRIVE TABLES FOR 50 OVERLAYS - - REPT 50 - DB 0 - ENDM - -USR$SP: DW USR$RET ;USR$RET STACK POINTER - ;THIS MUST ALSO BE IN CODE SEG - DSEG - -DMAPTR: DS 2 ;DMA ADDRESS FOR INPUT XFER -PROCNAME: DS 8 ;NAME OF PROCEDURE WHICH WE ARE CALLI -NG -OVLGNUM: DS 1 ;OVERLAY NUMBER -PROCADR: DS 2 ;PROCEDURE ADDRESS -MYFCB: DS 36 ;FCB FOR FILE OPENING -; -; USR$RET STACK CONTAINS RETURN ADDRESS AND -; SAVED OVERLAY AREA ADDRESS -; AND OVERLAY GROUP NUMBER ;(MAX NESTING 25 - - DS 129 ;SAVED RETURN ADDRESSES -USR$RET: -OVLAREA: DS 2 ;LOC OF MOST RECENT OVL AREA - - END - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/PASLIB.ERL b/software/CPM/CPM12_PASCALMTP_v561/PASLIB.ERL deleted file mode 100644 index cf524db..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/PASLIB.ERL and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/PINI.SRC b/software/CPM/CPM12_PASCALMTP_v561/PINI.SRC deleted file mode 100644 index fd28ba9..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/PINI.SRC +++ /dev/null @@ -1,78 +0,0 @@ -MODULE INITIALIZE; - -CONST - HW_STACK_SIZE = 128; (* NUMBER OF BYTES RESERVED FOR HARDWARE STACK *) - (* CHANGE IS HEAVY RECURSION IS USED *) - -(*$I FIBDEF.LIB*) - -VAR - SYSMEM : EXTERNAL INTEGER; (* TOP OF HEAP *) - @SFP : EXTERNAL INTEGER; (* TOP OF RECURSION STACK *) - @EFL : ^INTEGER; (* USED BY FULLHEAP *) - @FRL : RECORD - LINK : ^INTEGER; - SIZE : INTEGER - END; (* USED ALSO BY FULLHEAP *) - - INPUT, - OUTPUT: FIB; (* DEFAULT CONSOLE FILES *) - - @TFN: STRING[2]; (* FOR TEMP. FILE NAMES *) - - @SYSIN, - @SYSOU: INTEGER; (* I/O VECTORS *) - - @RNC, - @WNC: EXTERNAL INTEGER; (* REALLY SUBROUTINES BUT JUST *) - (* NEED THESE TO GET THEIR ADDRESSES *) - - -(*$E-*) (* HIDE GETSP *) - -FUNCTION GETSP:INTEGER; -VAR - TEMPINT: INTEGER; (* FOR CAPTURING STACK POINTER *) -BEGIN - INLINE("LXI H / 0 / 0 / "DAD SP / "SHLD / TEMPINT); - GETSP := TEMPINT -END; - -(*$E+*) - -PROCEDURE @INI; -BEGIN - @FRL.LINK := NIL; - @FRL.SIZE := 0; - @EFL := NIL; - SYSMEM := ADDR(SYSMEM) + 2; (* SO SYSMEM POINTS TO FREE AREA *) - @SFP := GETSP - HW_STACK_SIZE; - @TFN := '00'; - WITH INPUT DO - BEGIN - IOSIZE := 1; - BUFLEN := 1; - OPTION := FCONIO; - FTEXT := TRUE; - FBUFFER[0] := ' '; - FBUFADR := WRD(ADDR(INPUT.FBUFFER)) - END; - - WITH OUTPUT DO - BEGIN - IOSIZE := 1; - BUFLEN := 1; - OPTION := FCONIO; - FTEXT := TRUE; - FBUFFER[0] := ' '; - FBUFADR := WRD(ADDR(OUTPUT.FBUFFER)) - END; - - @SYSIN := ADDR(@RNC); - @SYSOU := ADDR(@WNC) - -END; - -MODEND. - - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/PROG.SRC b/software/CPM/CPM12_PASCALMTP_v561/PROG.SRC deleted file mode 100644 index b1faa9b..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/PROG.SRC +++ /dev/null @@ -1,34 +0,0 @@ -PROGRAM DEMO_PROG; - -VAR - I : INTEGER; (* TO BE ACCESSED BY THE OVERLAYS *) - CH: CHAR; - -EXTERNAL [1] PROCEDURE OVL1; (* COULD HAVE HAD PARAMETERS *) - -EXTERNAL [2] PROCEDURE OVL2; (* ALSO COULD HAVE HAD PARAMETERS *) - -(* EITHER COULD ALSO HAVE BEEN A FUNCTION IF DESIRED *) - -BEGIN - REPEAT - WRITE('Enter character, A/B/Q: '); - READ(CH); - CASE CH OF - 'A','a' : BEGIN - I := 1; (* TO DEMONSTRATE ACCESS OF GLOBALS *) - OVL1 (* FROM AN OVERLAY *) - END; - - 'B','b' : BEGIN - I := 2; - OVL2 - END - ELSE - IF NOT(CH IN ['Q','q']) THEN - WRITELN('Enter only A or B') - END (* CASE *) - UNTIL CH IN ['Q','q']; - WRITELN('End of program') -END. - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/PUT.SRC b/software/CPM/CPM12_PASCALMTP_v561/PUT.SRC deleted file mode 100644 index 99c18a9..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/PUT.SRC +++ /dev/null @@ -1,23 +0,0 @@ -MODULE PUTREC; -(* - * [PASLIB] PUT - Pascal PUT operation. - * Revisions: - * - * - *) - -(*$I fibdef.lib*) - -VAR - @LFB: EXTERNAL ^FIB; - -EXTERNAL PROCEDURE @WNB; - -PROCEDURE PUT(VAR F:FIB; SZ:INTEGER); -BEGIN - @LFB := ADDR(F); - @WNB (* GO WRITE BUFFER OUT *) -END; - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/RANDOMIO.ERL b/software/CPM/CPM12_PASCALMTP_v561/RANDOMIO.ERL deleted file mode 100644 index f2ed091..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/RANDOMIO.ERL and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/READ.ME b/software/CPM/CPM12_PASCALMTP_v561/READ.ME deleted file mode 100644 index 7f2bd7f..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/READ.ME +++ /dev/null @@ -1,727 +0,0 @@ - - - - - - - - - - - ******************************************************************** - ******************************************************************** - ********************** ********************* - ********************** PASCAL/MT+ ********************* - ********************** ********************* - ******************************************************************** - ******************************************************************** - ********** ********** - ******* Release Notes ******* - ****** ****** - ******************************************************************** - ******************************************************************** - ******************************************************************** - ***** ***** - ***** Copyright (c) 1983 by Digital Research ***** - ***** ***** - ***** CP/M is a registered trademark of Digital Research. ***** - ***** ***** - ******************************************************************** - - - - - These release notes pertain to both the software and the - documentation set for the Digital Research product: - - Pascal/MT+ For the CP/M Family of Operating Systems - - They provide the most current information regarding: - - o Sofware bugs that have been identified since the product - was released. - - o Errors or omissions in the documentation set that could - not be corrected because of the lead time needed for - typesetting and printing. - - - - - - - - - - - - - - - - - - 1 - - - - - - - - SOFTWARE BUGS - - - - The following software bugs have been identified in the current - release (5.6): - - - - Problem: When compiling with the D (debugger) command-line option - enabled, symbol table overflow is not always detected. - This problem is related to the total number of constants, - types, and variables declared in the program you are - compiling. - - Solution: Reduce the number of entries in the symbol table by - breaking the program down into separately compiled - modules. - - Problem: Conformant arrays do not always work correctly. They work - for one-dimensional arrays of simple types. They do not - work for one-dimensional arrays of structured types, or - multi-dimensional arrays of any type. - - Solution: There is no fix available at this time. Work is in - progress. - - Problem: Run-time range checking enabled by the $R+ source-code - option does NOT work when indexing into string variables. - - Solution: Use the predefined functions and procedures for string - handling when working with the STRING data type. - - Problem: The ODD function does not return values in the set [0,1]. - - Solution: Application Note #3, available through Technical Support - fixes this problem. - - Problem: The $K9 and $K10 compiler options cause the compiler to - erroneously issue Error #103 upon encountering the EXIT - procedure. - - Solution: If you intend to use EXIT, you cannot use the $K9 and $K10 - options. - - Problem: Using the construct - - WRITE(f,data) - - with files of characters is NOT equivalent to the - sequence of statements - - f^ := data, PUT (f) - - Solution: Declare the file variable f, to be of type BYTE. - - - - 2 - - - - - - - - - Problem: The compiler does not detect the erroneous assignment of a - REAL number to a variable of type WORD. A program - containing such an assignment will compile and link - properly, but will halt indefinitely when executed. - - Solution: Do not assign a REAL variable to a variable of type WORD; - it is an invalid assignment. - - Problem: When using FPREALS.ERL, some formatted real numbers in the - interval (0,1) default to scientific notation on output. - - Solution: There is no fix available at this time; the problem is - being studied. - - Problem: The procedures BLOCKREAD and BLOCKWRITE do not work - correctly on operating systems with allocation block - sizes larger than 1K because the correct extents are not - always opened. - - Solution: On systems with allocation block sizes greater than 1K, - you must use the procedures SEEKREAD and SEEKWRITE with - the file variable declared as follows: - - VAR - f : FILE of PACKED ARRAY[0..127] OF BYTE - - Problem: The MOD function does not work correctly when the modulus - is a negative integer; otherwise, it works correctly. - - Solution: There is no fix available at this time; the problem is - being studied. In the interim, do not use MOD with - negative modulus. - - Problem: When using BCD reals, the run-time system does not detect - division by zero. This problem can indefinitely halt the - application program. - - Solution: You can avoid this problem by adding code to the program - that tests the divisor for zero BEFORE performing the - division, and takes appropriate action based on the - outcome. - - Problem: When using BCD reals, dividing a very small number (such - as 0.0001) by a very large number (such as - 10000000000000.0000) can cause an indefinite halt in the - application program. - - Solution: There is no solution at this time; the problem is being - studied. - - Problem: When using BCD reals, multiplication and division are very - slow. - - Solution: This performance problem is currently being studied. - - - - 3 - - - - - - - - ************************************** - * SPECIAL INSTRUCTIONS FOR SPP USERS * - ************************************** - - - - The Speed Programming Package SPP, as distributed will NOT run with - Pascal/MT+ release 5.6. You must use the utility program SPPFIX.COM - to remove the excess entry point names from the name tables at the - end of the overlay file SPP.002. SPPFIX.COM is included with the - 5.6 distribution disks. - - Note: The file STRIP.SRC, supplied on your distribution disk will - NOT work on SPP.002. (See Documenatation Errata, below). - - In order to get SPP to run with Pascal/MT+ (release 5.6), you must - perform the following steps: - - 1) Compile NSB.SRC - - 2) Change the linker command file SPPMAIN.CMD as follows - - /V:1700/D:8300/X:1500 - - 3) Change all the other CMD files to - - /P:1700 - - 4) Link the SPP files using the SUBMIT command - - A>submit linkspp - - 5) Use the command - - A>sppfix 1700 [:] - - to strip all the unused entry points. - - - - - - - - - - - - - - - - - - - - - - 4 - - - - - - - - **************************************** - * AMD9511 HARDWARE MATH CHIP INTERFACE * - **************************************** - - - - The distribution disks contain several files that enable you to - create a hardware floating point package using the AM9511 math chip. - - To use this interface you must perform the following steps: - - - 1) Edit the file AMDIO.SRC, on your distribution disk, so that the - constant definitions for the port addresses agree with your - hardware configuration. - - 2) Compile AMDIO.SRC. - - 3) Link the application with the following command line: - - A>LINKMT ,AMDIO,FPRTNS,TRAN9511,FPREALS/S,PASLIB/S - - 4) To use an early release of the AM9511 chip, declare @I95 as an - external procedure and call it from the main program. This - routine will initialize the chip. - - Note: The file APUSUB.MAC contains the AMD9511 drivers that TRAN9511 - uses and is included for your information only. APUSUB.MAC does NOT - need to be assembled because it is alreadly included in - TRAN9511.ERL. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 5 - - - - - - - - ************************ - * DOCUMENTATION ERRATA * - ************************ - - - - The following are errors in the Pascal/MT+ Language Reference Manual - (February 1983 edition): - - - Page 2-2. Replace the second paragraph with following: - - "You cannot use reserved words such as BEGIN or IF as - identifiers. Also, you should not use predefined - identifiers to name any object in your program, - especially if the predefined identifier is the name of - a routine in the run-time library PASLIB.ERL. Using - the name of a run-time routine as an identifier makes - the routine inaccessible from inside the scope of the - new definition. This will cause unpredictable results - in your program. - - Page 3-3. Change WORD(x) to WRD(x) - - Page 6-2. Change the third paragraph to read: - - "The data type for a function must be a simple type. - Put the type name after a colon at the end of the - function heading. - - Page 6-8. In Table 6-1, change the Returns type for the Function - ABS from REAL to "same as NUM". - - Page 6-10. In Table 6-1, the Function @HERR returns a BOOLEAN type, - and the the Function ADDR returns a POINTER not an - INTEGER type. Also change FUNCTION @RLS to PROCEDURE - @RLS. - - Page 6-12. Change the first sentence in the second paragraph to - read: - - "You can use ADDR to reference external variables." - - Page 6-13. Change the example to ARCTAN(1) = 0.78539 - - Page 6-19. Change the first sentence in the second paragraph to - read: - - "CLOSEDEL closes and deletes files after use." In the - last paragraph, change File Control Blocks (FCBs) to - File Information Blocks (FIBs). - - - - - - - - 6 - - - - - - - - Page 6-44. Change the explanation of the PACK and UNPACK functions - to read: - - "The Pascal/MT+ compiler accepts PACK and UNPACK for - compatibility with other versions of Pascal. These - procedures are not necessary because Pascal/MT+ is byte - oriented. However, in Pascal/MT+ both PACK and UNPACK - generate calls to the MOVE function (see MOVE)." - - Page 6-56. At the top of the page, change - - SEEKREAD, SEEKWRITE Function - - to read as follows: - - SEEKREAD, SEEKWRITE Procedure - - Page 6-68. Change the fifth paragraph to read: - - "WRITE and WRITELN treat strings as arrays of - characters. They do not write the length byte to TEXT - files. They do write the length byte to files of other - types." - - Page 6-75. At the top of the page, change - - @HERR Function - - to read as follows: - - @HERR - - Also, change the syntax description from - - FUNCTION @HERR - - to read as follows: - - VAR - @HERR : EXTERNAL BOOLEAN - - - Page 7-2. In the second paragraph, change F2 to F3 in: - - F2^ := 45; - - puts the integer value 45 in the buffer of the file - variable F2. - - Page 7-5. Add the following to the end of the first paragraph in - Section 7.4: - - "Note: You cannot use the debugger with redirected I/O. - - - - - - 7 - - - - - - - - The following are errors in the Pascal/MT+ Programmer's Guide for - the CP/M Family of Operating Systems (March 1983 edition): - - - Page 1-1. In the third paragraph, change 8K bytes to 3K bytes. - - Page 1-3. In Table 1-1, under filetype SRC, make the change - - "(the compiler also accepts PAS as a source filetype)" - - Page 1-3. In Table 1-1, under filetype SYM, make the change - - "Symbol file used by SID, the symbolic debugger" - - Page 1-4. In Table 1-2, change DEMOPROG.SRC to PROG.SRC, and - LIBMT+.COM to LIBMT.COM. - - Page 1-5. In Table 1-2, change USCD-style to UCSD-style. - - Page 1-7. The second paragraph states you can use the distribution - disks just as they are. This is not true; they are - write-protected. You must copy them onto backup disks. - - Page 2-3. Change the first paragraph in Section 2.2.2 to read: - - "During Phase 0, When the compiler finds a syntax - error, it displays the line containing the error. If - you are using the MTERRS.TXT file, the compiler also - displays an error description. In all other Phases, - the compiler displays the line number and an error - identification number." - - Page 2-4. In Table 2-1, change the description of the default - action for the A option to read - - "Compiler does not automatically chain" - - Page 2-16. Table 2-5 is incomplete. Add the following error - message: - - Undefined symbol: xxxxxxxxx - - Explanation: The specified symbol is referenced but not - defined in the module. - - - - - - - - - - - - - - - 8 - - - - - - - - Page 3-6. Section 3.2.2, second paragraph. Change the first - sentence to read as follows: - - "When part of a program calls an overlay-resident - routine, the program accesses that routine through an - entry-point table at the end of the overlay." - - Page 3-9. In the first paragraph, change 80H to 100H. - - Page 3-9. Under the /X option, in the second paragrap, change the - last sentence to read as follows: - - "nnnn is the hexadecimal number of bytes to reserve for - overlay data." - - Page 3-10. In the first paragraph, change the last sentence to read - as follows: - - "The minimum value for /D is: 100H + size of the - largest overlay (rounded to the next multiple of 128) + - the size of the root code." - - Page 3-10. Change the fourth paragraph to read as follows: - - "When you link a root program the first time to - generate the SYM file, you must use the /V:n option to - tell the linker to save an area in the code segment for - use as the overlay area address table." - - Page 3-10. Change the command line for linking an overlay to: - - LINKMT =/O:n,/P:mmmm/X:ssss - - - Page 3-11. Change section 3.2.5 to 3.2.6. Insert section 3.2.5 as - follows: - - 3.2.5 Overlay Name Table - - The first three bytes of an overlay file are the - overlay number followed by a two byte pointer to the - name table for the overlay. Entries in the name table - are ten bytes long, eight bytes for the name followed - by two bytes for the address. - - After the overlay manager ensures that the overlay is - in memory, it searches this table for the requested - routine. The overlay manager then branches to the - address found in the name table. - - The linker always includes all entry points to the - overlay, including run-time routines, in this name - table even if only one of the entry points is - necessary. - - - - - 9 - - - - - - - - STRIP is a utility program which reduces the disk and - memory requirements for overlays by removing - unnecessary entry point names from the name table at - the end of an overlay file. - - Note: STRIP is included on the distribution disk in - source form (STRIP.SRC) only. - - In order to use STRIP, you must know: - - o the load address of the overlay (the parameter to - the V and P linker options). This is used to calculate - the offset of the name table within the overlay file. - - o the names of all the essential entry points. For - example, those declared as EXTERNAL in your Pascal - program or module. - - - You invoke STRIP with the command: - - STRIP [] - - If you omit the , STRIP prompts you for the - filename. You then enter the name of the overlay file, - for example ROOT.001. STRIP then prompts you for the - base address, the loading address. You then enter the - hexadecimal address of the overlay area into which you - want the overlay file to be loaded when it is executed, - for example 1600. - - STRIP first displays all of the entry point names, and - then begins displaying each entry point one at a time - followed by the prompt - - (Y/N/Q)? - - If you want to retain the name, enter a Y; otherwise - enter a N if the name is to be removed, or a Q to exit - this phase of the operation. - - When all entry points have been processed, STRIP - displays all of the entry points that have not been - deleted, and asks whether to write the stripped file. - If everything is correct, enter Y, and STRIP deletes - the old file and replaces it with the new stripped - file. - - Page 3-13. Change all three link command lines as follows: - - A>LINKMT PROG,PASLIB/S/V1:2000/D:4000/X:100 - - A>LINKMT PROG=PROG/O:1,MOD1,PASLIB/S/P:2000/L - - A>LINKMT PROG=PROG/O:2,MOD2,PASLIB/S/P:2000/L - - - - 10 - - - - - - - - - Also, change the values described in the text to - reflect the values given in these command lines. - - Page 4-6. In Table 4-1, change the size of the FLOATING REAL data - type to 4 8-bit bytes. - - Page 4-7. Change the paragraph under the example to read: - - "The assembly language program must remove all - parameters from the stack before returning to the - calling routine." - - Page 4-10. Change the example function KEYPRESSED to read as - follows: - - FUNCTION KEYPRESED : BOOLEAN; - - BEGIN - KEYPRESSED := (@BDOS(11,WRD(0)) <> 0) - END; - - - Page 4-12. In the example illustrating INLINE, change LHD to LHLD. - - Page 4-18. Add the following to the end of the second paragraph in - Section 4.4: - - "Note: You should avoid using local variables in - recursive procedures and functions." - - Page 5-4. Add this sentence to the end of the first paragraph: - - "If you want to use breakpoints, you must set them - before starting to debug with the BE or TR commands." - - Page 5-5. In Table 5-2, 320 bytes should be 32 bytes. - - Page 5-6. In Table 5-3, change the syntax of the E command to - - E enables display entry and exit of each - procedure or function during execution - (default is off). - - Page A-15. In the explanation of Error #253, change the limit to 2560 bytes. - - - - - - - - - - - - - - 11 - - - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/RNB.SRC b/software/CPM/CPM12_PASCALMTP_v561/RNB.SRC deleted file mode 100644 index bb847dd..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/RNB.SRC +++ /dev/null @@ -1,95 +0,0 @@ -MODULE RNBMODULE; -(* - * [PASLIB] @RNB - Read next buffer from file. - * Revisions: - * 9/17/80 Last update - * - *) - -(*$I fibdef.lib*) - -VAR - @LFB : EXTERNAL ^FIB; - RESULTIO: EXTERNAL INTEGER; - -EXTERNAL FUNCTION @BDOS(FUNC:INTEGER; PARM:WORD):INTEGER; -EXTERNAL PROCEDURE @DFLT; - -(* PURPOSE: READ n BYTES FROM A FILE POINTED TO BY @LFB *) -(* n IS SPECIFIED BY @LFB^.IOSIZE *) -(* LAST UPDATE: SEPTEMBER 17, 1980 *) - -PROCEDURE @RNB; -VAR - DSTPTR: ^BYTE; - N,I : INTEGER; -BEGIN - MOVE(@LFB^.FBUFADR,DSTPTR,2); (* SET DEST POINTER *) - - IF @LFB^.OPTION = FCONIO THEN (* CON:, DO AN ECHOING READ *) - BEGIN - DSTPTR^ := CHR(@BDOS(1,WRD(0))); (* GO READ A CHAR WITH ECHO *) - IF DSTPTR^ = $0D THEN (* ECHO CR WITH CRLF *) - I := @BDOS(2,WRD($0A)) - ELSE IF DSTPTR^ = $08 THEN (* ECHO BS WITH SP/BS *) - BEGIN - I := @BDOS(2,WRD(' ')); - I := @BDOS(2,WRD($08)) - END; - EXIT - END - ELSE - IF @LFB^.OPTION = FTRMIO THEN (* KBD: DO A NON-ECHO READ *) - BEGIN - REPEAT - DSTPTR^ := CHR(@BDOS(6,WRD($FF))); (* GO READ A CHAR WITH NO ECHO *) - UNTIL DSTPTR^ <> 0; - EXIT - END - ELSE (* check for rdr: *) - IF @LFB^.OPTION = FAUXIO THEN (* RDR: *) - BEGIN - DSTPTR^ := CHR(@BDOS(3,WRD(0))); (* GO READ RDR *) - END; - - IF @LFB^.NOSECTRS THEN - BEGIN - @LFB^.FEOF := TRUE; - EXIT - END; - - FOR N := 1 TO @LFB^.IOSIZE DO - BEGIN - WITH @LFB^ DO - BEGIN - IF FSECINX = 128 THEN (* TIME TO READ MORE *) - BEGIN - FSECINX := 0; - IF NOT NOSECTRS THEN - BEGIN - I := @BDOS(26,WRD(ADDR(FSECTOR))); - RESULTIO := @BDOS(20,WRD(ADDR(FCB))); - IF RESULTIO <> 0 THEN - NOSECTRS := TRUE - END - END; - IF NOSECTRS THEN - BEGIN - DSTPTR^ := CHR($FF); - FEOF := TRUE; - BUFIDX := 0; - @DFLT; - EXIT - END - ELSE - DSTPTR^ := FSECTOR[FSECINX]; - FSECINX := FSECINX + 1 - END; (* WITH *) - DSTPTR := DSTPTR + 1 - END; - @LFB^.BUFIDX := 0; (* SO GNB WORKS *) - @DFLT; (* TO PROTECT USER DATA FROM I/O CLOBBER *) -END; - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/RNC.SRC b/software/CPM/CPM12_PASCALMTP_v561/RNC.SRC deleted file mode 100644 index 1e40fad..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/RNC.SRC +++ /dev/null @@ -1,32 +0,0 @@ -MODULE RDNXCH; -(* - * [PASLIB] @RNC - Read next character from buffer. - * Revisions: - * - * - *) - -(*$I fibdef.lib*) - -VAR - @LFB: EXTERNAL ^FIB; - -EXTERNAL PROCEDURE GET(VAR F:FIB; SZ:INTEGER); - -FUNCTION @RNC:CHAR; -BEGIN - IF @LFB^.OPTION > FRANDOM THEN (* DON'T GIVE BUFFER, BUT READ DIRECTLY *) - (* IF CONSOLE/TERMINAL FILE *) - BEGIN - GET(@LFB^,@LFB^.BUFLEN); - @RNC := @LFB^.FBUFFER[0] - END - ELSE - BEGIN - @RNC := @LFB^.FBUFFER[0]; (* @RNC := F^ *) - GET(@LFB^,@LFB^.BUFLEN); (* GET(F) *) - END -END; - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/ROVLMGR.ERL b/software/CPM/CPM12_PASCALMTP_v561/ROVLMGR.ERL deleted file mode 100644 index cb4d57f..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/ROVLMGR.ERL and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/RST.MAC b/software/CPM/CPM12_PASCALMTP_v561/RST.MAC deleted file mode 100644 index 49e8add..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/RST.MAC +++ /dev/null @@ -1,196 +0,0 @@ -;---------------------------------------------------------------------- -; [PASLIB] RST.MAC: Read string from console with editing priviledges. -; @RST -; Revisions: -; 3/8/81 Last MGL update -; -; -;---------------------------------------------------------------------- - - PUBLIC @RST - - EXTRN @STR - EXTRN @CHW - EXTRN @SYSIN - EXTRN @LFB - EXTRN @CPMRD ;CP/M READ STRING CALLER - ;PROCEDURE @CPMRD(VAR BUF:RDBUF); - ;RDBUF = BYTE,BYTE,ARRAY[1..255] OF CHAR; - -OPTION EQU 56 ;(FREAD,FWRITE,...FLSTOUT) -FCONIO EQU 4 ;USED BY THIS MODULE -FEOLN EQU 59 ;BOOLEAN; -FEOF EQU 60 ;BOOLEAN; - - DSEG -STRBUF: DS 1 - DS 1 - DS 255 ;FOR USING CP/M INPUT - -RETADR: DS 2 -COLCTR: DS 1 ;FOR TAB EXPANSION - - CSEG - -@RST: - XRA A - STA COLCTR - - POP H - SHLD RETADR - - POP H ;GET MAX DEFINED LENGTH - MOV A,L - STA STRBUF - XRA A - STA STRBUF+1 - - LHLD @LFB - LXI D,OPTION - DAD D - MOV A,M - CPI FCONIO - JNZ NONCONSOLE ;BR IF NOT A CONSOLE FILE FOR INPUT - -; -; IF IT IS A CONSOLE FILE THEN USE CP/M READ CONSOLE BUFFER -; - - LXI H,STRBUF - PUSH H - CALL @CPMRD ;GO READ CONSOLE BUFFER FROM CP/M - - LDA STRBUF+1 - ORA A - JZ ENDOFINPUT ;NO CTRL/Z FOUND - LDA STRBUF+2 - CPI 1AH ;CTRL/Z ON INPUT (EOF)? - JNZ ENDOFINPUT - - LHLD @LFB ;GET POINTER TO FIB - LXI D,FEOF - DAD D ;POINT TO END OF FILE BOOLEAN - MVI M,1 - -ENDOFINPUT: ;SHARED CODE - LXI H,STRBUF+1 - PUSH H - LXI H,255 - PUSH H - CALL @STR ;STORE THE STRING - - - LHLD @LFB - LXI D,OPTION - DAD D - MOV A,M - CPI FCONIO ;IF @LFB^.OPTION <> FCONIO THEN BRANCH - JNZ RSTXIT - - MVI C,0DH ;IF A CONSOLE FILE THEN ECHO CRLF - PUSH B - LXI H,-1 - PUSH H - PUSH H - CALL @CHW - LHLD @LFB - LXI D,FEOLN - DAD D - MVI M,1 ;SET @LFB^.EOLN := TRUE - -RSTXIT: - MVI A,0DH ;SO READLN WILL WORK - LHLD RETADR - PCHL - -; -; COME HERE IF NON-CONSOLE READ -; JUST CALL INDIRECT TO @SYSIN UNTIL A CR IS FOUND -; -NONCONSOLE: - LXI H,STRBUF+2 ;POINT TO INPUT BUFFER AREA - MVI A,0 - STA STRBUF+1 ;SET LENGTH - - PUSH H - LHLD @LFB ;GET FIB POINTER - LXI B,FEOLN ;READ CHARS UNTIL EOLN - DAD B - MOV A,M - POP H - RAR - JC ENDOFINPUT - -NEXTCH: - PUSH H - LXI H,RETURN - PUSH H - LHLD @SYSIN - PCHL ;GO CALL THE INPUT ROUTIN - -RETURN: - POP B ;GET CHAR - - - POP H ;GET BUFFER POINTER - LDA STRBUF+1 - CPI 0FFH ;STRING OVERFLOW? - JZ NOSTORE ;IF SO THEN DONT STORE IT - - CALL STORE$WITH$TAB$EXPANSION - - INX H ;BUMP POINTER - LDA STRBUF+1 - INR A - STA STRBUF+1 -NOSTORE: - XCHG - LHLD @LFB ;GET FIB POINTER - LXI B,FEOLN ;READ CHARS UNTIL EOLN - DAD B - MOV A,M - RAR - XCHG - JNC NEXTCH ;LOOP UNTIL EOLN - JMP ENDOFINPUT ;AND WE ARE DONE - -STORE$WITH$TAB$EXPANSION: - MOV A,C - CPI 09H ;TAB CHARACTER? - JZ TAB$EXPAND - MOV M,C - LDA COLCTR - INR A - STA COLCTR - RET - -TAB$EXPAND: - MVI M,' ' ;STORE AT LEAST ONE BLANK - - LDA STRBUF+1 - INR A - STA STRBUF+1 - - LDA COLCTR - INR A - STA COLCTR - - CPI 0FFH ;STRING OVERFLOW? - RZ ;IF SO THEN EXIT - - ANI 7 ;ON BOUNDARY? - JZ DONE$TABBING ;RETURN IF YES - - INX H - JMP TAB$EXPAND - -DONE$TABBING: - PUSH H - LXI H,STRBUF - INX H - DCR M - POP H - RET - - END - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/SPPFIX.COM b/software/CPM/CPM12_PASCALMTP_v561/SPPFIX.COM deleted file mode 100644 index f2fc0e5..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/SPPFIX.COM and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/STRIP.CMD b/software/CPM/CPM12_PASCALMTP_v561/STRIP.CMD deleted file mode 100644 index de5d85e..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/STRIP.CMD +++ /dev/null @@ -1,2 +0,0 @@ -STRIP,RANDOMIO,PASLIB/S - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/STRIP.SRC b/software/CPM/CPM12_PASCALMTP_v561/STRIP.SRC deleted file mode 100644 index 685d1ed..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/STRIP.SRC +++ /dev/null @@ -1,165 +0,0 @@ -PROGRAM STRIPIT; -(* - * STRIP - Selectively remove Overlay Entry Points from an overlay file. - * MT+ overlays may have more than one entry point, and in general, the - * linker will include all external symbols in the Overlay Entry Point - * Table, located at the end of the overlay code. This utility displays - * each of these symbols and prompts you to keep or delete the entry - * point. It is provided for users who require overlay files to be as - * compact as possible. - * - * Usage: - * STRIP filename - * - * If filename is omitted, the program will prompt for one. filename - * must be an overlay file produced by LINKMT (i.e., one with a numeric - * extension). - * - * Revised from the 5.5 version for 5.6 (3/10/83 SP) - * Revisions: - * - * - * - *) - -CONST - maxFileSize = 150; (* Max. overlay file size in 128-byte sectors *) - -TYPE - ALPHA = PACKED ARRAY [1..8] OF CHAR; - - NAMEREC = RECORD - NAME : ALPHA; - ADDR : INTEGER - END; - NAMEARR = ARRAY [0..0] OF NAMEREC; - SECTOR = ARRAY [0..127] OF BYTE; - pstr = ^string; - -VAR - NAMELIST : ^NAMEARR; - I : INTEGER; - BASE : INTEGER; - TITLE : STRING; - INFILE : FILE OF SECTOR; - COUNT : INTEGER; - INLINE : STRING[2]; - NEWSIZE : INTEGER; - cmdline : pstr; - BUF : ARRAY [0..maxFileSize] OF SECTOR; (* Overlay loading area *) - -(* PASLIB: *) -external function @cmd: pstr; (* returns pointer to command line *) - - -PROCEDURE KRUNCH(I:INTEGER); -VAR - J : INTEGER; -BEGIN - REPEAT - NAMELIST^[I] := NAMELIST^[I+1]; - I := I + 1; - UNTIL ORD(NAMELIST^[I].NAME[1]) = 0 -END; - - -PROCEDURE show_table; -var - i : integer; -begin - I := 0; - while namelist^[i].name[1] <> chr(0) do begin - if i mod 6 = 0 then writeln; - WRITE(NAMELIST^[I].NAME, ' '); - I := I + 1 - end; - writeln; - writeln(i, ' entry points remain.'); -end; - - -BEGIN (* main *) - writeln('STRIP 5.6'); - - cmdline := @cmd; - title := cmdline^; - while (title[1] <> ' ') and (length(title) > 0) do - delete(title, 1, 1); (* Remove leading blanks *) - if length(title) = 0 then begin - write('Overlay file name? '); - readln(title); - end; - - ASSIGN(INFILE, TITLE); - RESET(INFILE); - if ioresult = 255 then begin - writeln('Can''t open ', title); - exit; - end; - - COUNT := 0; - WHILE IORESULT <> 1 DO BEGIN - if count = maxFileSize then begin - writeln('File exceeds ', maxFileSize, ' sectors; increase maxFileSize'); - exit; - end; - COUNT := COUNT + 1; - BUF[COUNT-1] := INFILE^; - SEEKREAD(INFILE, COUNT); - END; - WRITELN(Count,' sectors read'); - - WRITE('Base address for this overlay (hex)? '); - READHEX(INPUT, BASE, 2); - - MOVE(BUF[0,1],I,2); (* Get pointer to Overlay Entry Point Table *) - WRITE('Entry point table begins at '); WRITEHEX(OUTPUT,I-BASE,2); WRITELN; - - NAMELIST := ORD(ADDR(BUF)) + (I-BASE); - show_table; - - I := 0; - repeat - repeat - WRITE('Retain ', NAMELIST^[I].NAME,' (Y/N/Q)? '); - READLN(INLINE); - until inline[1] in ['Y','y','N','n','Q','q']; - IF inline[1] in ['N','n'] THEN - KRUNCH(I) - ELSE - I := I + 1; - until (NAMELIST^[I].NAME[1]=CHR(0)) OR (inline[1] in ['Q','q']); - - if inline[1] in ['Q','q'] then (* advance i to end of table *) - while namelist^[i].name[1] <> chr(0) do - i := i + 1; - - (* Now write it out *) - - show_table; - - NEWSIZE := (ORD(ADDR(NAMELIST^[I].NAME))-ORD(ADDR(BUF))); - IF (NEWSIZE MOD 128) <> 0 THEN - NEWSIZE := NEWSIZE + 128; - - WRITELN('New file size is ',NEWSIZE DIV 128,' sectors'); - COUNT := NEWSIZE DIV 128; - - repeat - write('Rewrite ', title, ' (Y/N)? '); - readln(inline); - if inline[1] in ['N','n'] then begin - writeln('File not rewritten.'); - exit; - end; - until inline[1] in ['Y','y']; - - ASSIGN(inFILE,TITLE); - REWRITE(inFILE); - FOR I := 0 TO COUNT-1 DO BEGIN - inFILE^ := BUF[I]; - SEEKWRITE(inFILE,I) - END; - CLOSE(inFILE,I) -END. - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/TRAN9511.ERL b/software/CPM/CPM12_PASCALMTP_v561/TRAN9511.ERL deleted file mode 100644 index 659bac3..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/TRAN9511.ERL and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/TRAN9511.SRC b/software/CPM/CPM12_PASCALMTP_v561/TRAN9511.SRC deleted file mode 100644 index 67f26b9..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/TRAN9511.SRC +++ /dev/null @@ -1,57 +0,0 @@ -MODULE TRAN9511; - -EXTERNAL PROCEDURE @ERR(AN_ERROR:BOOLEAN; ERRNUM:INTEGER); - - -EXTERNAL PROCEDURE @AMD(FUNC:INTEGER;VAR ARG:REAL;VAR STATUS:INTEGER); -{THE PROCEDURE @AMD,INTERFACES TO THE AMD9511 ARITHMETIC PROCESSING UNIT (APU). -THE FIRST ARGUMENT IS THE FUNCTION CODE (AND IS STRAIGHT FROM -THE AM9511 LITERATURE). THE SECOND IS THE ADDRESS OF ARG, A -REAL VARIABLE, THE FUNTION ARGUMENT IS IN ARG, AND THE RESULT -IS RETURNED IN ARG. THE THIRD ARGUMENT IS THE ADDRESS WHERE -THE APU STATUS IS RETURNED.} - -FUNCTION SIN(ARG:REAL):REAL; {SINE FUNCTION} -VAR STATUS:INTEGER; -BEGIN - @AMD($02,ARG,STATUS); - SIN:=ARG; -END; - -FUNCTION COS(ARG:REAL):REAL; {COSINE FUNCTION} -VAR STATUS:INTEGER; -BEGIN - @AMD($03,ARG,STATUS); - COS:=ARG; -END; - - -FUNCTION EXP(ARG:REAL):REAL; {E TO THE X FUNCTION} -VAR STATUS:INTEGER; -BEGIN - @AMD($0A,ARG,STATUS); - IF (STATUS & $1E) = $18 THEN BEGIN - @ERR(TRUE,7); (* TRANCENDENTAL OUT OF RANGE *) - END; - EXP:=ARG; -END; - -FUNCTION LN(ARG:REAL):REAL; {NATURAL LOGARITHM FUNCTION} -VAR STATUS:INTEGER; -BEGIN - @AMD($09,ARG,STATUS); - IF (STATUS & $1E) = $8 THEN BEGIN - @ERR(TRUE,7); - END; - LN:=ARG; -END; - -FUNCTION ARCTAN(ARG:REAL):REAL; {INVERSE TANGENT FUNCTION} -VAR STATUS:INTEGER; -BEGIN - @AMD($07,ARG,STATUS); - ARCTAN:=ARG; -END; - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/TRANCEND.ERL b/software/CPM/CPM12_PASCALMTP_v561/TRANCEND.ERL deleted file mode 100644 index 018a740..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/TRANCEND.ERL and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/UTILMOD.ERL b/software/CPM/CPM12_PASCALMTP_v561/UTILMOD.ERL deleted file mode 100644 index 5967642..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/UTILMOD.ERL and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/UTILMOD.SRC b/software/CPM/CPM12_PASCALMTP_v561/UTILMOD.SRC deleted file mode 100644 index d2cf98f..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/UTILMOD.SRC +++ /dev/null @@ -1,52 +0,0 @@ -MODULE UTILITIES; - -(* USE AS FOLLOWS: - FUNCTION RENAME(F,NEWNAME); MUST BE PRECEEDED BY ASSIGN - PROCEDURE EXTRACT(F,NAME); RETURNS NAME FROM AN FILE - FUNCTION KEYPRESSED : BOOLEAN; TRUE IF KEY PRESSED -*) - -(*$I FIBDEF.LIB*) - -EXTERNAL FUNCTION @BDOS(FUNC,PARM:INTEGER):INTEGER; - -FUNCTION RENAME(VAR F:FIB; VAR NEWNAME:STRING):INTEGER; - -(* TO USE: - - ASSIGN(MYFILE,OLDNAME); - IF RENAME(MYFILE,NEWNAME) = 255 THEN - OLDNAME NOT FOUND IN DIRECTORY - ELSE - RENAME WAS SUCCESSFUL - -*) -VAR - TEMPFILE : RECORD - CASE BOOLEAN OF - TRUE: (FYLE:FILE); - FALSE:(FIBB:FIB) - END; - RESULT:INTEGER; -BEGIN - ASSIGN(TEMPFILE.FYLE,NEWNAME); - MOVE(TEMPFILE.FIBB.FCB,TEMPFILE.FIBB.FCB[16],12); - MOVE(F.FCB,TEMPFILE.FIBB.FCB,12); - RESULT := @BDOS(23,ADDR(TEMPFILE.FIBB.FCB)); - RENAME := RESULT -END; - - -PROCEDURE EXTRACT(VAR F:FIB; VAR OUTNAME : STRING); -BEGIN - OUTNAME := F.FNAME -END; - - -FUNCTION KEYPRESSED:BOOLEAN; -BEGIN - KEYPRESSED := (@BDOS(11,0) <> 0) -END; - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/WNC.SRC b/software/CPM/CPM12_PASCALMTP_v561/WNC.SRC deleted file mode 100644 index e6b5947..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/WNC.SRC +++ /dev/null @@ -1,25 +0,0 @@ -MODULE WRNXCH; -(* - * [PASLIB] @WNC - Write next character. - * Revisions: - * - * - *) - -(*$I fibdef.lib*) - -VAR - @LFB: EXTERNAL ^FIB; - -EXTERNAL PROCEDURE PUT(VAR F:FIB; SZ:INTEGER); - -PROCEDURE @WNC(CH:CHAR); -BEGIN - @LFB^.FBUFFER[0] := CH; (* F^ := CH *) - PUT(@LFB^,@LFB^.BUFLEN) (* PUT(F) *) -END; - -MODEND. - - - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/XBDOS.SRC b/software/CPM/CPM12_PASCALMTP_v561/XBDOS.SRC deleted file mode 100644 index 5bdf20e..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/XBDOS.SRC +++ /dev/null @@ -1,57 +0,0 @@ -MODULE BDOS; -(* - * [PASLIB] @BDOS - Call CP/M directly. - * Revisions: - * This version of @BDOS checks for error returns and calls @IOERR - * as required to report a CP/M error. - * - * - *) - -EXTERNAL PROCEDURE @IOERR(CPMFUNCNUM:INTEGER); - -FUNCTION @BDOS(FUNC:INTEGER; PARM:WORD):INTEGER; -CONST - CPMENTRYPOINT = 5; - -VAR - RESULT : INTEGER; - -BEGIN - INLINE( "LHLD / FUNC / - "MOV C,L / - "LHLD / PARM / - "XCHG / - "CALL / CPMENTRYPOINT / - "MOV L,A / - "MVI H / 0 / - "SHLD / RESULT ); - - @BDOS := RESULT; - - IF FUNC < 15 THEN - EXIT; - IF FUNC = 26 THEN - EXIT; - IF (FUNC=15) OR (FUNC=16) OR (FUNC=22) THEN - BEGIN - IF RESULT = 255 THEN - @IOERR(FUNC) - END - ELSE - IF (FUNC = 21) THEN - IF RESULT <> 0 THEN - @IOERR(FUNC); -END; - -PROCEDURE @DFLT; -(* Set default DMA address. *) -VAR - I : INTEGER; -BEGIN - I := @BDOS(26,WRD($80)); -END; - - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/XREF.COM b/software/CPM/CPM12_PASCALMTP_v561/XREF.COM deleted file mode 100644 index 8f9bc07..0000000 Binary files a/software/CPM/CPM12_PASCALMTP_v561/XREF.COM and /dev/null differ diff --git a/software/CPM/CPM12_PASCALMTP_v561/XREF.DOC b/software/CPM/CPM12_PASCALMTP_v561/XREF.DOC deleted file mode 100644 index 5f480b9..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/XREF.DOC +++ /dev/null @@ -1,23 +0,0 @@ -The files XREF.SRC and XREF.COM are the source and object -of a Pascal cross referencing program. They are public -domain and not specific to Pascal/MT+ (i.e. may be used -to cross reference other Pascal programs). They may -also be used to cross reference other languages if the -keyword table is changed. - -To operate: - -1. Type XREF - -2. XREF asks: Input file? - -3. XREF asks: Output file name? - or - CON: or - LST: - -4. XREF asks: Do you want a listing? (N means No, anything else means YES) - -And that's it! - - \ No newline at end of file diff --git a/software/CPM/CPM12_PASCALMTP_v561/XREF.SRC b/software/CPM/CPM12_PASCALMTP_v561/XREF.SRC deleted file mode 100644 index cb270d3..0000000 --- a/software/CPM/CPM12_PASCALMTP_v561/XREF.SRC +++ /dev/null @@ -1,504 +0,0 @@ -(*====================================================================*) -(* PROGRAM TITLE: PASCAL CROSS-REFERENCING PROGRAM *) -(* *) -(* PROGRAM FILE: XREF.SRC *) -(* *) -(* LAST UPDATE: 09-MAR-81 by Mike Lehman *) -(* *) -(* NOTE: THIS PROGRAM WAS ORIGINALLY WRITTEN BY N. WIRTH AND *) -(* ADAPTED FOR UCSD PASCAL (I.4 - THE PUBLIC DOMAIN VERSION) *) -(* BY SHAWN FANNING (IN 1978) AND SUBSEQUENTLY ADAPTED FOR *) -(* PASCAL/MT+ BY MIKE LEHMAN (IN 1981) AND IS A PUBLIC DOMAIN *) -(* PROGRAM. IF YOU MAKE REVISIONS, ETC. PLEASE LEAVE THE AUTHOR *) -(* AND MODIFIERS NAME IN THE SOURCE FILE. THANK YOU. *) -(* *) -(* PROGRAM SUMMARY: *) -(* *) -(* THIS PROGRAM PRODUCES A CROSS-REFERENCE LISTING FOR ANY *) -(* PASCAL PROGRAM. OCCURENCES ONLY ARE LISTED. NO DISTINCTION IS *) -(* MADE BETWEEN DEFINITIONS AND REFERENCES. *) -(*====================================================================*) - - - -PROGRAM XREF; - -(*CROSS REFERENCE GENERATOR FOR PASCAL PROGRAMS. N.WIRTH, 7.5.74*) -(*'QUADRATIC QUOTIENT' HASH METHOD*) - -CONST - P = 749; (*SIZE OF HASHTABLE*) - NK = 45; (*NO. OF KEYWORDS*) - ALFALEN = 8; - REFSPERLINE = 15; - REFSPERITEM = 5; - - -TYPE - ALFA = PACKED ARRAY[1..ALFALEN] OF CHAR; - INDEX = 0..P; - ITEMPTR = ^ITEM; - WORD = RECORD - KEY: ALFA; - FIRST, LAST: ITEMPTR; - FOL: INDEX - END ; - NUMREFS = 1..REFSPERITEM; - REFTYPE = (COUNT, PTR); - ITEM = RECORD - REF : ARRAY[NUMREFS] OF INTEGER; - CASE REFTYPE OF - COUNT: (REFNUM: NUMREFS); - PTR: (NEXT: ITEMPTR) - END ; - BUFFER = PACKED ARRAY[0..131] OF CHAR; - -VAR - TOP: INDEX; (*TOP OF CHAIN LINKING ALL ENTRIES IN T*) - I,LINECOUNT,BUFCURSOR: INTEGER; (*CURRENT LINE NUMBER*) - FF,CH: CHAR; (*CURRENT CHAR SCANNED *) - BUF,BUF1,BUF2: ^BUFFER; - T: ARRAY [INDEX] OF WORD; (*HASH TABLE*) - KEY: ARRAY [1..NK] OF ALFA; (* RESERVED KEYWORD TABLE *) - ERROR, (* ERROR FLAG *) - LISTING: BOOLEAN; (* LISTING OPTION *) - INFILE: TEXT; - LST : TEXT; - LSTFILENAME : STRING; - INPUT_LINE : STRING; - -PROCEDURE INITIALIZE; -VAR - I : INTEGER; - -PROCEDURE FIRSTHALF; -BEGIN - KEY[ 1] := 'AND '; - KEY[ 2] := 'ARRAY '; - KEY[ 3] := 'BEGIN '; - KEY[ 4] := 'BOOLEAN '; - KEY[ 5] := 'CASE '; - KEY[ 6] := 'CHAR '; - KEY[ 7] := 'CONST '; - KEY[ 8] := 'DIV '; - KEY[ 9] := 'DOWNTO '; - KEY[10] := 'DO '; - KEY[11] := 'ELSE '; - KEY[12] := 'END '; - KEY[13] := 'EXIT '; - KEY[14] := 'FILE '; - KEY[15] := 'FOR '; - KEY[16] := 'FUNCTION'; -END; - -PROCEDURE SECONDHALF; -BEGIN - KEY[17] := 'GOTO '; - KEY[18] := 'IF '; - KEY[19] := 'IN '; - KEY[20] := 'INPUT '; - KEY[21] := 'INTEGER '; - KEY[22] := 'MOD '; - KEY[23] := 'NIL '; - KEY[24] := 'NOT '; - KEY[25] := 'OF '; - KEY[26] := 'OR '; - KEY[27] := 'OUTPUT '; - KEY[28] := 'PACKED '; - KEY[29] := 'PROCEDUR'; - KEY[30] := 'PROGRAM '; - KEY[31] := 'REAL '; - KEY[32] := 'RECORD '; - KEY[33] := 'REPEAT '; - KEY[34] := 'SET '; - KEY[35] := 'STRING '; - KEY[36] := 'TEXT '; - KEY[37] := 'THEN '; - KEY[38] := 'TO '; - KEY[39] := 'TYPE '; - KEY[40] := 'UNTIL '; - KEY[41] := 'VAR '; - KEY[42] := 'WHILE '; - KEY[43] := 'WITH '; - KEY[44] := 'WRITE '; - KEY[45] := 'WRITELN '; -END; - -BEGIN (* INITIALIZE *) - WRITELN; - WRITELN('Pascal/MT+ Program Xref Utility -- Release 5.2'); - WRITELN('This program is public domain'); - WRITELN; - FF:=CHR(12); - NEW(BUF1); - NEW(BUF2); - BUF:=BUF1; - ERROR := FALSE; - FOR I := 0 TO P DO - T[I].KEY := ' '; - FIRSTHALF; - SECONDHALF; - LINECOUNT:= 0; - BUFCURSOR:= 0; - TOP := P; - CH := ' ' -END; (* INITIALIZE *) - - - -PROCEDURE OPENFILES; -VAR - NUMBLOCKS: INTEGER; - OPENOK: BOOLEAN; - OPENERRNUM : INTEGER; - LISTOPTION: CHAR; - FILENAME: STRING; - -BEGIN (* OPEN *) - REPEAT - WRITELN; - WRITE( 'Input file ? ' ); - READLN( FILENAME ); - IF LENGTH(FILENAME) >0 THEN - BEGIN - ASSIGN(INFILE, FILENAME ); - RESET(INFILE) - END; - OPENERRNUM := IORESULT; - OPENOK := ( OPENERRNUM <> 255 ); - IF NOT OPENOK THEN - WRITELN( '*** INPUT OPEN ERROR #', OPENERRNUM ); - UNTIL OPENOK; - - WRITE('Output file name? '); - READLN(LSTFILENAME); - ASSIGN(LST,LSTFILENAME); - REWRITE(LST); - - WRITE( 'Do you want a listing ? ' ); - READ( LISTOPTION ); - LISTING := NOT(LISTOPTION = 'N'); - IF LISTING THEN PUTNUMBER(0); - READLN(INFILE,INPUT_LINE); - WRITELN; -END; (* OPEN *) - - -PROCEDURE LPWRITELN; -VAR - I : INTEGER; -BEGIN - BUF^[BUFCURSOR]:=CHR(13); - BUFCURSOR:=BUFCURSOR+1; - FOR I := 0 TO BUFCURSOR-1 DO - WRITE(LST,BUF^[I]); - IF BUF = BUF1 THEN BUF:=BUF2 ELSE BUF:=BUF1; - BUFCURSOR:=0; - LINECOUNT:=LINECOUNT+1; - IF (LINECOUNT MOD 60) = 0 THEN - PAGE(LST); -END; - -PROCEDURE PUTALFA(S:ALFA); -BEGIN - MOVELEFT(S[1],BUF^[BUFCURSOR],8); - BUFCURSOR:=BUFCURSOR+8; -END; - -PROCEDURE PUTNUMBER(NUM: INTEGER); -VAR I,IPOT:INTEGER; - A: ALFA; - CH: CHAR; - ZAP:BOOLEAN; - -BEGIN - ZAP:=TRUE; - IPOT:=10000; - A[1]:=' '; - FOR I:= 2 TO 6 DO - BEGIN - CH:=CHR(NUM DIV IPOT + ORD('0')); - IF I <> 6 THEN - IF ZAP THEN - IF CH = '0' THEN - CH:=' ' - ELSE ZAP:=FALSE; - A[I]:=CH; - NUM:=NUM MOD IPOT; - IPOT:=IPOT DIV 10; - END; - A[7]:=' '; - MOVELEFT(A,BUF^[BUFCURSOR],7); - BUFCURSOR:=BUFCURSOR+7; -END; - - -PROCEDURE GETNEXTCHAR; -VAR I : INTEGER; -BEGIN - - IF LENGTH(INPUT_LINE) = 0 THEN - READLN(INFILE,INPUT_LINE); - - IF LENGTH(INPUT_LINE) = 0 THEN - CH := ' ' - ELSE - BEGIN - CH:=INPUT_LINE[1]; - DELETE(INPUT_LINE,1,1) - END; - - IF EOF(INFILE) THEN ERROR:=TRUE - ELSE - BEGIN - BUF^[BUFCURSOR]:=CH; - BUFCURSOR:=BUFCURSOR+1; - IF LENGTH(INPUT_LINE) = 0 THEN - BEGIN - BUF^[BUFCURSOR]:=CHR(13); - BUFCURSOR:=BUFCURSOR+1; - LINECOUNT:= LINECOUNT +1; - IF LISTING THEN - BEGIN - IF LSTFILENAME <> 'CON:' THEN - WRITE('.'); - FOR I := 0 TO BUFCURSOR-1 DO - WRITE(LST,BUF^[I]); - IF BUF = BUF2 THEN BUF:=BUF1 ELSE BUF:=BUF2; - BUFCURSOR:=0; - PUTNUMBER(LINECOUNT); - END - ELSE - BEGIN - BUFCURSOR:=0; - WRITE('.') - END; - - IF (LINECOUNT MOD 60) = 0 THEN - BEGIN - IF LISTING THEN PAGE(LST); - WRITELN(OUTPUT,'< ',LINECOUNT:4,',',MEMAVAIL:5,' >'); - END; - END; - END; - END; (* GETNEXTCHAR *) - - -PROCEDURE SEARCH( ID: ALFA ); (*MODULO P HASH SEARCH*) -(*GLOBAL: T, TOP*) -VAR - I,J,H,D : INTEGER; - X : ITEMPTR; - F : BOOLEAN; - -BEGIN - J:=0; - FOR I:= 1 TO ALFALEN DO - J:= J*10+ORD(ID[I]); - H := ABS(J) MOD P; - F := FALSE; - D := 1; - REPEAT - IF T[H].KEY = ID - THEN - BEGIN (*FOUND*) - F := TRUE; - IF T[H].LAST^.REFNUM = REFSPERITEM - THEN - BEGIN - NEW(X); - X^.REFNUM := 1; - X^.REF[1] := LINECOUNT; - T[H].LAST^.NEXT:= X; - T[H].LAST := X; - END - ELSE - WITH T[H].LAST^ DO - BEGIN - REFNUM := REFNUM + 1; - REF[REFNUM] := LINECOUNT - END - END - ELSE - IF T[H].KEY = ' ' - THEN - BEGIN (*NEW ENTRY*) - F := TRUE; - NEW(X); - X^.REFNUM := 1; - X^.REF[1] := LINECOUNT; - T[H].KEY := ID; - T[H].FIRST := X; - T[H].LAST := X; - T[H].FOL := TOP; - TOP := H - END - ELSE - BEGIN (*COLLISION*) - H := H+D; - D := D+2; - IF H >= P - THEN - H := H - P; - IF D = P - THEN - BEGIN - WRITELN(OUTPUT,'TBLE OVFLW'); - ERROR := TRUE - END ; - END - UNTIL F OR ERROR -END (*SEARCH*) ; - - - -PROCEDURE PRINTWORD(W: WORD); -VAR - L: INTEGER; - X: ITEMPTR; - NEXTREF : INTEGER; - THISREF: NUMREFS; -BEGIN - PUTALFA(W.KEY); - X := W.FIRST; - L := 0; - REPEAT - IF L = REFSPERLINE - THEN - BEGIN - L := 0; - LPWRITELN; - PUTALFA(' '); - END ; - L := L+1; - THISREF := (L-1) MOD REFSPERITEM + 1; - NEXTREF := X^.REF[ THISREF ]; - IF THISREF = X^.REFNUM - THEN - X := NIL - ELSE - IF THISREF = REFSPERITEM - THEN - X := X^.NEXT; - PUTNUMBER(NEXTREF); - UNTIL X = NIL; - LPWRITELN; -END (*PRINTWORD*) ; - - - -PROCEDURE PRINTTABLE; - -VAR - I,J,M: INDEX; - -BEGIN - I := TOP; - WHILE I <> P DO - BEGIN (*FIND MINIMAL WORD*) - M := I; - J := T[I].FOL; - WHILE J <> P DO - BEGIN - IF T[J].KEY < T[M].KEY - THEN - M := J; - J := T[J].FOL - END ; - PRINTWORD(T[M]); - IF M <> I THEN - BEGIN - T[M].KEY:=T[I].KEY; - T[M].FIRST:=T[I].FIRST; - T[M].LAST:=T[I].LAST; - END; - I := T[I].FOL - END -END (*PRINTTABLE*) ; - - - -PROCEDURE GETIDENTIFIER; -VAR - J,K,I: INTEGER; - ID: ALFA; - -BEGIN (* GETIDENTIFIER *) - I := 0; - ID := ' '; - REPEAT - IF I < ALFALEN - THEN - BEGIN - I := I+1; - IF ('a' <= CH) AND (CH <= 'z') - THEN - ID[I] := CHR( ORD(CH) - ORD('a') + ORD('A') ) - ELSE - ID[I] := CH - END; - GETNEXTCHAR - UNTIL ( NOT(((CH>='A') AND (CH<='Z')) OR ((CH>='a') AND (CH<='z')) - OR ((CH>='0') AND (CH<='9')))) OR (ERROR); - I := 1; - J := NK; - REPEAT - K := (I+J) DIV 2; (*BINARY SEARCH*) - IF KEY[K] <= ID - THEN - I := K+1; - - IF KEY[K] >= ID - THEN - J := K-1; - - UNTIL I > J; - IF KEY[K] <> ID THEN SEARCH(ID); -END; (* GETIDENTIFIER *) - -BEGIN (* CROSSREF *) - INITIALIZE; - - OPENFILES; - WHILE (NOT(EOF(INFILE))) AND (NOT( ERROR)) DO - BEGIN - IF ((CH>='A') AND (CH<='Z')) THEN - GETIDENTIFIER - ELSE - IF (CH = '''') THEN - BEGIN - REPEAT - GETNEXTCHAR; - UNTIL (CH = '''') OR (ERROR); - GETNEXTCHAR; - END - ELSE - IF CH = '(' THEN - BEGIN - GETNEXTCHAR; - IF CH = '*' THEN - BEGIN - GETNEXTCHAR; - WHILE (CH <> ')') AND (NOT(ERROR)) DO - BEGIN - WHILE (CH <> '*') AND (NOT(ERROR)) DO - GETNEXTCHAR; - GETNEXTCHAR; - END; - GETNEXTCHAR; - END; - END - ELSE - GETNEXTCHAR; - - END; (* WHILE *) - PAGE(LST); - LINECOUNT := 0; - BUFCURSOR := 0; - PRINTTABLE; - PAGE(LST); - CLOSE(LST,I); - IF I = 255 THEN - WRITELN('Error closing output file') -END. - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/ARCTAN.ERL b/software/CPM/CPM13_MTPUG_01/ARCTAN.ERL deleted file mode 100644 index dd73ff9..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/ARCTAN.ERL and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/ARCTAN.SRC b/software/CPM/CPM13_MTPUG_01/ARCTAN.SRC deleted file mode 100644 index 88903a8..0000000 --- a/software/CPM/CPM13_MTPUG_01/ARCTAN.SRC +++ /dev/null @@ -1,85 +0,0 @@ -MODULE ARCTAN5; { Copyright (c) by T. W. Lougheed 24 April 1981 } - - -{ Proposed replacement for current arctangent function. It everywhere -meets the accuracy of the Pascal MT+ to within a factor of 2, often -exceeds it in accuracy by a factor of 10 (especially for tangents of -angles near +PI/2 or -PI/2), and correctly produces angles confined -to the inteval -PI/2 to PI/2, which the installed routine does not. } - -{ First version 5 February 1981 - - By T. W. Lougheed - Dept. T. & A. Mechanics - Thurston Hall, Cornell U. - Ithaca, NY 14853 - - Last version 23 February 1981 - - This software is in the public domain, and may not be sold by any - person or corperation without permission of the author. } - - -{ This code is intended for floating-point arithmatic with an accuracy -of 8 digits or less. } - -function ARCTAN( z :real) :real; - - { | truncation. } - const HALF_PI = 1.570796326; - PI = 3.141592654; - - var AZ :real; - - - { From the HANDBOOK OF MATHEMATICAL FUNCTIONS by Abramowicz and - Stegun, 10-th printing. Formula 4.4.49 -- abs of error is less than - or equal to 2E-8*X for 0 < X < 1, ignoring arithmatic error - in the floating-point software. } - - function TCHEBYSHEV( X :real) :real; - - { Coefficients for a Tchebychev polinomial balanced for - the inteval 0 < X < 1. } - - { | truncation. } - const A2 = -0.3333314528; - A4 = 0.1999355085; - A6 = -0.1420889944; - A8 = 0.1065626393; - { | truncation. } - A10 = -0.0752896400; - A12 = 0.0429096138; - A14 = -0.0161657368; - { | truncation. } - A16 = 0.0028662257; - - var S :real; - - begin - S := sqr( X ); - TCHEBYSHEV := ((((((((A16*S + A14)*S + A12)*S - + A10)*S + A8)*S + A6)*S + A4)*S + A2)*S + 1)*X; - end; - - - begin - - if Z < -1 then AZ := HALF_PI - TCHEBYSHEV( 1/Z ) - else if Z = -1 then AZ := -HALF_PI/2 - else if Z < 1 then AZ := TCHEBYSHEV( Z ) - else if Z = 1 then AZ := HALF_PI/2 - else AZ := HALF_PI - TCHEBYSHEV( 1/Z ); - - { Note that the tangent is periodic with period PI, rather - than period 2*PI as are the sine and the cosine. } - while AZ > HALF_PI do AZ := AZ - PI; - while AZ < -HALF_PI do AZ := AZ + PI; - ARCTAN := AZ; - - end; - - -modend -. - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/CMPXLIB.ERL b/software/CPM/CPM13_MTPUG_01/CMPXLIB.ERL deleted file mode 100644 index 482e8ac..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/CMPXLIB.ERL and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/CMPXLIB.SRC b/software/CPM/CPM13_MTPUG_01/CMPXLIB.SRC deleted file mode 100644 index 823a887..0000000 --- a/software/CPM/CPM13_MTPUG_01/CMPXLIB.SRC +++ /dev/null @@ -1,91 +0,0 @@ - -{COMPLEX ARITHMETIC LIBRARY FOR PASCAL; (C) 1981 BY FICOMP, INC. FAIRFAX, VA} - -MODULE CMPXLIB; - -TYPE - COMPLEX = RECORD - RE,IM: REAL - END; - -TYPE - PHASOR = RECORD - MAG,ANG: REAL - END; - -PROCEDURE CMPX(N1:COMPLEX;OP:CHAR;N2:COMPLEX;VAR CRES:COMPLEX); -{TO ADD, SUBTRACT, MULTIPLY, OR DIVIDE COMPLEX NUMBERS} -VAR TERM: REAL; -BEGIN - IF OP = '+' THEN - BEGIN {COMPLEX SUM OF 2 COMPLEX NUMBERS, N1+N2} - CRES.RE := N1.RE+N2.RE; - CRES.IM := N1.IM+N2.IM; - END - ELSE - IF OP = '-' THEN - BEGIN {COMPLEX DIFFERENCE OF 2 COMPLEX NUMBERS, N1-N2} - CRES.RE := N1.RE-N2.RE; - CRES.IM := N1.IM-N2.IM; - END - ELSE - IF OP = '*' THEN - BEGIN {COMPLEX PRODUCT OF 2 COMPLEX NUMBERS, N1*N2} - CRES.RE := N1.RE*N2.RE-N1.IM*N2.IM; - CRES.IM := N1.RE*N2.IM+N1.IM*N2.RE; - END - ELSE - IF OP = '/' THEN - BEGIN {COMPLEX QUOTIENT OF 2 COMPLEX NUMBERS, N1/N2} - TERM := SQR(N2.RE)+SQR(N2.IM); - CRES.RE := (N1.RE*N2.RE+N1.IM*N2.IM)/TERM; - CRES.IM := (N2.RE*N1.IM-N1.RE*N2.IM)/TERM; - END - ELSE - WRITELN(OP,' IS AN ILLEGAL COMPLEX OPERATOR'); -END; - -PROCEDURE POLAR(N:COMPLEX;VAR VECT:PHASOR); -{TO CONVERT COMPLEX NUMBER FROM CARTESIAN TO POLAR COORDINATES} -BEGIN - VECT.MAG := SQRT(SQR(N.RE)+SQR(N.IM)); - VECT.ANG := ARCTAN(N.IM/N.RE); -END; - -PROCEDURE CART(N:PHASOR;VAR XY:COMPLEX); -{TO CONVERT COMPLEX NUMBER FROM POLAR TO CARTESIAN COORDINATES} -BEGIN - XY.RE := N.MAG*COS(N.ANG); - XY.IM := N.MAG*SIN(N.ANG); -END; - -PROCEDURE CSQR(N:COMPLEX;VAR CSQ:COMPLEX); -{SQUARE OF COMPLEX NUMBER, SQR(N)} -BEGIN - CSQ.RE := SQR(N.RE)-SQR(N.IM); - CSQ.IM := 2*N.RE*N.IM; -END; - -PROCEDURE CSQRT(N:COMPLEX;VAR CSQT:COMPLEX); -{SQUARE ROOT OF COMPLEX NUMBER, SQRT(N)} -BEGIN - CSQT.RE := SQRT((N.RE+SQRT(SQR(N.RE)+SQR(N.IM)))/2); - CSQT.IM := N.IM/(2*CSQT.RE); -END; - -PROCEDURE CONJG(N:COMPLEX;VAR CONJ:COMPLEX); -{CONJUGATE OF A COMPLEX NUMBER} -BEGIN - CONJ.RE := N.RE; - CONJ.IM := -N.IM; -END; - -FUNCTION CABS(N:COMPLEX): REAL; -{ABSOLUTE VALUE OF COMPLEX NUMBER, ABS(N)} -BEGIN - CABS := SQRT(SQR(N.RE)+SQR(N.IM)); -END; - -MODEND. -S(N:COMPLEX): REAL; -{ABSOLUTE VALUE OF \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/CMPXTEST.COM b/software/CPM/CPM13_MTPUG_01/CMPXTEST.COM deleted file mode 100644 index fdbed08..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/CMPXTEST.COM and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/CMPXTEST.ERL b/software/CPM/CPM13_MTPUG_01/CMPXTEST.ERL deleted file mode 100644 index 072ad74..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/CMPXTEST.ERL and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/CMPXTEST.SRC b/software/CPM/CPM13_MTPUG_01/CMPXTEST.SRC deleted file mode 100644 index 92476d4..0000000 --- a/software/CPM/CPM13_MTPUG_01/CMPXTEST.SRC +++ /dev/null @@ -1,55 +0,0 @@ - -PROGRAM CMPXTEST; -{To test CMPXLIB library for complex arithmetic} - -TYPE - COMPLEX = RECORD RE,IM:REAL -END; - -TYPE - PHASOR = RECORD MAG,ANG:REAL -END; - -VAR X1,X2,ANS:COMPLEX; - OPR:CHAR; - V1,VANS:PHASOR; - ANGLE:REAL; - -EXTERNAL PROCEDURE CMPX(N1:COMPLEX;OP:CHAR;N2:COMPLEX;VAR CRES:COMPLEX); -EXTERNAL PROCEDURE POLAR(N:COMPLEX;VAR VECT:PHASOR); -EXTERNAL PROCEDURE CART(N:PHASOR;VAR XY:COMPLEX); -EXTERNAL PROCEDURE CSQR(N:COMPLEX;VAR CSQ:COMPLEX); -EXTERNAL PROCEDURE CSQRT(N:COMPLEX;VAR CSQT:COMPLEX); -EXTERNAL PROCEDURE CONJG(N:COMPLEX;VAR CONJ:COMPLEX); -EXTERNAL FUNCTION CABS(N:COMPLEX):REAL; -BEGIN -REPEAT - WRITELN('Enter complex number, arithmetic operator, complex number'); - READ(X1.RE,X1.IM,OPR,X2.RE,X2.IM); - CMPX(X1,OPR,X2,ANS); - WRITELN('Answer = ',ANS.RE:6:2,' j ',ANS.IM:6:2); -UNTIL OPR='Q'; - - WRITE('Enter complex number : '); - READ(X1.RE,X1.IM); - POLAR(X1,VANS); - ANGLE:=VANS.ANG/1.74533E-02; {Convert radians to degrees} - WRITELN('Polar = ',VANS.MAG:8:3,' at ',ANGLE:8:3); - - CART(VANS,ANS); - WRITELN('Back to Cartesian = ',ANS.RE:8:3,' j ',ANS.IM:8:3); - - CSQR(X1,ANS); - WRITELN('SQUARE=',ANS.RE:8:4,ANS.IM:8:4); - - CSQRT(X1,ANS); - WRITELN('SQUARE ROOT=',ANS.RE:7:3,ANS.IM:7:3); - - CONJG(X1,ANS); - WRITELN('Conjugate=',ANS.RE:7:3,ANS.IM:7:3); - - WRITELN('Absolute value=',CABS(X1):10:6); -END. -:3); - - CONJG(X1, \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/CP#M-DEC.DOC b/software/CPM/CPM13_MTPUG_01/CP#M-DEC.DOC deleted file mode 100644 index d5a32a0..0000000 --- a/software/CPM/CPM13_MTPUG_01/CP#M-DEC.DOC +++ /dev/null @@ -1,106 +0,0 @@ - - -************************************************************************* - - -COVERING: CPMTODEC,DECTOCPM,LISTDEC - -WRITTEN BY: BRIAN T. CHASE @ NOSC CODE 8131 8/26/78 - SAN DIEGO, CALIF. - - - THESE PROGRAMS ENABLE THE CP/M USER TO TRANSFER FILES BETWEEN -CP/M AND DEC FORMAT DISKETTES, AS WELL AS LISTING THE DEC DISK'S -DIRECTORY. - -________________________________________________________________________ - - -1. LISTDEC: THE PROGRAM IS STARTED BY TYPING "LISTDEC ", AS - IS ANY CP/M TRANSIENT PROGRAM. THE PROGRAM WILL THEN ASK - WHETHER OR NOT THE DEC DISK IS INTERLEAVED (SEE NOTE C.) - AS SOON AS THIS QUESTION IS ANSWERED THE DIRECTORY IS READ IN, - INTERPRETED, AND PRINTED AT THE CONSOLE. THE PROGRAM THEN - IMMEDIATELY RETURNS CONTROL TO CP/M (NO REBOOT). - -2. CPMTODEC: TYPE "CPMTODEC " TO EXECUTE. THE PROGRAM WILL - FIRST ASK IF USER WANTS TO ZERO (INITIALIZE) THE DEC DISK. - IF "Y" IS TYPED, IT WILL ASK "ARE YOU SURE?". IF EITHER OF - THESE QUESTIONS IS ANSWERED BY ANYTHING BUT A "Y", THIS OP- - TION WILL BE SKIPPED. IF DEC DISK IS TO BE ZEROED, THE MES- - SAGE "PLACE DEC DISK ON DRIVE B" WILL BE PRINTED (SEE NOTE - A), FOLLOWED BY THE QUESTION "IS DEC DISK INTERLEAVED?" (SEE - NOTE C). AFTER THIS QUESTION HAS BEEN ANSWERED, THE DISK ON - DRIVE B WILL BE ZEROED. - THE PROGRAM WILL THEN ASK FOR CP/M FILENAME (SOURCE - FILE ON CP/M DISK). ALL KEYBOARD EDITING COMMANDS ARE - AVAILABLE. IT THEN REQUESTS THE DEC FILENAME (DESTINATION - FILE). ALL FILE NAMING CONVENTIONS SHOULD BE OBSERVED. IF - A SYNTAX ERROR OCCURS, THE PROGRAM ASKS FOR BOTH FILENAMES - AGAIN (CHECK CHARACTER COUNT IN NAME). THE "PLACE DEC DISK - ON DRIVE B" MESSAGE IS THEN PRINTED (SEE NOTE A). ANSWER - THE READY(Y/N)? QUESTION WITH A "Y" WHEN READY-"N" WILL ASK - FOR NEW FILENAMES. - WHEN TRANSFER IS COMPLETE, THE MESSAGE "ANOTHER - TRANSFER(Y/N)?" WILL BE PRINTED. "Y" WILL ASK FOR NEW FILE- - NAMES, "N" WILL REBOOT SYSTEM (ZERO FIRST TIME ONLY). - -3. DECTOCPM: TYPE "DECTOCPM " TO EXECUTE. THIS IS SIMILAR - TO #2 ABOVE EXCEPT THAT THE PROGRAM ASKS IF THE DEC FILE - IS ASCII. THIS MEANS: IS THE FILE TO BE TRANSFERRED AN - ASCII SOURCE, LISTING, OR OTHER ASCII-TYPE FILE, OR IS - IT A DATA FILE OR MACHINE CODE,ETC. FILE. NON-ASCII FILES - ARE TRANSFERRED ENTIRELY (ALL BLOCKS TRANSFERRED). FOR - ASCII FILES, THE LAST BLOCK IS CHECKED FOR EOF CHARACTER - (DIFFERENT IN DEC & CP/M FILE FORMATS). (NO ZERO OPTION). - -_________________________________________________________________________ - -NOTES: - - A. THE CP/M STRUCTURE INCLUDES PROVISIONS FOR AT LEAST TWO - DISK DRIVES. IN ALL THREE OF THESE PROGRAMS, THE DEC DISK - IS TO BE PLACED ON DRIVE B. FOR THOSE USERS WITH A SINGLE - DRIVE ON THEIR SYSTEM, CBIOS SHOULD PRINT OUT AN APPROPRIATE - MESSAGE AT THE CONSOLE WHEN ANY PROGRAM SELECTS A DRIVE NOT - CURRENTLY BEING ACCESSED. IN THESE PROGRAMS, THE MESSAGE - "PLACE DEC DISK ON DRIVE B" SHOULD BE IGNORED BY SINGLE - DRIVE USERS-THEY SHOULD WAIT UNTIL THEIR CBIOS NOTIFIES - THEM OF THE SWITCH. - - B. IT SHOULD BE NOTED THAT TO SIMPLIFY THESE PROGRAMS - CONSIDERABLY, THE DEC DISK'S DIRECTORY IS ASSUMED TO BE - EFFECTIVELY ONLY ONE SEGMENT (8 SECTORS) LONG (THEY ARE - NORMALLY INITIALIZED TO 4 SEGMENTS). THIS IS A REASONABLE - ASSUMPTION, SINCE UP TO APPROXIMATELY 72 ENTRIES CAN BE - CONTAINED IN ONE SEGMENT. HOWEVER, IF A FILE CANNOT BE - FOUND ON THE DEC DISK BY THE DECTOCPM PROGRAM AND A SUB- - SEQUENT DIRECTORY LISTING ON A DEC COMPUTER SHOWS THE FILE - PRESENT, THE SOLUTION WOULD BE TO PIP THE DESIRED FILE TO - ANOTHER DEC DISK WITH FEWER OR NO FILES ON IT (EG A FRESH- - LY ZEROED DISK). - - C. THESE PROGRAMS WERE ALSO WRITTEN TO HANDLE TWO DIFFERENT - DEC DISK FORMATS: - - 1. STANDARD DEC FORMAT- LOGICAL SECTORS BEGIN ON TRACK 1 - WITH PHYSICAL SECTORS 1,3,5,7...23,25,2,4,6...24,26 (EVERY - OTHER SECTOR). THIS SEQUENCE IS ALSO SHIFTED BY ADDING AN - AMOUNT B=6*(TRACK#-1) TO THE TRACK 1 VALUES (IN MOD 26). - - 2. CONSECUTIVE- LOGICAL SECTORS ARE PHYSICAL SECTORS. - - EACH PROGRAM ASKS IF THE DEC DISK IS INTERLEAVED. THIS IS - ASKING WHETHER THE DISK IS STANDARD DEC FORMAT OR IF IT IS - CONSECUTIVE (IE LOGICAL SECTORS=PHYSICAL SECTORS). A FLAG IS - SET OR RESET FOR THE DISK B HANDLING ROUTINE. THE USER MAY - WISH TO ALTER THIS FUNCTION IF HE HAS ONLY ONE TYPE OF DEC - DISK. - - D. THE CP/M PROGRAM BEING TRANSFERRED MUST BE ON THE SAME - DISK THAT THE TRANSFERRING PROGRAM (CPMTODEC OR DECTOCPM) IS - ON (DUE TO THE AUTOMATIC READ-ONLY STATUS THAT SWITCHING - DISKS CAUSES IN VERSION 1.4). - -***************************************************************************** - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/CPMTODEC.COM b/software/CPM/CPM13_MTPUG_01/CPMTODEC.COM deleted file mode 100644 index 6e80e16..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/CPMTODEC.COM and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/DECTOCPM.COM b/software/CPM/CPM13_MTPUG_01/DECTOCPM.COM deleted file mode 100644 index 0cfada5..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/DECTOCPM.COM and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/EXP.ERL b/software/CPM/CPM13_MTPUG_01/EXP.ERL deleted file mode 100644 index 4476282..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/EXP.ERL and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/EXP.SRC b/software/CPM/CPM13_MTPUG_01/EXP.SRC deleted file mode 100644 index 232250b..0000000 --- a/software/CPM/CPM13_MTPUG_01/EXP.SRC +++ /dev/null @@ -1,130 +0,0 @@ -MODULE EXPONENT; { Copyright (c) by T. W. Lougheed 24 April 1981 } - -{ First version 8 March 1981 - - By T. W. Lougheed - Dept. T. & A. Mechanics - Thurston Hall, Cornell U. - Ithaca, NY 14853 - - Last version 27 April 1981 - - This software is in the public domain, and may not be sold by any - person or corperation without permission of the author. } - - -FUNCTION EXP( Z :REAL) :REAL; - -CONST E = 2.718281828459045; { Base of the natural logarithms. } - - MAXREAL = 9.9999999E17; { Result of overflow. } - MINREAL = 1.0E-17; { Result of an underflow. Could be - set to be zero just as resonably. } - - CAUSES_OVERFLOW = 41.4465; { Any argument greater in absolute - value than this will cause overflow. } - -VAR Y :REAL; N :INTEGER; { Intermediate values. } - - - - { The following funtion returns e raised to an INTEGER - power N. The sign of N is ignored: its absolute value - is used. } - - FUNCTION POWER( R :REAL; N :INTEGER ) :REAL; - - VAR X, F : REAL; - M : INTEGER; - - - - { This algorithm uses the 'invariant' method. The following - equasion is always true, it is the 'invariant': - - n m - R = Y = X F - - "n" is the power we want to raise "R" to, "Y" is the answer we - are seeking, "X" is on its way to being the answer (starts at 1) - and "m" starts at "n" and arrives at "0" when "X" has arrived - at the answer "Y". "F" initially starts at "R" and increases - as necessary to keep the invariant formula true. - - Since M = 2 (M div 2) + M mod 2, if we replace X with - X * F**(M mod 2) and then F with F**2 and M with M div 2, - the invariant formula is unchanged. So we itterate this set of - replacements until we see that M is zero. As mentioned before, - M is zero, X must be the desired answer "Y". - - The only fact left to note is that M mod 2 = M bit 0, and - M div 2 = M shr 1, so we can do all that jazz cheaply. } - - BEGIN - F := R; X := 1; M := ABS( N ); - IF M <> 0 THEN REPEAT - IF TSTBIT(M, 0) THEN X := X*F; - M := SHR(M, 1); F := SQR(F); - UNTIL M = 0; - POWER := X; - END; - - { Note that the description is much longer than the algorithm: - a hallmark of the method of programming with 'invariants'. } - { Note also that the method only works well if you're clever - at guessing what a good invariant could be. } - - - { The following function gives a Tchebyshev polinomial - approximation for EXP(X) for 0 < X < 0.69; the error without truncation - would be less than 2E-10. Adapted from quasion 4.2.45 from - THE HANDBOOK OF MATHEMATICAL FUNCTIONS, by Abramowicz - and Stegun. This is really SUPPOSED to have negative arguments ... - to give 1/EXP ... but I'm using it differently. } - - FUNCTION TCHEBYSHEV( X :REAL ) :REAL; - - CONST A1 = 0.9999999995; - A2 = 0.4999999206; - A3 = 0.1666653019; - A4 = 0.0416573475; - A5 = 0.0083013598; - A6 = 0.0013298820; - A7 = 0.0001413161; - - BEGIN - TCHEBYSHEV := ((((((A7*X + A6)*X + A5)*X + A4)*X + - A3)*X + A2)*X + A1)*X + 1; - END; - - - -BEGIN { Main } - -IF Z > CAUSES_OVERFLOW THEN EXP := MAXREAL -{ These are special cases that we would like to handle exactly } -ELSE IF Z = 1 THEN EXP := E -ELSE IF Z = 0 THEN EXP := 1 -ELSE IF Z = -1 THEN EXP := 1/E -ELSE IF Z > 0 THEN BEGIN - { Split up Z into its nearest integer part, N, and the - remainder, Z. Let POWER handle the integer part and - have TCHEBYSHEV handle the fractional part. } - N := ROUND( Z ); - Z := Z - N; - Y := POWER( E, N ); - EXP := Y*TCHEBYSHEV( Z ); - END -ELSE IF Z > -CAUSES_OVERFLOW THEN BEGIN - N := ROUND( - Z ); - Z := Z + N; - Y := POWER( E, N ); - EXP := Y/TCHEBYSHEV(Z); - END -ELSE EXP := MINREAL; { Underflow. } - -END; - -MODEND -. - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/F.PAS b/software/CPM/CPM13_MTPUG_01/F.PAS deleted file mode 100644 index 7fcac1d..0000000 --- a/software/CPM/CPM13_MTPUG_01/F.PAS +++ /dev/null @@ -1,14 +0,0 @@ -MODULE FORGRAPH; - -{ This is an examplary function for use with the graphing procedure. } - -FUNCTION F( X :REAL) :REAL; - BEGIN - { Happens to be an unnormalized probability amplitude function - from quantum mechanics -- for a simple-harmonic potential well, - I think. Whatever it is, it looks nice. } - F := SQR(COS(X))/EXP(SQR(X)); - END; - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/FILSIZ.ERL b/software/CPM/CPM13_MTPUG_01/FILSIZ.ERL deleted file mode 100644 index f564f4b..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/FILSIZ.ERL and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/FILSIZ.SRC b/software/CPM/CPM13_MTPUG_01/FILSIZ.SRC deleted file mode 100644 index b497cad..0000000 --- a/software/CPM/CPM13_MTPUG_01/FILSIZ.SRC +++ /dev/null @@ -1,18 +0,0 @@ -MODULE CPMX1; -(*$I FIBDEF.LIB*) - -VAR - RESULT:INTEGER; - -EXTERNAL FUNCTION @BDOS(FUNC,PARM:INTEGER):INTEGER; - -FUNCTION FILSIZ( VAR F:FIB):INTEGER; -BEGIN - - RESULT:=@BDOS(35,ADDR(F.FCB)); - FILSIZ:=256*ORD(F.FCB[34]) + ORD(F.FCB[33]) - -END; - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/GNB.ERL b/software/CPM/CPM13_MTPUG_01/GNB.ERL deleted file mode 100644 index 8b44c3d..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/GNB.ERL and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/GNB.SRC b/software/CPM/CPM13_MTPUG_01/GNB.SRC deleted file mode 100644 index 7764af6..0000000 --- a/software/CPM/CPM13_MTPUG_01/GNB.SRC +++ /dev/null @@ -1,58 +0,0 @@ -MODULE GETNEXT; - -(*$M GNB*) -(*$M **) - -(*$I FIBDEF.LIB*) - -VAR - @LFB: EXTERNAL ^FIB; - -EXTERNAL PROCEDURE @RNB; - -FUNCTION GNB(VAR F:FIB; SZ:INTEGER):CHAR; -BEGIN - @LFB := ADDR(F); - - WITH F DO - BEGIN - IF BUFIDX = BUFLEN THEN (* TIME TO GO READ MORE *) - BEGIN - @RNB; - BUFIDX := 0 - END; - - IF NOT FEOF THEN - BEGIN - GNB := FBUFFER[BUFIDX]; - BUFIDX := BUFIDX + 1 - END - ELSE - GNB := CHR($FF); - - END (* WITH *) -END; - -MODEND. - -%%%START PURGE -MODULE KILLFILE; - -(*$M PURGE*) -(*$M **) - -(*$I FIBDEF.LIB*) -VAR - RESULTIO: EXTERNAL INTEGER; - -EXTERNAL FUNCTION @BDOS(FUNC:INTEGER; PARM:WORD):INTEGER; -EXTERNAL PROCEDURE @DFLT; - -PROCEDURE PURGE(VAR F:FIB; SZ:INTEGER); -BEGIN - @DFLT; - RESULTIO := @BDOS(19,WRD(ADDR(F.FCB))); - RESULTIO := 0 (* NO DATA FROM CP/M *) -END; - - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/GNBCHK.COM b/software/CPM/CPM13_MTPUG_01/GNBCHK.COM deleted file mode 100644 index 7957317..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/GNBCHK.COM and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/GNBCHK.ERL b/software/CPM/CPM13_MTPUG_01/GNBCHK.ERL deleted file mode 100644 index fb66444..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/GNBCHK.ERL and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/GNBCHK.SRC b/software/CPM/CPM13_MTPUG_01/GNBCHK.SRC deleted file mode 100644 index 67c2ad5..0000000 --- a/software/CPM/CPM13_MTPUG_01/GNBCHK.SRC +++ /dev/null @@ -1,59 +0,0 @@ -PROGRAM GNBCHK; -TYPE - BUFFER= ARRAY[0..1023] OF BYTE; -VAR - FIN : FILE OF BUFFER; - FOUT : TEXT; - CH : CHAR; - I,J,N,SKIP,NREC:INTEGER; - STR:STRING; - HFLNEXT: INTEGER; - -BEGIN - WRITELN('ENTER FILENAME TO READ'); - READLN(STR); - WRITELN('ENTER NUMBER OF SECTORS TO SKIP'); - READLN(SKIP); - WRITELN('ENTER NUMBER OF SECTORS TO READ'); - READLN(NREC); - ASSIGN(FOUT,'LST:'); - REWRITE(FOUT); - ASSIGN(FIN,STR); - RESET(FIN); - - HFLNEXT:=IORESULT; - WRITELN(FOUT,'IORESULT FOR INPUT FILE= ',HFLNEXT); - HFLNEXT:=0; - J:=0; - N:=1; - WHILE (N<=NREC) DO - BEGIN - IF N>SKIP THEN WRITELN(FOUT,'SECTOR=',N); - FOR I:=1 TO 128 DO - BEGIN - CH:=GNB(FIN); - IF N>SKIP THEN WRITEHEX(FOUT,CH,1); - IF (I MOD 40=0 ) AND (N>SKIP) THEN WRITELN(FOUT); - IF ORD(CH)=10 THEN - BEGIN - J:=J+1; - IF N>SKIP THEN - BEGIN - WRITELN(FOUT,' NREC=',J); - WRITELN(FOUT,'EOF= ',EOF(FIN),' IORESULT= ', - IORESULT,' HFLNEXT= ',HFLNEXT) - END; - END; - END; - N:=N+1; - END; - - WRITELN(FOUT,'EOF= ',EOF(FIN),' IORESULT= ', - IORESULT,' HFLNEXT= ',HFLNEXT); - WRITELN(FOUT,'NORMAL END'); - CLOSE(FOUT,I) - -END. - - - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/GRAPH.DOC b/software/CPM/CPM13_MTPUG_01/GRAPH.DOC deleted file mode 100644 index 7d3e051..0000000 --- a/software/CPM/CPM13_MTPUG_01/GRAPH.DOC +++ /dev/null @@ -1,17 +0,0 @@ - - The files - - GRAPH.PAS PLOT.MOD and F.PAS - - form a graphing procedure. GRAPH is the driving procedure for - the procedure PLOT, GRAPH chats with the user at the console - while plot does all the work. F supplies the function to be - plotted. - - The procedure PLOT uses escape-codes valid for an IMSAI VIO board, - hence is not likely to work on any other machine without change. - The form of the procedure is modular and I hope well commented, it - should be easilly modified for other machines. - - - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/GRAPH.PAS b/software/CPM/CPM13_MTPUG_01/GRAPH.PAS deleted file mode 100644 index 2f08369..0000000 --- a/software/CPM/CPM13_MTPUG_01/GRAPH.PAS +++ /dev/null @@ -1,195 +0,0 @@ -{ Copyright by T. W. Lougheed 27 April 1981 } - -{ This program plots a set of points given by the function Y = F(X). } - -{ This is a plotting program that uses the graphic symbols of -the VDP 80's VIO board. It puts the VIO board in the extended -character set mode, plots all the points given, then returns -to the original mode. All the magic with the screen takes place -in the external module PLOT. All values of the points to be plotted -are generated by the external function F. } - -{ First version 20 August 1980 - - By T. W. Lougheed - Dept. T. & A. Mechanics - Thurston Hall, Cornell U. - Ithaca, NY 14853 - - Last version 17 January 1981 } - -{ This program is in the public domain and may not be sold by any person -or corperation without express permission of the author. } - - -PROGRAM GRAPH14; - -CONST VERSION = 14; - ROWS = 23; { Number of rows used for graphics on the screen. } - { Number of columns is assumed 80 see PLOT to change. } - -TYPE POINT = RECORD X, Y :REAL END; - -VAR C : CHAR; - CENTER : POINT; - DATA : ARRAY[ 1..100 ] OF POINT; - DX, { Increment to make along X axis. } - START, STOP, { First and last X values. } - TOP, BOTTOM : REAL; { Largest & smallest Y values. } - K, L : INTEGER; { Dummy indicies. } - - -{ This is the function to be plotted. } - -EXTERNAL FUNCTION F( X :REAL) :REAL; - - -{ This procedure plots an X,Y graph of the DATA points given on -the screen. It handles the video itself, without outside help. } - -EXTERNAL PROCEDURE PLOT ( - L : INTEGER; { Number of points to plot. } - VAR DATA : ARRAY[ M..N :INTEGER ] OF POINT; - ORIGIN : POINT; { Center of the axes -- if out-of-bounds it is set to - lie at the upper corner of the screen. } - X_MIN, - X_MAX, { Bounds for X & Y values. If MIN <= MAX then .. } - Y_MIN, { .. scaling is done automaticly for that axis. } - Y_MAX : REAL - ); - - - -{ This procedure clears the video screen. } - -PROCEDURE CLEAR; - { Writing controll-Z erases the screen. } - BEGIN WRITE( CHR($1A) ) END; - - - -{ The following procedure positions the cursor on the -screen to the row & column indicated, using escape codes -appropriate to an IMSAI VIO board. } - -PROCEDURE CURSOR( ROW, COLUMN :INTEGER); - CONST OFFSET = $1F; { The VIO offsets all co-ordinates. } - ESC = $1B; { ASCII character code. } - VAR A, B : CHAR; - BEGIN - A := CHR( $1F + ROW ); - B := CHR( $1F + COLUMN ); - WRITE( CHR(ESC), '=', A, B ); - END; - - - -{ Prints the plotters sign-on message. } - -PROCEDURE SIGN_ON; - BEGIN - CLEAR; { Erase screen. } - WRITELN; - WRITELN( ' F U N C T I O N P L O T T E R (version ', - VERSION, ') ' ); - WRITELN; - WRITELN; - WRITELN( - ' This program plots the value of the function "F" provided when the' ); - WRITELN( - 'program was linked. Note that the abscissa (X-axis) runs down the' ); - WRITELN( - 'screen and the ordinate (Y-axis) runs across: they are rotated ninety' ); - WRITELN( 'degrees from the customary directions for plotting functions.' ); - WRITELN; - WRITELN( - ' The program will now ask you for initial and final values of X and' ); - WRITELN( - 'extreem values for Y in order to determine the scales for the two axes.' - ); - WRITELN( - 'After the plot is made you may start over, so if the plot does not' ); - WRITELN( 'satisfy you, you may try again using different paramiters.' ); - WRITELN; WRITELN; - END; - - - -{ This procedure querries the user for paramiters. } - -PROCEDURE PARAMITERS; - BEGIN - - REPEAT - WRITELN; - WRITE( 'Where is the plot to start on the abscissa ? ', - '(X axis) ' ); READ( START ); - WRITE( ' ... and where is it to stop ? ' ); READ( STOP ); - IF START = STOP THEN WRITELN( 'HOLD IT ! They''re the same. ' ); - UNTIL START <> STOP; - - WRITELN; - WRITE( 'Do you want automatic scaling ? (Y/N) ' ); READ( C ); WRITELN; - IF C IN [ 'n', 'N' ] - THEN REPEAT - WRITE( 'What is the lower limit for plotted values ', - 'along the ordinate ? (Y-Axis) ' ); READ( BOTTOM ); - WRITE( ' ... and the upper limit ? ' ); READ( TOP ); - IF BOTTOM = TOP THEN WRITELN( 'Wait a minute: They''re the same !' ); - UNTIL BOTTOM <> TOP - ELSE BEGIN BOTTOM := 0; TOP := 0 END; { Forces auto-scaling. } - - END; - - - -BEGIN { GRAPHICS. } - -{ Introduce the program: } SIGN_ON; - -REPEAT - - PARAMITERS; { Find out where to start and stop, &c. } - - { Figure what the points ought to be. } - WRITELN; WRITE( 'Calculating points ' ); - L := 3*ROWS; - DX := (STOP - START)/(L - 1); - FOR K := 1 TO L DO WITH DATA[K] DO - BEGIN - WRITE('.'); IF K MOD 5 = 0 THEN WRITE( ' ' ); { Talley of points. } - IF K MOD 50 = 0 THEN BEGIN WRITELN; WRITE( ' ':18 ) END; - X := K*DX + START; Y := F(X); { This is the only appearance of "F" } - END; - WRITELN( ' Done. ' ); - - - WRITELN; - WRITE( 'Hit any key when you''re ready to see the plot.' ); - READ( C ); { Dummy input. } - - - { Call plotting routine. } - - { CENTER is the location of the origin - -- if impropper it will default to the upper corner. } - - CENTER.X := 0.0; CENTER.Y := 0.0; - { For the meaning of the paramiters, consult comments on PLOT. } - PLOT( L, DATA, CENTER, START, STOP, BOTTOM, TOP ); - - WRITELN; - REPEAT - WRITE( 'Another plot ? (Y/N) ' ); READ( C ); WRITELN; - UNTIL C IN [ 'y', 'Y', 'n', 'N' ]; - - UNTIL C IN [ 'n', 'N' ]; - - -WRITELN; -WRITELN( 'Normal end of program.' ); - -END -. - - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/LIST.COM b/software/CPM/CPM13_MTPUG_01/LIST.COM deleted file mode 100644 index 441ab7b..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/LIST.COM and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/LISTDEC.COM b/software/CPM/CPM13_MTPUG_01/LISTDEC.COM deleted file mode 100644 index beead83..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/LISTDEC.COM and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/LN.ERL b/software/CPM/CPM13_MTPUG_01/LN.ERL deleted file mode 100644 index 3ef0273..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/LN.ERL and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/LN.SRC b/software/CPM/CPM13_MTPUG_01/LN.SRC deleted file mode 100644 index 4113a85..0000000 --- a/software/CPM/CPM13_MTPUG_01/LN.SRC +++ /dev/null @@ -1,108 +0,0 @@ -MODULE LOG3; { Copyright (c) by T. W. Lougheed 24 April 1981 } - -{ This function returns the natural logarithm of the given -number with accuracy limited by machine precision. It is much -more efficient than the algorithm used in PASCAL/MT 5.2 and just -as accurate, but could be improved, particularly in its Tchebyshev -polinimial. For likely algorithms, see COMPUTER APPROXIMATIONS -by John Hart & friends, 1978 by Krieger Pub. Co., Huntington NY. } - -{ First version 5 February 1981 - - By T. W. Lougheed - Dept. T. & A. Mechanics - Thurston Hall, Cornell U. - Ithaca, NY 14853 - - Last version 23 February 1981 - - This software is in the public domain, and may not be sold by any - person or corperation without permission of the author. } - - -FUNCTION LN( Z :REAL ) :REAL; - -CONST { If the input is zero or negative, the output is - - maxreal. } - - MAXREAL = 9.9999E17; - -VAR LOGARITHM : REAL; - - -{ This procedure reduces the exponent of Z to 1 and -sets LOGARITHM to the value of the removed part. - Note that this must be re-written for every new -internal representation of the reals. } - - -PROCEDURE MANGLE_Z; - - CONST { The following are used for the conversion of the - exponential part of Z directly to a logarithm. } - - LOG_2 = 0.6931471805994531; - - EXPT_MASK = $7F; { Exponent is a power of 2 stored in bits - six through zero in two-s complement format. } - - EXPT_SIGN_BIT = 6; { Bit to test to get sign of exponent. } - - VAR EXPONENT :BYTE; - - BEGIN - - - MOVE( Z, EXPONENT, 1 ); - - { The exponent is in a two's compement form: all negative - numbers are of the form 128 - V where V is the absolute - value of the negative part, hence subtract 128 to get negative - number. Bit 7 is the sign of the characteristic. } - IF TSTBIT( EXPONENT, EXPT_SIGN_BIT ) - THEN LOGARITHM := LOG_2*(ORD( EXPONENT&EXPT_MASK ) - 129) - ELSE LOGARITHM := LOG_2*(ORD( EXPONENT&EXPT_MASK ) - 1); - - { Make the number Z to be between 1 and 2. } - EXPONENT := CHR( 1 ); - MOVE( EXPONENT, Z, 1 ); - END; - - - - { This function is a Tchebyshev polinomial for the natural - logarithm of one plus its argument. The formula is from - THE HANDBOOK OF MATHEMATICAL FUNCTIONS (10-th printing) - by Abramowicz and Stegun, formula 4.1.44. The error is - less than 3E-8 for argument X between 0 and 1 inclusive. } - - FUNCTION TCHEBYSHEV( X :REAL) :REAL; - - CONST A1 = 0.9999964239; - A2 = -0.4998741238; - A3 = 0.3317990258; - A4 = -0.2407338048; - A5 = 0.1676540711; - A6 = -0.0953293879; - A7 = 0.0360884937; - A8 = -0.0064535442; - - BEGIN - TCHEBYSHEV := (((((((A8*X + A7)*X + A6)*X + A5)*X + A4)*X + - A3)*X + A2)*X + A1)*X; - { TCHEBYSHEV = LN( 1 + X ). } - END; - - - -BEGIN -IF Z <= 0 THEN LN := - MAXREAL - ELSE BEGIN - MANGLE_Z; - LN := LOGARITHM + TCHEBYSHEV( Z - 1 ); - END; -END; - -MODEND -. - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/MATHLIB.ERL b/software/CPM/CPM13_MTPUG_01/MATHLIB.ERL deleted file mode 100644 index 470812e..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/MATHLIB.ERL and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/MATHLIB.SRC b/software/CPM/CPM13_MTPUG_01/MATHLIB.SRC deleted file mode 100644 index 3063f16..0000000 --- a/software/CPM/CPM13_MTPUG_01/MATHLIB.SRC +++ /dev/null @@ -1,118 +0,0 @@ -{MATH FUNCTION LIBRARY FOR PASCAL; (C) 1981 BY FICOMP, INC. FAIRFAX, VA.} - -MODULE MATHLIB; - -CONST DRCON = 1.74533E-02; - HALFPI = 1.5708; - LOGCON = 2.30259; - -{TRIG FUNCTIONS} - -FUNCTION RAD(X:REAL): REAL; -{CONVERTS DEGREES TO RADIANS} -BEGIN - RAD := X*DRCON; -END; - -FUNCTION DEG(X:REAL): REAL; -{CONVERTS RADIANS TO DEGREES} -BEGIN - DEG := X/DRCON; -END; - -FUNCTION TAN(X:REAL): REAL; -{TANGENT FUNCTION} -BEGIN - TAN := SIN(X)/COS(X); -END; - -FUNCTION COT(X:REAL): REAL; -{COTANGENT FUNCTION} -BEGIN - COT := COS(X)/SIN(X); -END; - -FUNCTION ASIN(X:REAL): REAL; -{ARCSIN FUNCTION} -BEGIN - ASIN := ARCTAN(X/SQRT(-X*X+1.0)); -END; - -FUNCTION ACOS(X:REAL): REAL; -{ARCOSINE FUNCTION} -BEGIN - ACOS := -ARCTAN(X/SQRT(-X*X+1.0))+HALFPI; -END; - -FUNCTION ACOT(X:REAL): REAL; -{ARCOTANGENT FUNCTION} -BEGIN - ACOT := ARCTAN(X)+HALFPI; -END; - -{COMMON LOG FUNCTIONS} - -FUNCTION LOG10(X:REAL): REAL; -{LOG (BASE 10) FUNCTION} -BEGIN - IF X<=0 THEN - LOG10 := 0.0 - ELSE - LOG10 := LN(X)/LOGCON; -END; - -FUNCTION ALOG10(X:REAL): REAL; -{ANTILOG (BASE 10) FUNCTION} -BEGIN - ALOG10 := EXP(X*LOGCON); -END; - -{POWER FUNCTIONS} - -FUNCTION POWER(X:REAL;N:INTEGER): REAL; -{COMPUTES REAL X RAISED TO INTEGER POWER N RECURSIVELY} -BEGIN - IF X=0.0 THEN - POWER := 0.0 - ELSE - IF N=0 THEN - POWER := 1.0 - ELSE - IF N<0 THEN - POWER := POWER(X,N+1)/X - ELSE - POWER := POWER(X,N-1)*X; -END; - -FUNCTION ROOT(X:REAL;N:INTEGER): REAL; -{COMPUTES INTEGER ROOT N OF REAL X} -BEGIN - IF (X=0.0) OR (N=0) THEN - ROOT := 0.0 - ELSE - IF (NOT ODD(N)) AND (X<0) THEN - ROOT := 0.0 - ELSE - IF N=1 THEN - ROOT := X - ELSE - IF X>0 THEN - ROOT := EXP(LN(X)/N) - ELSE - ROOT := -EXP(LN(ABS(X))/N); -END; - -FUNCTION RPOWER(X,N:REAL): REAL; -{COMPUTES REAL X RAISED TO REAL POWER N} -BEGIN - IF (X<=0.0) OR (N=0.0) THEN - RPOWER := 0.0 - ELSE - RPOWER := EXP(LN(X)*N); -END; - -MODEND. - REAL POWER N} -BEGIN - IF (X<=0.0) OR (N=0.0) THEN - RPOWER := 0. \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/MATHTEST.COM b/software/CPM/CPM13_MTPUG_01/MATHTEST.COM deleted file mode 100644 index f3d867d..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/MATHTEST.COM and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/MATHTEST.ERL b/software/CPM/CPM13_MTPUG_01/MATHTEST.ERL deleted file mode 100644 index b5dc108..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/MATHTEST.ERL and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/MATHTEST.SRC b/software/CPM/CPM13_MTPUG_01/MATHTEST.SRC deleted file mode 100644 index 3808b32..0000000 --- a/software/CPM/CPM13_MTPUG_01/MATHTEST.SRC +++ /dev/null @@ -1,59 +0,0 @@ -PROGRAM MATHTEST; -{To test MATHLIB library} - -VAR - X,NR:REAL; - NI:INTEGER; - -EXTERNAL FUNCTION RAD(X:REAL):REAL; -EXTERNAL FUNCTION DEG(X:REAL):REAL; -EXTERNAL FUNCTION TAN(X:REAL):REAL; -EXTERNAL FUNCTION COT(X:REAL):REAL; -EXTERNAL FUNCTION ASIN(X:REAL):REAL; -EXTERNAL FUNCTION ACOS(X:REAL):REAL; -EXTERNAL FUNCTION ACOT(X:REAL):REAL; -EXTERNAL FUNCTION LOG10(X:REAL):REAL; -EXTERNAL FUNCTION ALOG10(X:REAL):REAL; -EXTERNAL FUNCTION POWER(X:REAL;N:INTEGER):REAL; -EXTERNAL FUNCTION ROOT(X:REAL;N:INTEGER):REAL; -EXTERNAL FUNCTION RPOWER(X,N:REAL):REAL; - -BEGIN - WRITE('Enter real number : '); - READ(X); - - WRITELN('TAN= ',TAN(RAD(X)):8:4); - - WRITELN('COT= ',COT(RAD(X)):8:4); - - WRITELN('ASIN= ',DEG(ASIN(X)):8:4); - - WRITELN('ACOS= ',DEG(ACOS(X)):8:4); - - WRITELN('ACOT= ',DEG(ACOT(X)):8:4); - - WRITELN('LOG10= ',LOG10(X):8:4); - - WRITELN('ALOG10= ',ALOG10(X):8:4); - - WRITE('Input real number, integer power: '); - - READ(X,NI); - - WRITELN(X,' to ',NI,'power = ',POWER(X,NI):8:4); - - WRITELN(NI, 'root of ',X,' = ',ROOT(X,NI):8:4); - - WRITE('Input real number, real power: '); - - READ(X,NR); - - WRITELN(X,' to ',NR,' power = ',RPOWER(X,NR):8:4); - -END. - - WRITE('Input real number, real power: '); - - READ(X,NR); - - WR \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/MODEM.LIB b/software/CPM/CPM13_MTPUG_01/MODEM.LIB deleted file mode 100644 index 78ede9a..0000000 --- a/software/CPM/CPM13_MTPUG_01/MODEM.LIB +++ /dev/null @@ -1,667 +0,0 @@ -;MACROS LIBRARY FOR CP/M ROUTINE SIMULATION 10/15/80 - -;CONTAINS: -; 1) INBUF - DUPLICATES READ BUFFER ROUTINE -; SAME AS CP/M FUNCTION 10, BUT DOES -; NOT USE CTRL-C (REASON FOR ROUTINE). -; DOES ALLOW CONTROLS U, R, E, AND H (BACKSPACE). -; OUTPUTS BELL IF INPUT GREATER THAN BUFFER -; 2) CMDLINE - PARSES A CP/M BUFFER INTO FORMAT SAME AS -; CP/M COMMAND LINE. -; 3) INLNCOMP - COMPARES STRINGS FOLLOWING CALL TO 'ILCOMP' -; TO STRING ADDRESSED BY DE REGS. -; 4) MULTNAME - MULTI-FILE FILE ACCESS ROUTINE FROM -; CP/M USERS GROUP. -; 5) DIRLIST - LISTS DIRECTORY - -INBUF MACRO ;NO PARAMETERS USED. - - LOCAL START,INBUFO,INBUFA,DELETE,NODEL,ALERT - LOCAL INBUFLT,CLEAR,CLEARL,INBUFR,RETYPE,BKSPC,PCRLF - LOCAL CONIN,CONOUT,CONIN1,CONOUT1,NOUCASE,CTLRLP - LOCAL CONSTAT,CONST1,CONINLP - - PUSH PSW - PUSH H - PUSH B - PUSH D ;DE REGISTERS MUST BE PUSHED LAST -START CALL CLEAR ;CLEAR THE BUFFER AREA - POP D ;GET ADDRESS OF BUFFER ON RETRIES - PUSH D ;RESTORE STACK - XRA A - INX D ;ADDRESS COUNT FIELD - STAX D ;INITIALIZE WITH A ZERO IN COUNT BYTE - INX D - XCHG ;ADDRESS FIRST BUFFER BYTE WITH HL -INBUFA CALL CONIN - CPI 0DH ;IS IT A RETURN? - JZ INBUFR ;IF SO, THEN RETURN - CPI 7FH ;IS IT A DELETE? - JZ DELETE - CPI 8 ;CTRL-H WILL BACKSPACE.. - JZ DELETE ;..OVER DELETED CHAR. - CPI 'U'-40H ;IS IT A CTRL-U - JZ INBUFO ;OUTPUT # CR LF AND START OVER - CPI 'R'-40H ;CTRL-R RETYPES LINE - JZ RETYPE - CPI 'E'-40H - JZ PCRLF - CPI 20H ;NO CONTROL CHARACTERS OTHER.. - JC INBUFA ;..THAN ABOVE ALLOWED. - MOV B,A ;SAVE INPUTTED CHARACTER - XCHG ;SAVE HL IN DE - POP H ;GET ADDRESS OF BUFFER IN HL - PUSH H ;RESTORE STACK - INX H ;ADDRESS COUNT BYTE - INR M ;INCREASE COUNT BYTE - DCX H ;ADDRESS MAXIMUM - MOV A,M ;PUT MAXIMUM IN A - INX H ;ADDRESS COUNT - CMP M ;COMPARE COUNT TO MAXIMUM - JC ALERT ;IF MAXIMUM, RING BELL AND WAIT FOR CR - XCHG ;RESTORE BUFFER POINTER TO HL - MOV M,B ;PUT INPUTTED CHARACTER IN BUFFER - MOV A,B ;OUTPUT IT - CALL CONOUT - INX H ;BUMP POINTER - JMP INBUFA ;GET NEXT CHARACTER - -DELETE XCHG ;SAVE BUFFER POINTER IN DE - POP H ;ADDRESS BEGINNING OF BUFFER - PUSH H ;RESTORE STACK - INX H ;ADDRESS COUNT FIELD - MOV B,A ;SAVE DELETE CHAR - 7FH OR 08H - MOV A,M - SUI 1 ;DECREASE COUNT - MOV M,A - JC NODEL ;DON'T DELETE PAST BEGINING OF BUFFER. - XCHG ;RESTORE BUFFER POINTER TO HL - DCX H ;POINT TO LAST BYTE INPUTTED - MOV A,B ;GET BACK EITHER 7FH OR 08H - MOV B,M ;GET CHARACTER BEING DELETED - MVI M,20H ;RESTORE BLANK - CPI 8 - JZ BKSPC - MOV A,B ;ECHO CHAR IF 7FH - CALL CONOUT - JMP INBUFA ;GET NEXT CHARACTER -NODEL INR M ;DON'T LEAVE COUNT NEGATIVE - XCHG ;RESTORE POINTER TO HL - JMP INBUFA -BKSPC CALL CONOUT ;TRUE ERASE IF 08H - MVI A,20H - CALL CONOUT - MVI A,8 - CALL CONOUT - JMP INBUFA - -INBUFO MVI A,'#' - CALL CONOUT - MVI A,0DH - CALL CONOUT - MVI A,0AH - CALL CONOUT - JMP START - -RETYPE POP D - PUSH D - INX D ;POINT TO CURRENT NUMBER.. - LDAX D ;..OF CHARACTERS. - MOV B,A - MVI A,'#' - CALL CONOUT - MVI A,0DH - CALL CONOUT - MVI A,0AH - CALL CONOUT - MOV A,B ;TEST IF ZERO INPUT - ORA A - JZ INBUFA -CTLRLP INX D - LDAX D - CALL CONOUT - DCR B - JNZ CTLRLP - JMP INBUFA - -ALERT MVI A,7 - CALL CONOUT - DCR M - XCHG - JMP INBUFA - -PCRLF MVI A,0DH - CALL CONOUT - MVI A,0AH - CALL CONOUT - JMP INBUFA - -INBUFR MVI A,0DH - CALL CONOUT - MVI A,0AH - CALL CONOUT - POP D - POP B - POP H - POP PSW - RET - -CLEAR POP D ;ACCOUNTS FOR CALL - POP H ;ADDRESS BUFFER IN HL - PUSH H ;RESTORE.. - PUSH D ;..STACK - MOV B,M ;SAVE MAXIMUM IN B - INX H ;POINT TO FIRST.. - INX H ;..BUFFER BYTE. - MVI A,20H -CLEARL MOV M,A - INX H - DCR B - JNZ CLEARL - RET - -CONIN PUSH H ! PUSH D ! PUSH B -CONINLP CALL CONSTAT - ORA A - JZ CONINLP - CALL CONIN1 - CPI 61H ;CHANGE TO UPPER.. - JC NOUCASE ;..CASE SINCE CP/M.. - CPI 7BH ;..DOES THE SAME. - JNC NOUCASE - ANI 5FH -NOUCASE POP B ! POP D ! POP H - RET -CONIN1 LHLD 1 - LXI D,6 - DAD D - PCHL - -CONSTAT PUSH H ! PUSH D ! PUSH B - CALL CONST1 - POP B ! POP D ! POP H - RET -CONST1 LHLD 1 - LXI D,3 - DAD D - PCHL - -CONOUT PUSH H ! PUSH D ! PUSH B ! PUSH PSW - CALL CONOUT1 - POP PSW ! POP B ! POP D ! POP H - RET -CONOUT1 LHLD 1 - LXI D,9 - DAD D - MOV C,A - PCHL - - ENDM - -CMDLINE MACRO ;NO PARAMETERS USED - -;LOADS A COMMAND LINE ADDRESSED BY DE REGISTERS (MAX # CHARACTERS IN LINE -;IN DE, NUMBER OF CHARS IN LINE IN DE+1, LINE STARTS IN DE+2) INTO FCB -;ADDRESSED BY HL REGISTERS. THE FCB SHOULD BE AT LEAST 33 BYTES IN LENGTH. -;THE COMMAND LINE BUFFER MUST HAVE A MAXIMUM LENGTH OF AT LEAST ONE MORE -;THAN THE GREATEST NUMBER OF CHARACTERS THAT WILL BE NEEDED. - - LOCAL CMDLINE, DEFDR, DONE, DRIVE, FILL1, FILL, FILL2, INIT, INITL1 - LOCAL INITL2, INITL3, INITL4, NAME1, NAME2, SCAN, TRANS, TSTNAM - LOCAL TSTTYP, TSTTYPL, TYPE1, TYPE2, NAME2C - - - PUSH PSW - PUSH B - PUSH D - PUSH H - - CALL INIT ;FILLS FCBS WITH BLANKS AND NULLS - - XCHG ;GET START OF COMMAND LINE IN HL. - INX H ;ADDRESS # BYTES IN CMD LINE. - MOV E,M ;LOAD DE PAIR WITH # BYTES. - MVI D,0 - INX H - DAD D ;POINT TO BYTE AFTER LAST CHAR.. - MVI M,0DH ;..IN CMD LINE AND STORE DELIMITER. - POP H ;RESTORE HL AND DE. - POP D - PUSH D - PUSH H - INX D ;ADDRESS START OF COMMAND. - INX D - - CALL DRIVE - -NAME1 MVI C,8 ;TRANSFER FIRST FILENAME TO FCB. - CALL TRANS - CPI 0DH - JZ DONE - CPI 20H ;IF SPACE, THEN START OF.. - JZ NAME2 ;..SECOND FILENAME. - -TYPE1 POP H ;FILETYPE MUST BE AFTER.. - PUSH H ;..EIGHTH BYTE OF NAME. - LXI B,9 - DAD B - MVI C,3 ;TRANSFER TYPE OF FIRST FILE - CALL TRANS - CPI 0DH - JZ DONE - -NAME2 LDAX D ;EAT MULTIPLE SPACES.. - CPI 20H ;..BETWEEN NAMES. - JNZ NAME2C - INX D - JMP NAME2 - LDAX D - CPI 0DH ;TEST IF FIRST NAME.. - JZ DONE ;..ONLY AND THEN SPACE. -NAME2C POP H ;SECOND NAME STARTS IN 16TH BYTE. - PUSH H ;POINT HL TO THIS BYTE. - LXI B,16 - DAD B - CALL DRIVE - MVI C,8 - CALL TRANS - CPI 0DH - JZ DONE - -TYPE2 POP H ;SECOND TYPE STARTS IN 25TH BYTE. - PUSH H - LXI B,25 - DAD B - MVI C,3 - CALL TRANS - -DONE POP H - PUSH H - INX H ;POINT TO FIRST CHAR OF FIRST NAME IN FCB. - CALL SCAN ;CHECK FOR * (AMBIGUOUS NAMES). - POP H - PUSH H - LXI B,17 ;POINT TO FIRST CHAR OF SECOND NAME IN FCB. - DAD B - CALL SCAN - POP H - POP D - POP B - POP PSW - RET - -; =============>>> SUBROUTINES <<=============== - -INIT PUSH H ;INITIALIZES FCB WITH 1 NULL (FOR FIRST DRIVE),.. - PUSH B ;..11 BLANKS, 4 NULLS, 1 NULL (FOR 2ND DRIVE),.. - MVI M,0 ;..11 BLANKS, AND 4 NULLS. - INX H - MVI B,11 - MVI A,20H - CALL INITFILL - MVI B,5 - MVI A,0 - CALL INITFILL - MVI B,11 - MVI A,20H - CALL INITFILL - MVI B,4 - MVI A,0 - CALL INITFILL - POP B - POP H - RET - -INITFILL - MOV M,A - INX H - DCR B - JNZ INITFILL - RET - -DRIVE INX D ;CHECK 2ND BYTE OF FILENAME. IF IT.. - LDAX D ;..IS A ":", THEN DRIVE WAS SPECIFIED. - DCX D - CPI ':' - JNZ DEFDR ;ELSE ZERO FOR DEFAULT DRIVE ('INIT' PUT ZERO) - LDAX D - ANI 5FH - SUI 40H ;CALCULATE DRIVE (A=1, B=2,...).. - MOV M,A ;..AND PLACE IT IN FCB. - INX D ;ADDRESS FIRST BYTE OF.. - INX D ;..IN CMD LINE,.. -DEFDR INX H ;..AND NAME FIELD IN FCB. - RET - -TRANS LDAX D ;TRANSFER FROM CMD LINE TO FCB.. - INX D ;..UP TO NUMBER OF CHARS SPECIFIED.. - CPI 0DH ;..BY C-REG. KEEP SCANNING FIELD.. - RZ ;..WITHOUT TRANSFER UNTIL A DELIMITING.. - CPI '.' ;..FIELD CHAR SUCH AS '.', BLANK, OR.. - RZ ;..C/R (FOR END OF CMD LINE). - CPI 20H - RZ - DCR C - JM TRANS ;ONCE C-REG IS LESS THAN ZERO, KEEP READING.. - MOV M,A ;..CMD LINE BUT DO NOT TRANSFER TO FCB. - INX H - JMP TRANS - -SCAN MVI B,8 ;SCAN FILE NAME ADDRESSED BY HL. -TSTNAM MOV A,M - CPI '*' ;IF '*' FOUND, FILL IN REST OF FIELD.. - JZ FILL1 ;..WITH '?' FOR AMBIGUOUS NAME. - INX H - DCR B - JNZ TSTNAM - JMP TSTTYP -FILL1 CALL FILL - -TSTTYP MVI B,3 ;SCAN AND FILL TYPE FIELD FOR NAME.. -TSTTYPL MOV A,M ;..SPECIFIED ABOVE. - CPI '*' - JZ FILL2 - INX H - DCR B - RZ - JMP TSTTYPL -FILL2 CALL FILL - RET - -FILL MVI M,'?' ;ROUTINE TRANSFERS '?'. - INX H - DCR B - JNZ FILL - RET - - ENDM - -INLNCOMP MACRO ;NO PARAMETERS USED - -;IN-LINE COMPARE. COMPARES STRING ADDRESSED BY DE-REG TO STRING -;AFTER CALL (ENDS WITH ZERO). RETURN WITH CARRY SET MEANS STRINGS -;NOT THE SAME. ALL REGISTERS EXCEPT A-REG ARE UNAFFECTED. - - LOCAL ILCOMPL, SAME, NOTSAME, NSLP - - XTHL ;POINT HL TO 1ST CHAR. - PUSH D -ILCOMPL MOV A,M ;HL POINTS TO IN-LINE STRING. - ORA A ;END OF STRING IF ZERO. - JZ SAME - LDAX D - CMP M - JNZ NOTSAME - INX H - INX D - JMP ILCOMPL -NOTSAME MVI A,0 ;IF NOT SAME, FINISH THRU.. -NSLP INX H ;..STRING SO RETURN WILL.. - CMP M ;..GO TO INSTRUCTION AFTER.. - JNZ NSLP ;..STRING AND NOT REMAINDER OF STRING. - STC -SAME POP D - INX H ;AVOIDS A NOP INSTRUCTION.. - XTHL ;..WHEN RETURNING. - RET - - ENDM - -MFACCESS MACRO ;NO PARAMETERS USED - - LOCAL MOVE, CPM, MFNAME, MFN01, MFN02, MFFIX1, MFREQ - LOCAL MFCUR, MOVER, SRCHF, SRCHN, STDMA, BDOS, FCB, FCBEXT - LOCAL FCBRNO - - ;MFFLG1 IS NOT SET LOCAL BECAUSE IT MUST BE RESET - ;IN MAIN MODEM PROGRAM ON AN ABORT - -; -; MUST BE ASSEMBLED BY "MAC" -; -;MULTI-FILE ACCESS SUBROUTINE. ALLOWS PROCESSING -;OF MULTIPLE FILES (I.E. *.ASM) FROM DISK. THIS -;ROUTINE BUILDS THE PROPER NAME IN THE FCB EACH -;TIME IT IS CALLED. THIS COMMAND WOULD BE USED -;IN SUCH PROGRAMS AS MODEM TRANSFER, TAPE SAVE, -;ETC IN WHICH YOU WANT TO PROCESS SINGLE OR -;MULTIPLE FILES. -; -;THE FCB WILL BE SET UP WITH THE NEXT NAME, READY TO -;DO NORMAL PROCESSING (OPEN, READ, ETC.) WHEN ROUTINE IS CALLED. -; -;CARRY IS SET IF NO MORE NAMES CAN BE FOUND -; -;DEFINE DATA MOVE MACRO -; -MOVE MACRO ?F,?T,?L,?I - IF NOT NUL ?F - LXI H,?F - ENDIF - IF NOT NUL ?T - LXI D,?T - ENDIF - IF NOT NUL ?L - LXI B,?L - ENDIF - IF NOT NUL ?I - LOCAL ?B,?Z - CALL ?Z -?B DB ?I -?Z POP H ;GET TO - LXI B,?Z-?B - ENDIF - CALL MOVER -MF SET -1 ;;SHOW EXPANSION - ENDM -; -;DEFINE CP/M MACRO - CPM FNC,PARM -; -CPM MACRO ?F,?P - PUSH B - PUSH D - PUSH H - IF NOT NUL ?F - MVI C,?F - ENDIF - IF NOT NUL ?P - LXI D,?P - ENDIF - CALL BDOS - POP H - POP D - POP B - ENDM -; -;------------------------------------------------ -; -; MULTI-FILE ACCESS SUBROUTINE -; -;THE ROUTINE IS COMMENTED IN PSEUDO CODE, -;EACH PSEUDO CODE STATEMENT IS IN <<...>> -; -MFNAME: -;<> - CPM STDMA,80H - XRA A ! STA FCBEXT -;<> - LDA MFFLG1 ! ORA A ! JNZ MFN01 -; <> - MVI A,1 ! STA MFFLG1 -; <> - MOVE FCB,MFREQ,12 ;SAVE ORIG REQ - LDA FCB ! STA MFCUR ;SAVE DISK IN CURR FCB -; <> - MOVE MFREQ,FCB,12 - CPM SRCHF,FCB -;<> - JMP MFN02 -MFN01: -; <> - MOVE MFCUR,FCB,12 - CPM SRCHF,FCB -; <> - MOVE MFREQ,FCB,12 - CPM SRCHN,FCB -;<> -MFN02: -;<> - INR A ! STC ! JNZ MFFIX1 ! STA MFFLG1 ! RET ;FIX BY M.Z. -MFFIX1: -;<> - DCR A ! ANI 3 ! ADD A - ADD A ! ADD A ! ADD A ! ADD A - ADI 81H ! MOV L,A ! MVI H,0 - PUSH H ;SAVE NAME POINTER - MOVE ,MFCUR+1,11 -;<> - POP H ! MOVE ,FCB+1,11 -;<> - XRA A ! STA FCBEXT ! STA FCBRNO ;FIX BY M.Z. -;<> - RET -; -;MULTI-FILE ACCESS WORK AREA -; -MFFLG1 DB 0 ;1ST TIME SW -MFREQ DS 12 ;REQ NAME -MFCUR DS 12 ;CURR NAME -;------------------------------------------------ -; -;MOVE SUBROUTINE -; -MOVER MOV A,M - STAX D - INX H - INX D - DCX B - MOV A,B - ORA C - JNZ MOVER - RET -; -;EQUATES USED BY MULTI-ACCESS SUBROUTINE -; -SRCHF EQU 17 -SRCHN EQU 18 -STDMA EQU 26 ;FIX BY M.Z. -BDOS EQU 5 -FCB EQU 5CH -FCBEXT EQU FCB+12 -FCBRNO EQU FCB+32 - ENDM - -DIRLIST MACRO ;NO PARAMETERS USED - - LOCAL DIRLP,PRTNAME,NOFILE,DIRDONE,QSTMARK,QSTLP,PRNTNAME,NEXTSR - LOCAL MOVENAME,GETADD,DRIVE,CALCDR,SRCHFCB,NAMECT,PRNTHD,DRNAME - - LXI D,CMDBUF ;PUT COMMAND LINE IN FCB - LXI H,5CH - CALL CPMLINE - LXI H,SRCHFCB - CALL INITFCBS - LDA 6CH ;GET DRIVE # - STA SRCHFCB - LDA 6DH - CPI 20H ;IF BLANK GET ALL NAMES - PUSH PSW - CZ QSTMARK - POP PSW - CNZ MOVENAME ;ELSE MOVE NAME INTO FCB - CALL DRIVE - LXI D,80H - MVI C,STDMA - CALL BDOS - XRA A - STA NAMECT ;CR AFTER 4 NAMES - LXI D,SRCHFCB - MVI C,SRCHF ;DO FIRST SEARCH - CALL BDOS - CPI 0FFH - JZ NOFILE - -DIRLP CALL GETADD - LXI D,15 ;OFFSET FOR RECORD COUNT - DAD D - MOV A,M - ORA A - JZ NEXTSR ;NO LIST IF FILE IS ZERO LENGTH - LXI D,-5 - DAD D ;POINT TO $SYS ATTRIB BYTE - MOV A,M - ANI 80H - JNZ NEXTSR ;NO LIST IF $SYS FILE - LXI D,-10 - DAD D ;POINT TO BEGINNING OF NAME - INX H ;POINT TO FIRST LETTER - LXI D,PRNTNAME - MVI B,8 - CALL MOVE - INX D - MVI B,3 - CALL MOVE - CALL ILPRT -PRNTNAME - DB ' ',' ',' ', ' | ', 0 ;8,1,3 SPACES - LDA NAMECT - INR A - STA NAMECT - ANI 03H - ORA A - CZ CRLF -NEXTSR LXI D,SRCHFCB - MVI C,SRCHN ;DO NEXT SEARCH - CALL BDOS - CPI 0FFH - JZ DIRDONE - JMP DIRLP -NOFILE CALL ILPRT - DB 'NOT FOUND',0 -DIRDONE CALL CRLF - RET - -QSTMARK MVI A,'?' ;IF BLANK IN FCB, PUT IN 11 ?'s - MVI B,11 - LXI H,SRCHFCB+1 -QSTLP MOV M,A - INX H - DCR B - JNZ QSTLP - RET - -MOVENAME - LXI H,6DH - LXI D,SRCHFCB+1 - MVI B,11 - CALL MOVE ;MOVE IN CP/M PROGRAM - RET - -GETADD ANI 03H ;GET MOD4 FOR CP/M 1.4 - ADD A ! ADD A ! ADD A ;ADD 32 - ADD A ! ADD A - MOV E,A - MVI D,0 - LXI H,80H ;ADD DMA OFFSET - DAD D - RET - -DRIVE LDA SRCHFCB ;IF NO DRIVE, CAL - ORA A ;LOGGED IN DRIVE - JZ CALCDR - ADI 40H - JMP PRNTHD -CALCDR MVI C,25 - CALL BDOS - ADI 41H -PRNTHD STA DRNAME - CALL ILPRT - DB CR,LF,'DRIVE ' -DRNAME DB ' ',CR,LF,0 - RET - -SRCHFCB DS 33 -NAMECT DS 1 - - ENDM - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/MODEM.PAS b/software/CPM/CPM13_MTPUG_01/MODEM.PAS deleted file mode 100644 index e758f07..0000000 --- a/software/CPM/CPM13_MTPUG_01/MODEM.PAS +++ /dev/null @@ -1,684 +0,0 @@ - -(* MODEM SOFTWARE PACKAGE FOR CPM *) - -(* PAUL L. GREENE *) -(* MICRO ENGINEERING *) -(* P.O. BOX 8094 *) -(* LA CRESCENTA, CA. 91214 *) - -(* THIS PROGRAM IS BEING SUBMITTED TO THE PASCAL/MT USER'S *) -(* GROUP FOR DISTRIBUTION AND USE BY INDIVIDUALS ONLY. *) -(* MICRO ENGINEERING RESERVES ALL OTHER RIGHTS TO THIS *) -(* PROGRAM. *) - -(* WRITTEN FOR THE PASCAL/MT COMPILER VERSION 3.1 *) - -(* PASCAL/MT COPYRIGHT MT MICROSYSTEMS *) -(* CP/M COPYRIGHT DIGITAL RESEARCH *) - -(*************************************************************) - -(* OPERATING INSTRUCTIONS *) - -(* THIS PROGRAM REQUIRES THAT THE "IOBYTE" BE IMPLEMENTED, *) -(* AND THAT THE MODEM IS CONNECTED TO ONE OF THE CONSOLE I/O *) -(* INTERFACES. THE PROGRAM PERFORMS CONSOLE SWAPPING TO *) -(* COMMUNICATE BETWEEN THE USER AND THE MODEM. THE USER'S *) -(* CONSOLE MUST BE AS FAST OR FASTER THAN THE MODEM SPEED. *) -(* THIS PROVIDES A HARDWARE INDEPENDENT MEANS OF CONTROLLING *) -(* THE MODEM. *) - -(* THE PROGRAM FIRST ASKS WHICH CONSOLE NUMBER THE MODEM IS *) -(* IS CONNECTED TO. ANSWER WITH A SINGLE DIGIT, 0-3. YOU *) -(* ARE THEN ASKED TO SELECT WHETHER CONSOLE INPUT IS TO BE *) -(* ECHOED ON THE CONSOLE OUTPUT. ANSWER 'Y' OR 'N'. *) - -(* YOU ARE THEN ASKED TO DEFINE SEVERAL SPECIAL CONTROL *) -(* CHARACTERS. ONLY THE CHARACTERS FOR "QUIT" AND "MODE" *) -(* ARE NOT SENT TO THE MODEM. THE OTHERS ARE USED TO *) -(* CONTROL THE REMOTE COMPUTER FROM THIS PROGRAM. A COMMAND *) -(* PROMPT LINE IS THEN DISPLAYED, AND THE DESIRED COMMAND *) -(* ENTERED BY TYPING THE FIRST LETTER. *) - -(* THE "INITIAL" COMMAND REPEATS THE ABOVE INITIALIZATION. *) - -(* THE "MODEM" COMMAND CONNECTS THE USER'S CONSOLE TO THE *) -(* MODEM FOR COMMUNICATION WITH THE REMOTE COMPUTER. THE *) -(* "COMMAND MODE" CONTROL CHARACTER CAN THEN BE USED ANYTIME *) -(* TO RETURN TO COMMAND LEVEL. *) - -(* THE "QUIT" COMMAND RETURNS CONTROL TO CP/M. *) - -(* ALL COMMUNICATION FROM THE MODEM TO THE USER MAY BE *) -(* CAPTURED ON A DISK FILE USING THE "RECEIVE" COMMAND. THE *) -(* PROGRAM WILL ASK FOR THE FILE NAME, WHICH MAY INCLUDE A *) -(* DISK DESIGNATOR. A RECEIVE FILE MAY BE OPENED AT ANY *) -(* TIME BY RETURNING TO COMMAND MODE. WHEN ALL DESIRED *) -(* TEXT HAS BEEN CAPTURED, THE FILE MUST BE CLOSED AND *) -(* LOGGED ON THE DISK USING THE "CLOSE" COMMAND AFTER *) -(* RETURNING TO COMMAND MODE. THE AMOUNT OF TEXT THAT CAN *) -(* BE CAPTURED IS ONLY LIMITED BY AVAILABLE DISK SPACE. *) -(* THE TEXT IS INITIALLY BUFFERED IN MAIN MEMORY UNTIL THE *) -(* BUFFER IS FULL. A "SUSPEND" CHARACTER IS THEN SENT TO *) -(* THE MODEM, AND THE BUFFER IS WRITTEN TO DISK. THE *) -(* PROGRAM THEN SENDS A "CONTINUE" CHARACTER TO THE MODEM *) -(* AND RESUMES CAPTURING THE TEXT. THEREFORE, THE REMOTE *) -(* COMPUTER THAT YOU ARE COMMUNICATING WITH MUST HAVE BOTH *) -(* "SUSPEND" AND "CONTINUE" CAPABILITY. *) - -(* DISK FILES MAY BE SENT TO THE MODEM USING THE "SEND" *) -(* COMMAND. THE PROGRAM ASKS FOR THE NAME OF THE FILE TO *) -(* BE SENT, WHICH MAY INCLUDE A DISK DESIGNATOR. THE FILE *) -(* IS THEN OPENED AND PREPARED FOR TRANSMISSION. ACTUAL *) -(* SENDING OF THE FILE DOES NOT BEGIN UNTIL RETURNING TO *) -(* "MODEM" MODE. THE SEND FILE IS ECHOED ON THE USER'S *) -(* CONSOLE UNTIL COMPLETE OR UNTIL SUSPENDED BY RETURNING *) -(* TO COMMAND LEVEL. THE SEND FILE IS ALSO FULLY BUFFERED *) -(* AND CAN BE ANY LENGTH UP TO AVAILABLE DISK CAPACITY. *) -(* A FILE CAN BE SENT AT ANY TIME BY USING THE ABOVE *) -(* PROCEDURE AFTER RETURNING TO COMMAND LEVEL. *) - -(* MODIFICATIONS *) - -(* A DEDICATED MODEM CAN BE USED BY MODIFYING THE FOLLOWING *) -(* PROCEDURES TO DIRECTLY ACCESS THE DEVICE: *) -(* PROCEDURE WRITEMODEM *) -(* PROCEDURE READMODEM *) -(* PROCEDURE TESTMODEM *) - - -(*************************************************************) -(*-----------------------------------------------------------*) -(*************************************************************) - -PROGRAM MODEM; - -CONST - ENDFILE=$1A; (* CP/M EOF (CONTROL-Z) *) - BUFSIZE=4095; (* DISK FILE BUFFERS *) - RECSIZE=79; - CR=$0D; - LF=$0A; - SPACE=$20; - NULL=00; - - (* BDOS FUNCTIONS - SEE CP/M MANUAL *) - IOCHK=7;IOSET=8; - - (* BIOS FUNCTIONS - SEE CP/M MANUAL *) - WBOOT=0;CONSTS=3;CONIN=6;CONOUT=9; - -TYPE - BUFFER=ARRAY [0..BUFSIZE] OF CHAR; - REC=ARRAY [0..RECSIZE] OF CHAR; -VAR - INTITLE,OUTTITLE :ARRAY [0..13] OF CHAR; - - INFILE,OUTFILE :TEXT; - - INBUF,OUTBUF :BUFFER; - - TRANSDATA,RECDATA, - SUSPEND,CONTINUE, - TERMINATE,MODE,QUIT, - CIOBYTE,MIOBYTE, - ININDEX,OUTINDEX :INTEGER; - - DISKFULL,EOF, - FISTAT,FOSTAT, - CISTAT,MISTAT, - COREADY,MOREADY, - DONE,MWAIT,CRLF, - CONECHO,PARITY :BOOLEAN; - -(*************************************************************) -(*************************************************************) - -(*$L-*) -(*$I FILEIO*) { CP/M FILE I/O LIBRARY } -(*$L+*) - -(*************************************************************) - -{ CP/M BDOS SUBROUTINE CALL } - -PROCEDURE EXTERNAL [5] MON2(FUNCT:INTEGER;INFO:INTEGER); - -(*************************************************************) - -{ CP/M BDOS FUNCTION CALL } - -FUNCTION MON1(FUNCT:INTEGER;INFO:INTEGER):INTEGER; - -VAR TEMP:INTEGER; - -BEGIN - -(* CALL MONITOR(BDOS), VALUE RETURNED IN REG A(LOW),B(HIGH) *) - -MON2(FUNCT,INFO); - -(* MOVE BA TO HL, SAVE AS TEMP *) - -INLINE ("MOV L,A/ - "MOV H,B/ - "SHLD / TEMP ); - -MON1:=TEMP; - -END; - -(*************************************************************) - -{ THIS PROCEDURE PERFORMS DIRECT ACCESS OF BIOS SUBROUTINES. } -{ THE ADDRESS OF THE BIOS SUBROUTINE JUMP TABLE IS ASSUMED } -{ TO BE AVAILABLE AT LOCATION 0001. THE PARAMETER "FUNCT" } -{ IS AN INDEX, MODULO-3, TO THE JUMP TABLE TO SELECT THE } -{ DESIRED FUNCTION. THE PARAMETER "INFO" IS PASSED TO THE } -{ BIOS SUBROUTINE IN REGISTER C. WITH SINCERE APOLOGIES, } -{ THIS ROUTINE IS SELF-MODIFYING, BUT IT IS ALSO SELF- } -{ RESTORING. THIS WAS NECESSARY SINCE FORWARD LABEL } -{ REFERENCES ARE NOT ALLOWED IN INLINE CODE, AND NO OTHER } -{ MEANS OF PERFORMING A COMPUTED SUBROUTINE CALL COULD BE } -{ DEVISED. } - -PROCEDURE BIOS2(FUNCT,INFO:INTEGER); - -VAR - ENTRY,ADDRESS,TEMP:INTEGER; -BEGIN -ENTRY:=$0001; (* LOCATION OF BIOS WARM START ENTRY ADDRESS *) -ADDRESS:=ENTRY^ + FUNCT; (* INDEX JUMP TABLE ENTRY *) -TEMP:=INFO; (* PUT INFO AT KNOWN ADDRESS *) -INLINE( [START]/"NOP / (* MODIFIED OPCODE *) - "LDA /TEMP/ (* GET INFO *) - "MOV C,A/ (* PUT IN C *) - "LHLD /ADDRESS/ (* LOAD BIOS ENTRY *) - "MVI A,/$E9/ (* 'PCHL' OPCODE *) - "STA /START/ (* MODIFY LOCATION *) - "CALL /START/ (* BRANCH TO BIOS *) - "MVI A,/$0/ (* 'NOP' OPCODE *) - "STA /START ); (* RESTORE OPCODE *) - -END; - -(*************************************************************) - -{ THIS FUNCTION IS SIMILAR TO PROCEDURE BIOS2 EXCEPT THAT THE } -{ CONTENT OF REGISTER A (AFTER RETURN FROM BIOS SUBROUTINE) } -{ IS RETURNED AS THE FUNCTION VALUE. } - -FUNCTION BIOS1(FUNCT,INFO:INTEGER):INTEGER; - -VAR ENTRY,ADDRESS,TEMP:INTEGER; - -BEGIN -ENTRY:=$0001; -ADDRESS:=ENTRY^ + FUNCT; -TEMP:=INFO; -INLINE( [START]/"NOP/ - "LDA /TEMP/ - "MOV C,A/ - "LHLD /ADDRESS/ - "MVI A,/$E9/ - "STA /START/ - "CALL /START/ - "MOV L,A/ (* SAVE RETURNED DATA*) - "MVI H,/0/ (* CLEAR HIGH BYTE *) - "SHLD /TEMP/ - "MVI A,/$0/ - "STA /START ); - -BIOS1:=TEMP; -END; - -(*************************************************************) - -PROCEDURE WRITECONSOLE(DATA:INTEGER); - -BEGIN -IF DATA=CR THEN CRLF:=TRUE; -IF (DATA <> CR) AND (CRLF=TRUE) THEN - BEGIN - IF DATA <> LF THEN BIOS2(CONOUT,LF); - CRLF:=FALSE; - END; -BIOS2(CONOUT,DATA); -END; - -(*************************************************************) - -PROCEDURE TESTCONSOLE(VAR STAT:BOOLEAN); - -VAR DATA:INTEGER; - -BEGIN -DATA:=BIOS1(CONSTS,0); -IF DATA=$00FF THEN STAT:=TRUE ELSE STAT:=FALSE; -END; - -(*************************************************************) - -PROCEDURE SETPARITY(VAR DATA:INTEGER); - -VAR RESULT:BOOLEAN; - -(*****************************) - -FUNCTION TESTPARITY(DATA:INTEGER):BOOLEAN; - -VAR -RESULT:BOOLEAN; -X:INTEGER; - -BEGIN -X:=DATA; -INLINE( "LDA /X/ (* GET CHAR *) - "ORA A/ (* SET PARITY FLAG *) - "PUSH PSW/ (* GET FLAGS TO A *) - "POP H/ - "MOV A,L/ - "RRC/ (* SHIFT PARITY TO LSB *) - "RRC/ - "ANI /$01/ (* MASK OTHER BITS *) - "MOV L,A/ (* MAKE BOOLEAN *) - "MVI H,/0/ - "SHLD /RESULT ); (* TRUE IF EVEN PARITY *) - -TESTPARITY:=RESULT; -END; - -(******************************) - -PROCEDURE CHANGEPARITY(VAR DATA:INTEGER); - -VAR X:INTEGER; - -BEGIN -X:=DATA; -INLINE( "LDA /X/ - "XRI /$80/ (* COMPLEMENT MSB *) - "STA /X ); -DATA:=X; -END; - -(******************************) - -BEGIN (*SETPARITY*) -RESULT:=TESTPARITY(DATA); -IF ((RESULT=TRUE) AND (PARITY=FALSE)) OR - ((RESULT=FALSE) AND (PARITY=TRUE)) - THEN CHANGEPARITY(DATA); -END; (*SETPARITY*) - -(*************************************************************) - -PROCEDURE WRITEMODEM(VAR DATA:INTEGER); - -BEGIN -SETPARITY(DATA); -MON2(IOSET,MIOBYTE); -BIOS2(CONOUT,DATA); -MON2(IOSET,CIOBYTE); -END; - -(*************************************************************) - -PROCEDURE TESTMODEM(VAR STAT:BOOLEAN); - -VAR DATA:INTEGER; - -BEGIN -MON2(IOSET,MIOBYTE); -DATA:=BIOS1(CONSTS,0); -IF DATA=$00FF THEN STAT:=TRUE ELSE STAT:=FALSE; -MON2(IOSET,CIOBYTE); -END; - -(*************************************************************) - -PROCEDURE READMODEM(VAR DATA:INTEGER); - -BEGIN -REPEAT - TESTMODEM(MISTAT) -UNTIL MISTAT=TRUE; -MON2(IOSET,MIOBYTE); -DATA:=BIOS1(CONIN,0); -DATA:=DATA & $007F; -MON2(IOSET,CIOBYTE); -END; - -(*************************************************************) - -PROCEDURE READFILE(VAR DATA:INTEGER); - -BEGIN -IF OUTINDEX > BUFSIZE THEN - BEGIN - WRITEMODEM(SUSPEND); - DATA:=ORD(GNB(OUTFILE,OUTBUF,OUTINDEX,EOF)); - WRITEMODEM(CONTINUE); - END -ELSE - DATA:=ORD(GNB(OUTFILE,OUTBUF,OUTINDEX,EOF)); - -IF EOF THEN - BEGIN - DATA:=0; - WRITELN;WRITELN('* * * END OF TRANSMIT FILE * * *'); - FOSTAT:=FALSE; - MOREADY:=FALSE; - END; - -END; - -(*************************************************************) - -PROCEDURE WRITEFILE(DATA:INTEGER); - -VAR - CH:CHAR; - TBUF:ARRAY[0..80] OF INTEGER; - I,TDATA,TIMER,TINDEX:INTEGER; - -BEGIN -IF ININDEX >= BUFSIZE THEN { WRITE BUFFER TO DISK } - - BEGIN - WRITEMODEM(SUSPEND); - - { CONTINUE READING MODEM UNTIL NO CHARACTERS ARE RECEIVED } - { FOR A RESPECTABLE PERIOD OF TIME. THIS ALLOWS THE REMOTE } - { TIME TO REACT TO THE "SUSPEND". THE CHARACTERS ARE PLACED } - { IN A TEMPORARY BUFFER UNTIL MODEM TRANSFERS STOP. CURRENT } - { TIMEOUT PERIOD IS APPROXIMATELY 2 SEC. } - - TINDEX:=0; - TBUF[TINDEX]:=DATA; - TIMER:=0; - WHILE TIMER < 1000 DO - BEGIN - TESTMODEM(MISTAT); - IF MISTAT THEN - BEGIN - READMODEM(TDATA); - TINDEX:=TINDEX+1; - TBUF[TINDEX]:=TDATA; - TIMER:=0; - END - ELSE TIMER:=TIMER+1; - END; - - { NOW THE CHARACTERS ARE RETRIEVED FROM THE TEMP BUFFER } - { AND WRITTEN TO DISK. IF MORE THAN 1 CHARACTER IS IN } - { THE BUFFER, THEN WRITE TO THE CONSOLE ALSO. } - - FOR I:=0 TO TINDEX DO - BEGIN - TDATA:=TBUF[I]; - CH:=CHR(TDATA); - IF (NOT DISKFULL) THEN - WNB(INFILE,INBUF,ININDEX,DISKFULL,CH); - IF I <> 0 THEN WRITECONSOLE(TDATA); - END; - - { THE REMOTE CAN NOW BE ALLOWED TO CONTINUE. } - - WRITEMODEM(CONTINUE); - END - -ELSE - - BEGIN - CH:=CHR(DATA); - WNB(INFILE,INBUF,ININDEX,DISKFULL,CH); - END; - - -IF DISKFULL THEN - BEGIN - WRITEMODEM(TERMINATE); - WRITELN; - WRITELN('* * * DISK FULL - TRANSFER TERMINATED * * *'); - FISTAT:=FALSE - END; - -END; - -(*************************************************************) - -PROCEDURE INITIAL; - -VAR - CONSOLE:INTEGER; - CH:CHAR; - -FUNCTION CONTROL:INTEGER; - -VAR CH:CHAR; - -BEGIN -READ(CH);WRITELN; -CONTROL:=ORD(CH) & $001F -END; - - -BEGIN -DONE:=FALSE;MWAIT:=FALSE;CRLF:=FALSE; -FOSTAT:=FALSE;FISTAT:=FALSE; -COREADY:=FALSE;MOREADY:=FALSE; -CISTAT:=FALSE;MISTAT:=FALSE; - -CIOBYTE:=MON1(IOCHK,0); -MIOBYTE:=CIOBYTE & $FFFC; (* LOGICAL AND TO CLEAR 2 LSB *) -CONSOLE:=CIOBYTE & $0003; (* LOGICAL AND TO MASK 2 LSB *) - -WRITELN;WRITELN('* * * MODEM COMMUNICATION PROGRAM * * *'); -WRITELN;WRITELN('CURRENT CONSOLE NUMBER: ',CONSOLE); - -REPEAT - WRITE('ENTER MODEM CONSOLE NUMBER (0-3): '); - READ(CONSOLE);WRITELN -UNTIL (CONSOLE >= 0) AND (CONSOLE <= 3); -MIOBYTE:=MIOBYTE + CONSOLE; - -WRITE('WANT CONSOLE ECHO (Y OR N)?'); -READ(CH);WRITELN; -IF CH='Y' THEN CONECHO:=TRUE ELSE CONECHO:=FALSE; - -WRITE('ENTER SUSPEND CHARACTER: CONTROL-'); -SUSPEND:=CONTROL; - -WRITE('ENTER CONTINUE CHARACTER: CONTROL-'); -CONTINUE:=CONTROL; - -WRITE('ENTER TERMINATE CHARACTER: CONTROL-'); -TERMINATE:=CONTROL; - -WRITE('ENTER COMMAND MODE CHARACTER:CONTROL-'); -MODE:=CONTROL; - -WRITE('ENTER SYSTEM RETURN CHARACTER: CONTROL-'); -QUIT:=CONTROL; - -WRITE('WANT EVEN OR ODD PARITY (E OR O)?'); -READ(CH);WRITELN; -IF CH='E' THEN PARITY:=TRUE ELSE PARITY:=FALSE; - -WRITELN('* * * INITIALIZATION COMPLETE * * *'); -WRITELN; - -END; - -(*************************************************************) - -PROCEDURE COMMAND; - -TYPE - NAME=ARRAY[0..11] OF CHAR; - STRING=RECORD - LEN:INTEGER; - VAL:ARRAY[1..79] OF CHAR - END; -VAR - CH:CHAR; - RESULT:INTEGER; - FILENAME:NAME; - -(*$L-*) -(*$ISTRIO*) -(*$IFILESTUF*) -(*$L+*) - -PROCEDURE READTITLE(VAR T:NAME); - -VAR - TITLE,FILENAME:STRING; - -BEGIN -WRITE(' FILE:'); -READSTR(FILENAME);WRITELN; -NAMEPARSER(FILENAME,TITLE); -MOVE(TITLE.VAL[1],T[0],12); -END; - -BEGIN (* COMMAND *) -WRITEMODEM(SUSPEND); -CH:=' '; -REPEAT - WRITELN;WRITELN; - WRITE('COMMAND:I(NITIAL),S(END),R(ECEIVE),C(LOSE),M(ODEM),Q(UIT) ?'); - READ(CH);WRITELN; - - IF CH='I' THEN INITIAL; - - IF CH='S' THEN - BEGIN - WRITE('SEND'); - READTITLE(FILENAME); - OPEN(OUTFILE,FILENAME,RESULT); - - IF RESULT=255 THEN - WRITELN('* * * UNABLE TO OPEN FILE * * *') - ELSE - BEGIN - OUTINDEX:=BUFSIZE+1; - FOSTAT:=TRUE; - END; - END; - - IF CH='R' THEN - BEGIN - WRITE('RECEIVE'); - READTITLE(FILENAME); - OPEN(INFILE,FILENAME,RESULT); - - IF RESULT <> 255 THEN DELETE(INFILE); - - CREATE(INFILE,FILENAME,RESULT); - IF RESULT=255 THEN - WRITELN('* * * DIRECTORY FULL * * *') - ELSE - BEGIN - ININDEX:=0; - FISTAT:=TRUE; - END; - END; - - IF CH='C' THEN - BEGIN - WRITEFILE(ENDFILE); - IF ININDEX <> 0 THEN - BEGIN - ININDEX:=BUFSIZE; - WRITEFILE(ENDFILE); - END; - CLOSE(INFILE,RESULT); - FISTAT:=FALSE; - END; - - IF CH='Q' THEN BIOS2(WBOOT,0); - -UNTIL CH='M'; -WRITELN('*** RETURNING TO MODEM ***'); -WRITELN; -WRITEMODEM(CONTINUE); - -END; - -(*************************************************************) -(*************************************************************) - -BEGIN -INITIAL; -COMMAND; -WHILE NOT DONE DO - BEGIN - - IF NOT MOREADY THEN (* GET NEW OUTPUT *) - - IF FOSTAT THEN (* GET FROM FILE *) - BEGIN - READFILE(TRANSDATA); - MOREADY:=TRUE; - END - ELSE (* GET FROM CONSOLE *) - BEGIN - TESTCONSOLE(CISTAT); - IF CISTAT THEN - BEGIN - TRANSDATA:=BIOS1(CONIN,0); - MOREADY:=TRUE; - END; - END; - - IF MOREADY THEN - BEGIN - IF TRANSDATA = QUIT THEN BIOS2(WBOOT,0); - IF TRANSDATA = MODE THEN - BEGIN - MOREADY:=FALSE; - COMMAND; - END; - - END; - - IF NOT COREADY THEN (* GET NEW INPUT *) - - BEGIN - TESTMODEM(MISTAT); - IF MISTAT THEN (* GET FROM MODEM *) - BEGIN - READMODEM(RECDATA); - COREADY:=TRUE; - IF RECDATA=SUSPEND THEN - BEGIN - REPEAT READMODEM(RECDATA) - UNTIL RECDATA=CONTINUE; - COREADY:=FALSE; - END; - END; - END; - - IF COREADY THEN (* SEND TO CONSOLE *) - BEGIN - WRITECONSOLE(RECDATA); - IF FISTAT THEN WRITEFILE(RECDATA); - COREADY:=FALSE; - END; - - IF MOREADY THEN (* SEND TO MODEM *) - BEGIN - WRITEMODEM(TRANSDATA); - IF CONECHO THEN - BEGIN - BIOS2(CONOUT,TRANSDATA); - IF TRANSDATA=CR THEN BIOS2(CONOUT,LF); - END; - MOREADY:=FALSE; - END; - - END; -END. (* MODEM *) - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/MTPUG01.BAK b/software/CPM/CPM13_MTPUG_01/MTPUG01.BAK deleted file mode 100644 index 10836e2..0000000 --- a/software/CPM/CPM13_MTPUG_01/MTPUG01.BAK +++ /dev/null @@ -1,50 +0,0 @@ -MODEM.PAS MT+Version 3.1 Program to send and recieve from -MODEM.LIB either the console or a disk file. - -ARCTAN.PAS/ERL These modules are complete and correct source - EXP.PAS/ERL for all of the trancendental functions vended - LN.PAS/ERL with Pascal/5.1. They fix a bug in the ARCTAN -SINCOS.PAS/ERL function and may either be more effedient - or more stable for large arguments. Sine and - Cosine are probably equal to those provided - TRANCEND.TWL is the replacement library. - -PAGE.DOC/PAS/COM Display a file on the console a page at a time. - -GRAPH.DOC/PAS Graph is the driving proceedure for PLOT. - PLOT.MOD Chats with the user at the terminal while - F.PAS PLOT and the function in F do all the work. - -FILSIZ.SRC/ERL Given the file name, return the file size using - CPM function 35 - -CMPXLIB.SRC/ERL Complex arithmetic library for Pascal MT+. -CMPLTEST.SRC/ERL/COM Test CMPXLIB - -MATHLIB.SRC/ERL Fifteen functions needed for most Scientific -MATHTEST.SRC/ERL/COM calculations. Test routine. - -CP/M-DEC.DOC Series of routine to read/write DEC disks to -CPMTODEC.COM CP/M or visa versa -DECTOCPM.COM -LISTDEC.COM List a DEC file. - -NSBH19.SRC Heath H-19 Version of NSB.SRC -NSBH19.DOC -SBGETCH.SRC Wordstar Version of Console Commands. - -RANDOM.PAS/ERL Random Number generator written by Ray Penley - for Pascal/Z Users Group - - RNB.SRC/ERL 5.1 Version of GNB and @RNB - GNB.SRC/ERL - -LIST.COM A program to list multiple files at either - the printer or the terminal. - -SHIFT.DOC/COM Shift from lower case to upper case: Pascal program only - -SD.COM Display the directory with space used in alphabetical - order. - - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/MTPUG01.DOC b/software/CPM/CPM13_MTPUG_01/MTPUG01.DOC deleted file mode 100644 index 6c9bb22..0000000 --- a/software/CPM/CPM13_MTPUG_01/MTPUG01.DOC +++ /dev/null @@ -1,50 +0,0 @@ -MODEM.PAS MT+Version 3.1 Program to send and recieve from -MODEM.LIB either the console or a disk file. - -ARCTAN.SRC/ERL These modules are complete and correct source - EXP.SRC/ERL for all of the trancendental functions vended - LN.SRC/ERL with Pascal/5.1. They fix a bug in the ARCTAN -SINCOS.SRC/ERL function and may either be more effedient - or more stable for large arguments. Sine and - Cosine are probably equal to those provided - TRANCEND.TWL is the replacement library. - -PAGE.DOC/PAS/COM Display a file on the console a page at a time. - -GRAPH.DOC/PAS Graph is the driving proceedure for PLOT. - PLOT.MOD Chats with the user at the terminal while - F.PAS PLOT and the function in F do all the work. - -FILSIZ.SRC/ERL Given the file name, return the file size using - CPM function 35 - -CMPXLIB.SRC/ERL Complex arithmetic library for Pascal MT+. -CMPLTEST.SRC/ERL/COM Test CMPXLIB - -MATHLIB.SRC/ERL Fifteen functions needed for most Scientific -MATHTEST.SRC/ERL/COM calculations. Test routine. - -CP/M-DEC.DOC Series of routine to read/write DEC disks to -CPMTODEC.COM CP/M or visa versa -DECTOCPM.COM -LISTDEC.COM List a DEC file. - -NSBH19.SRC Heath H-19 Version of NSB.SRC -NSBH19.DOC -SBGETCH.SRC Wordstar Version of Console Commands. - -RANDOM.PAS/ERL Random Number generator written by Ray Penley - for Pascal/Z Users Group - - RNB.SRC/ERL 5.1 Version of GNB and @RNB - GNB.SRC/ERL - -LIST.COM A program to list multiple files at either - the printer or the terminal. - -SHIFT.DOC/COM Shift from lower case to upper case: Pascal program only - -SD.COM Display the directory with space used in alphabetical - order. - - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/NSBH19.DOC b/software/CPM/CPM13_MTPUG_01/NSBH19.DOC deleted file mode 100644 index ce8279d..0000000 --- a/software/CPM/CPM13_MTPUG_01/NSBH19.DOC +++ /dev/null @@ -1,47 +0,0 @@ - - -Ver 1.00 -HELPSPP.HLP - - -New SPP editor commands - -Note: All are control(letter) - - -Function NEW (OLD) -------------------------------------------------------------------- -Cursor left word A (A) - " beg | end line B (B) - " foward page C (C) - " right word F (D) - Repeat search using last string W (E) - Insert mode on V (F) - DELETE char right G (G) - Backspace S or H (H) - Tab I (I) -Cursor down X (J) - " up E (K) - " right D (L) - " start of next line M (M) - Insert blank line following cursor N (N) - DELETE work right T (O) - DELETE line right - (P) - SUPER COMMAND Q (Q) -Cursor back page R (R) - Search esc direction count O (S) -Cursor top | bottem screen P (T) - Enter adjust mode K=accept esc=abort J (U) - End & accept insert, adjust, delete line K (V) - Copy text from copy buf (may be repeated) U (W) - Search & replace esc esc [V] L (X) - DELETE line K=accept esc=abort Y (Y) - Insert blank line at cursor Z (Z) - -Note: In search and replace Verify mode; - R = go ahead and replace - sp = don't replace but continue - esc = abort command - - - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/NSBH19.SRC b/software/CPM/CPM13_MTPUG_01/NSBH19.SRC deleted file mode 100644 index 7bd7861..0000000 --- a/software/CPM/CPM13_MTPUG_01/NSBH19.SRC +++ /dev/null @@ -1,359 +0,0 @@ -(* VERSION 0058 *) -(* SETUP FOR Zenith H-19 terminal 8 July 81 frg *) -(* Uses ZDS escape sequences *) -(* ADDED CONVERSION TO WORDSTAR COMMANDS - 14 JULY 81 FRG *) -(* VER 2.04 *) -(*$K0*) -(*$K1*) -(*$K2*) -(*$K5*) -(*$K6*) -(*$K7*) -(*$K8*) -(*$K12*) -(*$K13*) -(*$K14*) -(*$K15*) -PROGRAM PASCAL_SPP; - -(*$I EDTYPES*) -(*$I EDGLBLS*) - -TYPE -CPMOPERATION = (COLDBOOT,WARMBOOT,CONSTAT,CONIN,CONOUT,LIST, - PUNOUT,RDRIN,HOME,SELDSK,SETTRK,SETSEC,SETDMA, - DSKREAD,DSKWRITE); - -FNAME = ARRAY [1..8] OF CHAR; (* CP/M FILE NAME *) - -EXTENSION = ARRAY [1..3] OF CHAR; (* EXTENSION TO NAME *) - -FCB = RECORD - DSK : BYTE; - FN : FNAME; - EXT : EXTENSION; - OTHER: ARRAY [12..36] OF BYTE - END; - -DIRENT = RECORD - ET : BYTE; - FN : FNAME; - EXT : EXTENSION; - OTHR : ARRAY [12..31] OF BYTE - END; - -(*$I SBIFDEF.LIB*) - - - -VAR - - DIRFILE: FCB; (* FOR DISPLAYING DIRECTORIES *) - DIRBUF: ARRAY [0..3] OF DIRENT; - - FSTRING: STRING; - MEMORY: ABSOLUTE [$0000] ARRAY[0..0] OF BYTE; - CMDCH: CHAR; - @SFP: EXTERNAL INTEGER; - BUFSTAT: STATREC; - INTRFACE: SB_INTERFACE; (* USED TO COMMUNICATE BETWEEN PROGRAMS *) - SB_LAST_X, - SB_LAST_Y: INTEGER; (* FOR SOFTWARE CLR TO EOL/ CLR TO EOS ROUTINES *) - - -EXTERNAL FUNCTION @BDOS(PARM,FUNC:INTEGER):INTEGER; - -EXTERNAL [1] PROCEDURE LOGWRITER; (* LOG WRITER OVERLAY *) -EXTERNAL [2] PROCEDURE SPEED; (* EDITOR OVERLAY *) -EXTERNAL [3] PROCEDURE SYNCHECK; (* SYNTAX CHECKER OVERLAY *) -EXTERNAL [4] PROCEDURE VARCHECK; (* UNDEF VAR CHECKER OVERLAY *) -EXTERNAL [6] PROCEDURE MTRUN; (* RUN PROGRAM OVERLAY *) -EXTERNAL [7] PROCEDURE DISP_DIR; (* DIRECTORY DISPLAY OVERLAY *) -EXTERNAL [8] FUNCTION GETFILE:BOOLEAN; (* GET EDITOR FILE NAME, ETC. *) -EXTERNAL [8] PROCEDURE INIT; (* EDITOR INIT *) -EXTERNAL [9] PROCEDURE EDITWRITE; (* EDITOR WRITE BUFFER OVERLAY *) -EXTERNAL[10] PROCEDURE PRETTY; (* PROGRAM REFORMATER *) - - -(*--------------------------------------------------------------*) -(* User modification area BEGINS here: *) -(*--------------------------------------------------------------*) - - -FUNCTION LINESZ : INTEGER; (* SO USER CAN SET SIZE OF A LINE *) -BEGIN - LINESZ := 79 (* 80 - 1 *) -END; - -FUNCTION SCREENSZ : INTEGER; -BEGIN - SCREENSZ := 22 (* NUMBER OF LINES ON PHYSICAL SCREEN - 2 *) -END; - -FUNCTION STATUSROW : INTEGER; -BEGIN - STATUSROW := SCREENSZ + 1 -END; - -PROCEDURE SB_OUT_CH(CH:CHAR); -BEGIN - SB_BIOS_CALL(CONOUT,ORD(CH)) -END; - -FUNCTION SB_GETCH:CHAR; -(* CONVERT MOST WORDSTAR COMMANDS TO SPP EQUIV. FRG-14JUL81 *) -VAR - CH : CHAR; - CHI, CHO : INTEGER; -BEGIN - SB_BIOS_CALL(CONIN,0); - INLINE("STA / CH); - CHI := ORD(CH); - CASE CHI OF {NEW COMMAND OLD FUNCTION} - $04 : CHO := $0C; { D L } - $05 : CHO := $0B; { E K } - $06 : CHO := $04; { F D } - $0A : CHO := $15; { J U } - $0B : CHO := $16; { K V } - $0C : CHO := $18; { L X } - $0F : CHO := $13; { O S } - $10 : CHO := $14; { P T } - $13 : CHO := $08; { S H } - $14 : CHO := $0F; { T O } - $15 : CHO := $17; { U W } - $16 : CHO := $06; { V F } - $17 : CHO := $05; { W E } - $18 : CHO := $0A; { X J } - $1F : CHO := $10; { - P } - ELSE CHO := CHI; - END ; (* CASE *) - SB_GETCH := CHR(CHO) -END; - -PROCEDURE XYGOTO(X,Y:INTEGER); (* PUT CURSOR AT HORZ, VERT *) -BEGIN - SB_OUT_CH(CHR(ESC)); - SB_OUT_CH(CHR('Y')); - SB_OUT_CH(CHR(Y+32)); (* ROW *) - SB_OUT_CH(CHR(X+32)); (* COLUMN *) - SB_LAST_X := X; - SB_LAST_Y := Y; (* THESE ARE USED ONLY BY USER SOFTWARE *) - (* ROUTINES WHICH PERFORM CLR TO EOS AND *) - (* CLR TO EOL *) -END; - -PROCEDURE SB_CLR_SCRN; -BEGIN - SB_OUT_CH(CHR(ESC)); - sb_out_ch(CHR('E')); -END; - -PROCEDURE SB_CLR_EOS; -BEGIN - SB_OUT_CH(CHR(ESC)); - SB_OUT_CH(CHR('J')); - SB_OUT_CH(CHR(0)); (* GIVE IT TIME TO WORK *) - SB_OUT_CH(CHR(0)); (* GIVE IT TIME TO WORK *) -END; - - -PROCEDURE SB_CLR_LINE; -BEGIN - SB_OUT_CH(CHR(ESC)); - SB_OUT_CH(CHR('K')); -END; - - -(*--------------------------------------------------------------*) -(* User modification area ENDS WITH SB_CLR_LINE *) -(*--------------------------------------------------------------*) - - -PROCEDURE SB_FLUSH_BUF; -VAR - CH : CHAR; -BEGIN - IF NOT BUFSTAT.OCCUPIED THEN - EXIT; - - REPEAT - PRNT_AT(20,1,'Buffer occupied'); - PRNT_AT(21,1,'F)lush, U)pdate, W)rite & Flush, L)eave:'); - CH := SB_UP_CASE(SB_GETCH); - SB_OUT_CH(CH); - IF CH = 'L' THEN - EXIT; - - IF CH = 'F' THEN - BEGIN - IF NEWFILE THEN - PURGE(F); - BUFSTAT.OCCUPIED := FALSE; - EXIT - END; - - IF CH = 'W' THEN - BEGIN - EDITWRITE; - LOGWRITER; - BUFSTAT.OCCUPIED := FALSE - END; - - IF CH = 'U' THEN - BEGIN - EDITWRITE; (* BUT LEAVE IT OCCUPIED *) - LOGWRITER - END - UNTIL (CH='U') or (CH='F') OR (CH='W'); - NEWFILE:=FALSE; -END; - - -PROCEDURE SB_BIOS_CALL(FUNC:CPMOPERATION; PARM:INTEGER); -VAR - DISPATCH_LOC : INTEGER; -BEGIN - DISPATCH_LOC := (MEMORY[1] + SWAP(MEMORY[2])) + (ORD(FUNC)*3) - 3; - INLINE("LHLD / PARM / - "MOV C,L / - "MOV B,H / - "LHLD / DISPATCH_LOC / - "PCHL); -END; - -PROCEDURE PRNT_AT(ROW,COL:INTEGER; S:STRING); -BEGIN - XYGOTO(COL,ROW); - WRITE([ADDR(SB_OUT_CH)],S) -END; - -PROCEDURE MENU; -BEGIN - SB_CLR_SCRN; - PRNT_AT(1,1,'SpeedProgramming Package V5.2'); - PRNT_AT(3,1,'Options: E)dit'); - prnt_at(4,20, 'R)eformat'); - prnt_at(5,20, 'S)yntax check'); - prnt_at(6,20, 'V)ariable check'); - prnt_at(7,20, 'X)eq'); - prnt_at(8,20, 'D)ir'); - prnt_at( 9,20, 'L)ink'); - prnt_at(10,20, 'F)ast compile'); - prnt_at(11,20, 'Q)uit'); - prnt_at(22,1,'Command? ') -END; - -FUNCTION SB_UP_CASE(CH:CHAR):CHAR; -BEGIN - IF (CH >= 'a') AND (CH <= 'z') THEN - SB_UP_CASE := CHR(CH & $DF) - ELSE - SB_UP_CASE := CH -END; - - -(*$E-*) -FUNCTION GET_FILE_INTO_BUF:BOOLEAN; -BEGIN - IF NOT BUFSTAT.OCCUPIED THEN - IF GETFILE THEN (* GET FILE INTO BUFFER *) - INIT; - GET_FILE_INTO_BUF := BUFSTAT.OCCUPIED -END; -(*$E+*) - - - -BEGIN - BUFSZ := (@SFP - ADDR(BUF))-$100; (* SET UP EDITOR BUFFER SIZE *) - BUFSTAT.OCCUPIED := FALSE; - NEWFILE := FALSE; - REPEAT - MENU; - INTRFACE.NEXT_CMD := ' '; (* DEFAULT NO NEXT PROGRAM *) - INTRFACE.END_STAT := OK; - CMDCH := SB_UP_CASE(SB_GETCH); - SB_OUT_CH(CMDCH); (* ECHO IT *) - REPEAT - FSTRING := ''; (* DEFAULT IS NO PROGRAM *) - CASE CMDCH OF - 'D' : DISP_DIR; - 'E' : BEGIN - IF (BUFSTAT.OCCUPIED) AND ((INTRFACE.PREV_CMD = 'S') - OR (INTRFACE.PREV_CMD = 'R'))THEN - (* DO NOTHING *) - ELSE - SB_FLUSH_BUF; (* MAKE SURE USER WANTS TO DO THIS *) - - IF NOT BUFSTAT.OCCUPIED THEN (* BUFFER IS EMPTY *) - BEGIN - IF GETFILE THEN (* SEE IF HE WANTS A FILE *) - BEGIN - INIT; (* CALL EDITOR *) - IF BUFSTAT.OCCUPIED THEN - SPEED - END - END - ELSE - SPEED; (* BUFFER OCCUPIED, EDIT OLD *) - INTRFACE.PREV_CMD := ' '; - IF INTRFACE.NEXT_CMD = 'E' THEN - INTRFACE.NEXT_CMD := ' '; - END; - 'S' : BEGIN - IF GET_FILE_INTO_BUF THEN - BEGIN - INTRFACE.PREV_CMD := ' '; - SYNCHECK; - IF INTRFACE.END_STAT = SYNERR THEN - INTRFACE.NEXT_CMD := 'E' - END - END; - 'V' : IF GET_FILE_INTO_BUF THEN - VARCHECK; - 'R' : BEGIN - IF GET_FILE_INTO_BUF THEN - BEGIN - INTRFACE.PREV_CMD := 'R'; - PRETTY; - INTRFACE.NEXT_CMD := 'E'; - SB_CLR_SCRN - END - END; - 'X' : BEGIN - SB_FLUSH_BUF; - FSTRING := ''; - MTRUN - END; - 'Q' : BEGIN - INTRFACE.PREV_CMD := ' '; - SB_FLUSH_BUF; - IF BUFSTAT.OCCUPIED THEN - CMDCH := '@' - ELSE - BEGIN - SB_CLR_SCRN; - EXIT - END - END; - 'L' : BEGIN - SB_FLUSH_BUF; - FSTRING := 'LINKMT'; - MTRUN - END; - 'F' : BEGIN - IF GET_FILE_INTO_BUF THEN - BEGIN - SB_FLUSH_BUF; - FSTRING := 'FASTCOMP'; - MOVE(ENDFILE,MEMORY[ADDR(BUF)-2],2);(* SET UP INTEGER *) - MOVE(NAME,MEMORY[ADDR(BUF)-83],81); - MTRUN - END - END - END; - CMDCH := INTRFACE.NEXT_CMD; - UNTIL (CMDCH = ' ') OR (CMDCH = INTRFACE.PREV_CMD); - UNTIL FALSE -END. - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/PAGE.COM b/software/CPM/CPM13_MTPUG_01/PAGE.COM deleted file mode 100644 index 6d31b1d..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/PAGE.COM and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/PAGE.DOC b/software/CPM/CPM13_MTPUG_01/PAGE.DOC deleted file mode 100644 index ecec855..0000000 --- a/software/CPM/CPM13_MTPUG_01/PAGE.DOC +++ /dev/null @@ -1,14 +0,0 @@ - - The command 'PAGE ' causes a file to be displayed a-page-at- - a-time on the console. At the end of every 23 rd line, PAGE will print - the prompt 'MORE...' at the bottom corner of the screen, any response - except ESC, ^Q, ^C, ^X, ^Z, 'Q', 'q', 's', 'S', 'N', or 'n' will - abort the program. - - WARNING: PAGE uses character 1A hex to clear the screen, and assumes - an 80-by-24 screen. - - PAGE was written in PASCAL/MT by T. W. Lougeed and is in the public - domain. - - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/PAGE.PAS b/software/CPM/CPM13_MTPUG_01/PAGE.PAS deleted file mode 100644 index a46a5f0..0000000 --- a/software/CPM/CPM13_MTPUG_01/PAGE.PAS +++ /dev/null @@ -1,172 +0,0 @@ -PROGRAM PAGE10; - -{ This program is a CP/M utility for use with an 80 by 24 CRT. -It types out a page at a time to the screen. - -First version 1 August 1980 - -By T. W. Lougheed - Dept. of T. & A. Mechanics - Thurston Hall, Cornell U. - Ithaca, NY 14853 - - home phone 272-4993 - -Last version 10 February 1981 } - - -CONST HEIGHT = 24; { Dimensions of the screen in real characters. } - WIDTH = 80; - - { ASCII controll-codes. } - - EOF = $1A; { CP/M End-of-file marker: ^Z. } - BRK = $10; { Data-link escape: break: ^P. } - ESC = $1B; { Escape. } - NAK = $15; { Negative acknowledge: ^U. } - CAN = $18; { Cancel: ^X. } - BS = $08; { Backspace: ^H. } - TAB = $09; { Horizontal tab: ^I. } - CR = $0D; { Caraige-return: ^M. } - LF = $0A; { Linefeed: ^J. } - VT = $0B; { Vertical tab: ^K. } - FF = $0C; { Formfeed: ^L. } - DEL = $7F; { Rubout. } - -VAR C, D : CHAR; - K, L : INTEGER; - { Count of characters and lines for paging. } - { K = last character written on current line, L = current line. } - CANCELED : BOOLEAN; - { Flag used to stop looping. } - FNAME : STRING[127]; - { The name of the source file. } - SOURCE : FILE OF PACKED ARRAY [1..4096] OF CHAR; - { Note: NOT A TEXT-FILE! This means no meddling by PASCAL with - the data from the file. We will read from the file using the - procedure GNB (Get Next Byte) supplied with PASCAL/MT. - Given the array-limits 1..4096 it reads 32 records at a time, - which causes less rattle on the drives than one record at a time. } - COMMANDS, - POSITIVE, - NEGATIVE : SET OF CHAR; - { Types of responses to the "... more " prompt. } - - - - -{ Inserts into FNAME the data in the CP/M command buffer at $0080. } - -PROCEDURE CPM_COMMAND_LINE; - VAR BUFFER : ABSOLUTE[ $0080 ] PACKED ARRAY[0..127] OF CHAR; - BEGIN - MOVE( BUFFER, FNAME, 127 ); - END; - -{ Erases the screen for an IMSAI VIO board. } - -PROCEDURE CLEAR; - BEGIN WRITE( CHR(EOF) ); END; - - - -BEGIN { PAGE } - -POSITIVE := [ ' ', 'y', 'Y', 'g', 'G', 'c', 'C', CHR(CR), CHR(LF) ]; -NEGATIVE := [ 'q', 'Q', 'n', 'N', 'e', 'E', 'x', 'X', - CHR(CAN), CHR(NAK), CHR(EOF), CHR(ESC), CHR(BRK) ]; -COMMANDS := POSITIVE + NEGATIVE; - -{ Get the file name from the buffer. } -CPM_COMMAND_LINE; - -REPEAT - { If none available, then ask for one. } - IF (LENGTH( FNAME ) = 0) OR (FNAME = ' ') THEN - REPEAT WRITE( 'File ? ' ); READ( FNAME ) UNTIL LENGTH( FNAME ) > 0; - { Open the source file. K <> 255 if everything's okay. } - OPEN( SOURCE, FNAME, K ); - IF K >= 249 THEN BEGIN - WRITE( 'Unable to open file "', FNAME, - '", BDOS error ', K:3, '. Quit ? ' ); - READ( D ); WRITELN; - IF D IN [ 'q', 'Q', 'y', 'Y', 'e', 'E' ] THEN EXIT; - FNAME := ''; - END; - UNTIL K < 249; - - -{ Cosmetics. } -CLEAR; -WRITELN( '------------------------------------------------------------------', - '-------------' ); - - - -{ Preparation for paging loop. } - -C := GNB( SOURCE ); K := 0; { Character last printed (LF). } -CANCELED := FALSE; L := 2; { Line currently on. } - - -{ Central loop. } - -REPEAT - - { Choose what to do with the character. } - - CASE ORD(C) OF - LF : BEGIN K := 0; L := L + 1 END; - TAB : BEGIN - IF K < 71 { If it will fit on this line. } - THEN REPEAT - WRITE( ' ' ); K := K + 1; - UNTIL (K > 1) AND ((K-1) MOD 8 = 0) - ELSE BEGIN WRITELN; L := L + 1; K := 0 END; - END; - FF, VT : - WHILE L < HEIGHT - 1 DO BEGIN WRITELN; L := L + 1 END; - ELSE IF K < WIDTH THEN BEGIN WRITE( C ); K := K + 1 END - ELSE WRITE( CHR(BS), C ); { No scroll-over. } - END; - - - { When the following is indeed true, one presumably is at the beginning - of the last line on the screen. } - - IF L + 1 >= HEIGHT THEN BEGIN - - WRITE( CHR(CR), ' ':69, '... more ' ); READ( D ); - - WHILE NOT (D IN COMMANDS) OR (D = '?') DO BEGIN - WRITELN; - WRITELN( 'To continue paging, type a blank or .' ); - WRITELN( 'To stop paging type "N", "Q", "X", ^X, ^U,', - ' , or .' ); - WRITE( ' ':70, '... more ' ); READ( D ); - END; - - CANCELED := D IN NEGATIVE; - - IF NOT CANCELED THEN BEGIN - CLEAR; - L := 1; { Which puts the cursor back at the top. } - END; - - END; - - - C := GNB( SOURCE ); - UNTIL (C = CHR(EOF)) OR CANCELED; - -{ Cosmetic sign-off. } -WRITELN( '-----------------------------------------------------------------', - '--------------' ); -WRITELN( 'PAGE version 10 file "', - FNAME, '"' ); -WRITELN; - -END { PAGE } -. - - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/PLOT.BAK b/software/CPM/CPM13_MTPUG_01/PLOT.BAK deleted file mode 100644 index d5aa4f2..0000000 --- a/software/CPM/CPM13_MTPUG_01/PLOT.BAK +++ /dev/null @@ -1,315 +0,0 @@ -{ The following program plots dots on the screen, putting an X -and Y axis on the screen and scaling automaticly, when not well -instructed, to fit all the points on the screen with the given -constraint of the number of rows and columns allowed. } - -MODULE PLOT15; - -CONST ROWS = 23; { Previously passed as paramiters. } - COLS = 80; - -TYPE POINT = RECORD X, Y :REAL END; - - -{ This procedure plots an X,Y graph of the given DATA on the whole -screen, plotting its own axis grid. All management of the screen takes -place here. } - -PROCEDURE PLOT ( - L : INTEGER; { Number of points to plot. } - VAR DATA : ARRAY[ M..N :INTEGER ] OF POINT; { Stuff to plot; conformant - array; "VAR" simply to avoid passing excessive paramiters. } - ORIGIN : POINT; { Location of origin -- if out-of-bounds it is - set to lie at the upper corner of the screen. } - X_MIN, - X_MAX, { Bounds for X & Y values. If MAX <= MIN then .. } - Y_MIN, { .. scaling is done automaticly for that axis. } - Y_MAX : REAL - ); - - -VAR C : CHAR; { Dummy input. } - I, J, K : INTEGER; { Dummy indicies. } - ORIGINAL : BYTE; { Remember the VIO mode on entry. } - QUIT : BOOLEAN; { "Bad input" flag. } - SCREEN : ABSOLUTE[ $F000 ] ARRAY[ 1..24, 1..80 ] OF BYTE; - { Direct access to screen image. } - SX, { Scaling ration for X values. } - SY : REAL; { Scaling constant for Y values. } - VIO_CONTROLL : ABSOLUTE[ $F7FF ] BYTE; - { VIO board controll byte. } - - -{ This procedure checks for the paramiters. } - -PROCEDURE CHECKOUT; - VAR K : INTEGER; - BEGIN - - QUIT := FALSE; { Assume all is Okay until told otherwise. } - - { Do not allow more than the maximum number of points. } - IF M >= N THEN BEGIN - WRITELN; - WRITELN( 'Problem in procedure PLOT: indexes are backwards: ', - N:4, ' - ', M:4, ' is not positive.' ); - WRITELN( 'Be advised to check the paramiters in the procedure call.' ); - QUIT := TRUE; - END; - - { Be sure not to over-run the end of DATA. } - IF L > N - M THEN BEGIN - WRITELN; - WRITELN( 'Problem in procedure PLOT: the number of points ', L:5, - ' is larger than the allowed number ', N:5, '-', M:5, '.' ); - WRITELN( 'Be advised to check the paramiters in the procedure call.' ); - QUIT := TRUE; - END; - - IF QUIT THEN BEGIN WRITELN( 'Quitting PLOT.' ); EXIT END; - - - { The preceding errors were "fatal" the following are recoverable. } - - - { If a propper X_MAX, X_MIN pair is not provided, get one. } - - IF X_MIN >= X_MAX THEN BEGIN - DATA[M].X := X_MAX; X_MIN := X_MAX; - FOR K := M + 1 TO M + L - 1 DO WITH DATA[ K ] DO - IF X > X_MAX THEN X_MAX := X - ELSE IF X < X_MIN THEN X_MIN := X; - END; - - IF X_MIN = X_MAX THEN BEGIN { If correction fails. } - WRITELN; - WRITELN( 'Note well: upper and lower bounds for X are identical (', - X_MIN, ' ).' ); - X_MIN := X_MIN - 1; X_MAX := X_MAX + 1; - END; - - - { Make sure origin is correctly defined on the X axis. } - - IF NOT( (X_MIN <= ORIGIN.X) AND (ORIGIN.X <= X_MAX) ) - THEN IF (X_MIN <= 0) AND (0 <= X_MAX) THEN ORIGIN.X := 0 - ELSE ORIGIN.X := X_MIN; { Defaults to upper corner. } - - - { If a propper Y_MIN, Y_MAX pair is not provided, get one. } - - IF Y_MIN >= Y_MAX THEN BEGIN - DATA[M].Y := Y_MAX; Y_MIN := Y_MAX; - FOR K := M + 1 TO M + L - 1 DO WITH DATA[ K ] DO - IF Y > Y_MAX THEN Y_MAX := Y - ELSE IF Y < Y_MIN THEN Y_MIN := Y; - END; - - IF Y_MIN = Y_MAX THEN BEGIN { If correction fails. } - WRITELN; - WRITELN( 'Note well: upper and lower limits for Y are identical (', - Y_MIN, ').' ); - Y_MIN := Y_MIN - 1; Y_MAX := Y_MAX + 1; - END; - - - { Likewise make sure the origin's Y-co-ordinate is sensible. } - - IF NOT( (Y_MIN <= ORIGIN.Y) AND (ORIGIN.Y <= Y_MAX) ) - THEN IF (Y_MIN <= 0) AND (0 <= Y_MAX) THEN ORIGIN.Y := 0 - ELSE ORIGIN.Y := Y_MIN; { Defaults to upper corner. } - - - END; { of CHECKOUT } - - - -{ This procedure erases the screen. } - -PROCEDURE CLEAR; - { Writing a controll-Z causes the VIO firmware to clear the screen, - as long as the VIO board is in the TEXT or EXTENDED text mode. } - BEGIN WRITE( CHR($1A) ) END; - - -{ This procedure sets the screen to full graphics mode (graphics and text, -but no reverse-video characters. } - -PROCEDURE GRAPHICS_MODE; - CONST ESC = $1B; { The ASCII character code. } - BEGIN - CLEAR; { Start with a clean slate. } - { Prepare for restoration made at exit of the enclosing procedure. } - ORIGINAL := VIO_CONTROLL; { Memorize the original VIO mode setting. } - { The VIO firmware will put the screen into the mode upon recieving - the " 'G' " sequence. The primary benefit of not going directly - to the VIO-port is to get the fuzzy cursor turned on. } - WRITE( CHR(ESC), 'G' ); - END; - - - -{ The following procedure returns the screen to the mode it was in -when the program entered. Note that this procedure requires the -procedure GRAPHICS_MODE to have been called previously to work -propperly, though it will, probably, default to good options anyway. } - -PROCEDURE RESTORE_MODE; - CONST ESC = $1B; { The ASCII character code. } - BEGIN - { On entry, one is in POSITIVE video mode, MODE III set on, - and a 24 lines by 80 column screen. To what extent this was - not the case in the original it is reset. } - - { Restore number of columns if needed. } - IF (ORIGINAL & $01) <> 0 THEN WRITE( CHR(ESC), 'C' ); - { Restore number of rows if needed. } - IF (ORIGINAL & $02) <> 0 THEN WRITE( CHR(ESC), 'L' ); - { Restore mode if not set propperly. } - CASE ORIGINAL & $0C OF - $00, { Null mode, which is undesirable, defaults to TEXT. } - $08 : WRITE( CHR(ESC), 'T' ); { TEXT mode -- chrs $20..$7F } - $04 : WRITE( CHR(ESC), 'E' ); { EXTENDED mode -- chrs $A0..$FF } - $0C :; { For completeness -- GRAPHICS mode with full text. } - END; { of CASE } - { Turn on reverse video if thats the way it was. } - IF (ORIGINAL & $10) <> 0 THEN WRITE( CHR(ESC), 'V' ); - CLEAR; { Be neat and leave a blank screen. } - - END; - - - -{ The following uses an "Escape Sequence" to position the cursor. -An escape sequence is part of the VIO firmware, and an explanation -can be found in the "IMSAI VDP-80 Referance Manual" section III, -page 43 ("the addressable cursor"). } - -PROCEDURE CURSOR( ROW, COLUMN :INTEGER); - CONST OFFSET = $1F; { The VIO software offsets all addresses. } - ESC = $1B; { The ASCII character code. } - VAR A, B : CHAR; - BEGIN - A := CHR( OFFSET + ROW ); - B := CHR( OFFSET + COLUMN ); - { The '=' character signals a relocation of the cursor. } - WRITE( CHR(ESC), '=', A, B ); - END; - - - -{ This procedure draws a pair of axes with origin at row I column J. } - -PROCEDURE AXES( I, J :INTEGER ); - VAR K, L :INTEGER; { Dummy index. } - BEGIN - - { Idiot proofing upon idiot proofing. } - IF I > ROWS THEN I := ROWS ELSE IF I < 1 THEN I := 1; - IF J > COLS THEN J := COLS ELSE IF J < 1 THEN J := 1; - - { Prepare the screen. } - CURSOR( 24, 1 ); { Get the cursor out of the way. } - { For some reason, a stray dot occasionally remains on the screen on - the top row. We expurgate it by directly putting blanks on the - whole screen. } - FOR K := 1 TO COLS DO FOR L := 1 TO ROWS DO SCREEN[ L, K ] := ' '; - - { Make ordinate (Y axis). } - { Note that it runs horizontally, contrary to custom. } - FOR K := 1 TO COLS-1 DO IF (K - J) MOD 6 = 0 { One tick every 12 dots. } - THEN SCREEN[ I, K ] := CHR( $CB ) { Ticked bar 'T'. } - ELSE SCREEN[ I, K ] := CHR( $CA ); { Plain dash '-' . } - SCREEN[ I, COLS ] := 'y'; { Label axis. } - - { Make abscissa (X-axis). } - { Note that it runs vertically, also uncustomary. } - FOR K := 1 TO ROWS-1 DO IF (K - I) MOD 3 = 0 { One tick every 9 dots. } - THEN SCREEN[ K, J ] := CHR( $CD ) { Ticked line 'L'. } - ELSE SCREEN[ K, J ] := CHR( $C5 ); { Plain, vertical line '|'. } - SCREEN[ ROWS, J ] := 'x'; { Label axis. } - - { Put in origin. } - SCREEN[ I, J ] := CHR( $CF ); { A '+' sign. } - - END; { AXES } - - - -{ This procedure places a dot in the appropriate position on the -screen, using the character-block plotting set. The co-ordinates -of the dot are expected to be 1 <= I <= 72, 1 <= J <= 160. } - -PROCEDURE PLACE_DOT ( I, J :INTEGER ); - - VAR BIT, { Block in cell to be plotted. } - K, L, { Character cell to be plotted in. } - CELL : INTEGER; { Order of character on the screen. } - - BEGIN - - { If the dot is off screen, then plot it on the margin. } - IF I < 1 THEN I := 1 ELSE IF I > 3*ROWS THEN I := 3*ROWS; - IF J < 1 THEN J := 1 ELSE IF J > 2*COLS THEN J := 2*COLS; - - { Co-ordinates of the dot's cell on the screen. } - K := (I - 1) DIV 3 + 1; L := (J - 1) DIV 2 + 1; - - { Cell now becomes the contents of the memory. } - CELL := ORD( SCREEN[ K, L ] ); - - { If not a block character, set to a blank block. } - IF (CELL < $80) OR ($BF < CELL) THEN CELL := $80; - - { Add the bit of the desired dot to the existing block pattern. } - BIT := 5 - (I - 1) MOD 3 - 3*((J - 1) MOD 2); - SETBIT( CELL, BIT ); - - { Install the revised pattern on the screen. } - SCREEN[ K, L ] := CHR( CELL ); - - END; { of POINT } - - -BEGIN - - { Make sure all the paramiters make sense. } -CHECKOUT; IF QUIT THEN EXIT; - - { Turn on VIO board's full-set mode (includes both graphics & letters). } -GRAPHICS_MODE; - - -{ Make the axes. } - -I := 1 + ROUND( (ROWS - 1)*(ORIGIN.X - X_MIN)/(X_MAX - X_MIN) ); -J := 1 + ROUND( (COLS - 1)*(ORIGIN.Y - Y_MIN)/(Y_MAX - Y_MIN) ); -AXES( I, J ); { Plot co-ordinate lines. } - - -{ Plotting. } - - { Scale factors. } -SX := (3*ROWS - 1)/(X_MAX - X_MIN); -SY := (2*COLS - 1)/(Y_MAX - Y_MIN); - - { Note that if a point is out-of-bounds, it will be -placed on the appropriate margin without comment. } -FOR K := M TO L+M-1 DO WITH DATA[ K ] DO - PLACE_DOT( ROUND( SX*(X - X_MIN) ) + 1, ROUND( SY*(Y - Y_MIN) ) + 1 ); - - -{ Postlude. } - -CURSOR( 24, 1 ); -WRITE( 'dx =', 9/SX, ' dy =', 12/SY, - ' Hit any key when done looking. ' ); - { When input is recieved, return VIO to mode when entered. } -READ( C ); -RESTORE_MODE; - -END; { of PLOT } - -MODEND. - - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/PLOT.MOD b/software/CPM/CPM13_MTPUG_01/PLOT.MOD deleted file mode 100644 index f8dca6d..0000000 --- a/software/CPM/CPM13_MTPUG_01/PLOT.MOD +++ /dev/null @@ -1,331 +0,0 @@ -{ Copyright (c) by T. W. Lougheed 24 April 1981 } - -{ The following program plots dots on the screen, putting an X -and Y axis on the screen and scaling automaticly, when not well -instructed, to fit all the points on the screen with the given -constraint of the number of rows and columns allowed. } - - -{ First version 15 September 1981 - - By T. W. Lougheed - Dept. T. & A. Mechanics - Thurston Hall, Cornell U. - Ithaca, NY 14853 - - Last version 24 April 1981 } - -{ This program is in the public domain and may not be sold by any -person or corperation without express permission of the author. } - - -MODULE PLOT15; - -CONST ROWS = 23; { Dimensions of the screen. } - COLS = 80; - -TYPE POINT = RECORD X, Y :REAL END; - - -{ This procedure plots an X,Y graph of the given DATA on the whole -screen, plotting its own axis grid. All management of the screen takes -place here. } - -PROCEDURE PLOT ( - L : INTEGER; { Number of points to plot. } - VAR DATA : ARRAY[ M..N :INTEGER ] OF POINT; { Stuff to plot; conformant - array; "VAR" simply to avoid passing excessive paramiters. } - ORIGIN : POINT; { Location of origin -- if out-of-bounds it is - set to lie at the upper corner of the screen. } - X_MIN, - X_MAX, { Bounds for X & Y values. If MAX <= MIN then .. } - Y_MIN, { .. scaling is done automaticly for that axis. } - Y_MAX : REAL - ); - - -VAR C : CHAR; { Dummy input. } - I, J, K : INTEGER; { Dummy indicies. } - ORIGINAL : BYTE; { Remember the VIO mode on entry. } - QUIT : BOOLEAN; { "Bad input" flag. } - SCREEN : ABSOLUTE[ $F000 ] ARRAY[ 1..24, 1..80 ] OF BYTE; - { Direct access to screen image. } - SX, { Scaling ration for X values. } - SY : REAL; { Scaling constant for Y values. } - VIO_CONTROLL : ABSOLUTE[ $F7FF ] BYTE; - { VIO board controll byte. } - - -{ This procedure checks for the paramiters. } - -PROCEDURE CHECKOUT; - VAR K : INTEGER; - BEGIN - - QUIT := FALSE; { Assume all is Okay until told otherwise. } - - { Do not allow more than the maximum number of points. } - IF M >= N THEN BEGIN - WRITELN; - WRITELN( 'Problem in procedure PLOT: indexes are backwards: ', - N:4, ' - ', M:4, ' is not positive.' ); - WRITELN( 'Be advised to check the paramiters in the procedure call.' ); - QUIT := TRUE; - END; - - { Be sure not to over-run the end of DATA. } - IF L - 1 > N - M THEN BEGIN - WRITELN; - WRITELN( 'Problem in procedure PLOT: the number of points ', L:5, - ' is larger than the allowed number ', N:5, '-', M:5, '+1.' ); - WRITELN( 'Be advised to check the paramiters in the procedure call.' ); - QUIT := TRUE; - END; - - IF QUIT THEN BEGIN WRITELN( 'Quitting PLOT.' ); EXIT END; - - - { The preceding errors were "fatal" the following are recoverable. } - - - { If a propper X_MAX, X_MIN pair is not provided, get one. } - - IF X_MIN >= X_MAX THEN BEGIN - DATA[M].X := X_MAX; X_MIN := X_MAX; - FOR K := M + 1 TO M + L - 1 DO WITH DATA[ K ] DO - IF X > X_MAX THEN X_MAX := X - ELSE IF X < X_MIN THEN X_MIN := X; - END; - - IF X_MIN = X_MAX THEN BEGIN { If correction fails. } - WRITELN; - WRITELN( 'Note well: upper and lower bounds for X are identical (', - X_MIN, ' ).' ); - X_MIN := X_MIN - 1; X_MAX := X_MAX + 1; - END; - - - { Make sure origin is correctly defined on the X axis. } - - IF NOT( (X_MIN <= ORIGIN.X) AND (ORIGIN.X <= X_MAX) ) - THEN IF (X_MIN <= 0) AND (0 <= X_MAX) THEN ORIGIN.X := 0 - ELSE ORIGIN.X := X_MIN; { Defaults to upper corner. } - - - { If a propper Y_MIN, Y_MAX pair is not provided, get one. } - - IF Y_MIN >= Y_MAX THEN BEGIN - DATA[M].Y := Y_MAX; Y_MIN := Y_MAX; - FOR K := M + 1 TO M + L - 1 DO WITH DATA[ K ] DO - IF Y > Y_MAX THEN Y_MAX := Y - ELSE IF Y < Y_MIN THEN Y_MIN := Y; - END; - - IF Y_MIN = Y_MAX THEN BEGIN { If correction fails. } - WRITELN; - WRITELN( 'Note well: upper and lower limits for Y are identical (', - Y_MIN, ').' ); - Y_MIN := Y_MIN - 1; Y_MAX := Y_MAX + 1; - END; - - - { Likewise make sure the origin's Y-co-ordinate is sensible. } - - IF NOT( (Y_MIN <= ORIGIN.Y) AND (ORIGIN.Y <= Y_MAX) ) - THEN IF (Y_MIN <= 0) AND (0 <= Y_MAX) THEN ORIGIN.Y := 0 - ELSE ORIGIN.Y := Y_MIN; { Defaults to upper corner. } - - - END; { of CHECKOUT } - - - -{ This procedure erases the screen. } - -PROCEDURE CLEAR; - { Writing a controll-Z causes the VIO firmware to clear the screen, - as long as the VIO board is in the TEXT or EXTENDED text mode. } - BEGIN WRITE( CHR($1A) ) END; - - -{ This procedure sets the screen to full graphics mode (graphics and text, -but no reverse-video characters. } - -PROCEDURE GRAPHICS_MODE; - CONST ESC = $1B; { The ASCII character code. } - BEGIN - CLEAR; { Start with a clean slate. } - { Prepare for restoration made at exit of the enclosing procedure. } - ORIGINAL := VIO_CONTROLL; { Memorize the original VIO mode setting. } - { The VIO firmware will put the screen into the mode upon recieving - the " 'G' " sequence. The primary benefit of not going directly - to the VIO-port is to get the fuzzy cursor turned on. } - WRITE( CHR(ESC), 'G' ); - END; - - - -{ The following procedure returns the screen to the mode it was in -when the program entered. Note that this procedure requires the -procedure GRAPHICS_MODE to have been called previously to work -propperly, though it will, probably, default to good options anyway. } - -PROCEDURE RESTORE_MODE; - CONST ESC = $1B; { The ASCII character code. } - BEGIN - { On entry, one is in POSITIVE video mode, MODE III set on, - and a 24 lines by 80 column screen. To what extent this was - not the case in the original it is reset. } - - { Restore number of columns if needed. } - IF (ORIGINAL & $01) <> 0 THEN WRITE( CHR(ESC), 'C' ); - { Restore number of rows if needed. } - IF (ORIGINAL & $02) <> 0 THEN WRITE( CHR(ESC), 'L' ); - { Restore mode if not set propperly. } - CASE ORIGINAL & $0C OF - $00, { Null mode, which is undesirable, defaults to TEXT. } - $08 : WRITE( CHR(ESC), 'T' ); { TEXT mode -- chrs $20..$7F } - $04 : WRITE( CHR(ESC), 'E' ); { EXTENDED mode -- chrs $A0..$FF } - $0C :; { For completeness -- GRAPHICS mode with full text. } - END; { of CASE } - { Turn on reverse video if that's the way it was. } - IF (ORIGINAL & $10) <> 0 THEN WRITE( CHR(ESC), 'V' ); - CLEAR; { Be neat and leave a blank screen. } - - END; - - - -{ The following uses an "Escape Sequence" to position the cursor. -An escape sequence is part of the VIO firmware, and an explanation -can be found in the "IMSAI VDP-80 Referance Manual" section III, -page 43 ("the addressable cursor"). } - -PROCEDURE CURSOR( ROW, COLUMN :INTEGER); - CONST OFFSET = $1F; { The VIO software offsets all addresses. } - ESC = $1B; { The ASCII character code. } - VAR A, B : CHAR; - BEGIN - A := CHR( OFFSET + ROW ); - B := CHR( OFFSET + COLUMN ); - { The '=' character signals a relocation of the cursor. } - WRITE( CHR(ESC), '=', A, B ); - END; - - - -{ This procedure draws a pair of axes with origin at row I column J. } - -PROCEDURE AXES( I, J :INTEGER ); - VAR K, L :INTEGER; { Dummy index. } - BEGIN - - { Idiot proofing upon idiot proofing. } - IF I > ROWS THEN I := ROWS ELSE IF I < 1 THEN I := 1; - IF J > COLS THEN J := COLS ELSE IF J < 1 THEN J := 1; - - { Prepare the screen. } - CURSOR( 24, 1 ); { Get the cursor out of the way. } - { For some reason, a stray dot occasionally remains on the screen on - the top row. We expurgate it by directly putting blanks on the - whole screen. } - FOR K := 1 TO COLS DO FOR L := 1 TO ROWS DO SCREEN[ L, K ] := ' '; - - { Make ordinate (Y axis). } - { Note that it runs horizontally, contrary to custom. } - FOR K := 1 TO COLS-1 DO IF (K - J) MOD 6 = 0 { One tick every 12 dots. } - THEN SCREEN[ I, K ] := CHR( $CB ) { Ticked bar 'T'. } - ELSE SCREEN[ I, K ] := CHR( $CA ); { Plain dash '-' . } - SCREEN[ I, COLS ] := 'y'; { Label axis. } - - { Make abscissa (X-axis). } - { Note that it runs vertically, also uncustomary. } - FOR K := 1 TO ROWS-1 DO IF (K - I) MOD 3 = 0 { One tick every 9 dots. } - THEN SCREEN[ K, J ] := CHR( $CD ) { Ticked line 'L'. } - ELSE SCREEN[ K, J ] := CHR( $C5 ); { Plain, vertical line '|'. } - SCREEN[ ROWS, J ] := 'x'; { Label axis. } - - { Put in origin. } - SCREEN[ I, J ] := CHR( $CF ); { A '+' sign. } - - END; { AXES } - - - -{ This procedure places a dot in the appropriate position on the -screen, using the character-block plotting set. The co-ordinates -of the dot are expected to be 1 <= I <= 72, 1 <= J <= 160. } - -PROCEDURE PLACE_DOT ( I, J :INTEGER ); - - VAR BIT, { Block in cell to be plotted. } - K, L, { Character cell to be plotted in. } - CELL : INTEGER; { Order of character on the screen. } - - BEGIN - - { If the dot is off screen, then plot it on the margin. } - IF I < 1 THEN I := 1 ELSE IF I > 3*ROWS THEN I := 3*ROWS; - IF J < 1 THEN J := 1 ELSE IF J > 2*COLS THEN J := 2*COLS; - - { Co-ordinates of the dot's cell on the screen. } - K := (I - 1) DIV 3 + 1; L := (J - 1) DIV 2 + 1; - - { Cell now becomes the contents of the memory. } - CELL := ORD( SCREEN[ K, L ] ); - - { If not a block character, set to a blank block. } - IF (CELL < $80) OR ($BF < CELL) THEN CELL := $80; - - { Add the bit of the desired dot to the existing block pattern. } - BIT := 5 - (I - 1) MOD 3 - 3*((J - 1) MOD 2); - SETBIT( CELL, BIT ); - - { Install the revised pattern on the screen. } - SCREEN[ K, L ] := CHR( CELL ); - - END; { of POINT } - - -BEGIN - -{ Make sure all the paramiters make sense. } -CHECKOUT; IF QUIT THEN EXIT; - -{ Turn on VIO board's full-set mode (includes both graphics & letters). } -GRAPHICS_MODE; - - -{ Make the axes. } - -I := 1 + ROUND( (ROWS - 1)*(ORIGIN.X - X_MIN)/(X_MAX - X_MIN) ); -J := 1 + ROUND( (COLS - 1)*(ORIGIN.Y - Y_MIN)/(Y_MAX - Y_MIN) ); -AXES( I, J ); { Plot co-ordinate lines. } - - -{ Plotting. } - -{ Scale factors. } -SX := (3*ROWS - 1)/(X_MAX - X_MIN); -SY := (2*COLS - 1)/(Y_MAX - Y_MIN); - -{ Note that if a point is out-of-bounds, it will be -placed on the appropriate margin without comment. } -FOR K := M TO L+M-1 DO WITH DATA[ K ] DO - PLACE_DOT( ROUND( SX*(X - X_MIN) ) + 1, ROUND( SY*(Y - Y_MIN) ) + 1 ); - - -{ Postlude. } - -CURSOR( 24, 1 ); -WRITE( 'dx =', 9/SX, ' dy =', 12/SY, - ' Hit any key when done looking...' ); -{ When input is recieved, return VIO to mode when entered. } -READ( C ); -RESTORE_MODE; - -END; { of PLOT } - -MODEND. - - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/RANDOM.REL b/software/CPM/CPM13_MTPUG_01/RANDOM.REL deleted file mode 100644 index 671a62b..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/RANDOM.REL and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/RANDOM.SRC b/software/CPM/CPM13_MTPUG_01/RANDOM.SRC deleted file mode 100644 index cd4a9aa..0000000 --- a/software/CPM/CPM13_MTPUG_01/RANDOM.SRC +++ /dev/null @@ -1,181 +0,0 @@ -;================================================== -; PROGRAM TITLE: Random Number Generator -; -; WRITTEN BY: Raymond E. Penley -; DATE WRITTEN: 27 June 1980 -; -; WRITTEN FOR: Pascal/Z Users Group -; -; SUMMARY: -; Implements a Fibonacci series Random number generator. -; RANDOM will return numbers from 0 to x -; -; Call as Returns -; ------- ------------ -; real := RANDOM(10); 0.0 to 10.0 -; real := RANDOM(112); 0.0 to 112.0 -; I := TRUNC(RANDOM(10)); 0 to 10 -; -; ** -; Add these lines to your PASCAL source program: -; -; Procedure SEEDRAND; EXTERNAL; -; Functin RANDOM(X: Integer): REAL; external; -; -; Also within the body of the main program -; but BEFORE calling RANDOM(X); -; -; SEEDRAND; -; -;*** What would happen if you did not call SEEDRAND ? *** -; -;=============================================== -; -; PROCEDURE SEEDRAND; -; (* INITIAL VALUES FOR SEED1 AND SEED2 ARE HERE *) -; - NAME RANDOM - ENTRY SEEDRAND,RANDOM -; -SEEDRAND: - ENTR D,2,0 -; SEED1 := 10946; - MVI 0(IY),42 - MVI -1(IY),194 -; SEED2 := 17711 -; END; - MVI -2(IY),69 - MVI -3(IY),47 - EXIT D,0 -; -; -; -; Function Random(x: integer): real; -; (* -; GLOBAL -; SEED1, SEED2 : INTEGER *) -; CONST -; factor = Maxint; -; HALFINT = 16383; (* 1/2 OF MAXINT *) -; VAR -; x1 : real; -; temp1, temp2, HALF_ADDER : INTEGER; - -RANDOM: - ENTR D,2,10 -; (* Take 1/2 of the seeds for the comparison test *) -; temp1 := SEED1 DIV 2; - MOV L,-1(IY) - MOV H,0(IY) - LXI D,2 - DIVD D,0 - MOV -6(IX),H - MOV -7(IX),L -; temp2 := SEED2 DIV 2; - MOV L,-3(IY) - MOV H,-2(IY) - LXI D,2 - DIVD D,0 - MOV -8(IX),H - MOV -9(IX),L -; IF (temp1+temp2) >= HALFINT then{the number is too big -} - MOV L,-7(IX) - MOV H,-6(IX) - MOV E,-9(IX) - MOV D,-8(IX) - DADD D,0 - LXI D,16383 - GE D,0 -; { scale it down } -; HALF_ADDER := temp1 + temp2 - HALFINT - JNC L177 - MOV L,-7(IX) - MOV H,-6(IX) - MOV E,-9(IX) - MOV D,-8(IX) - DADD D,0 -; ELSE - LXI D,-16383 - DADD D,0 - MOV -4(IX),H - MOV -5(IX),L -; HALF_ADDER := temp1 + temp2; - JMP L197 -L177 - MOV L,-7(IX) - MOV H,-6(IX) - MOV E,-9(IX) - MOV D,-8(IX) - DADD D,0 - MOV -4(IX),H - MOV -5(IX),L -L197 -; SEED1 := SEED2; - MOV L,-3(IY) - MOV H,-2(IY) - MOV 0(IY),H - MOV -1(IY),L -; (* Restore from previous DIVision *) -; SEED2 := HALF_ADDER * 2; - MOV L,-5(IX) - MOV H,-4(IX) - DADD C - MOV -2(IY),H - MOV -3(IY),L -; (*---Convert X to real and divide by factor---*) -; x1 := ((X*1.0)/factor); - MOV L,8(IX) - MOV H,9(IX) - PUSH H - LXI H,320 - MOV D,A - MOV E,A - PUSH H - PUSH D - CVTF C - MULT D,-4 - CVTF A,32767 - FDVD D,-4 - LXI H,3 - DADD S - XCHG - PUSH IX - POP H - XCHG - LXI B,4 - LDDR - POP H - POP H -; (*---Return random number scaled by factor---*) -; RANDOM := ( SEED2 * x1 ); - MOV L,-3(IY) - MOV H,-2(IY) - PUSH H - LXI H,-4 - DADD S - SPHL - XCHG - PUSH IX - POP H - DCX H - DCX H - DCX H - LXI B,4 - LDIR - CVTF C - MULT D,-4 - LXI H,3 - DADD S - XCHG - PUSH IX - POP H - LXI B,13 - DADD B - XCHG - LXI B,4 - LDDR - POP H - POP H -; End{ of RANDOM(X) }; - EXIT D,2 - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/RNB.ERL b/software/CPM/CPM13_MTPUG_01/RNB.ERL deleted file mode 100644 index 1d114ad..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/RNB.ERL and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/RNB.SRC b/software/CPM/CPM13_MTPUG_01/RNB.SRC deleted file mode 100644 index 1c49b6e..0000000 --- a/software/CPM/CPM13_MTPUG_01/RNB.SRC +++ /dev/null @@ -1,78 +0,0 @@ -MODULE RNB; - -(*$M @RNB*) -(*$M **) - -(*$I FIBDEF.LIB*) - -VAR - @LFB : EXTERNAL ^FIB; - RESULTIO: EXTERNAL INTEGER; - -EXTERNAL FUNCTION @BDOS(FUNC:INTEGER; PARM:WORD):INTEGER; - -(* PURPOSE: READ n BYTES FROM A FILE POINTED TO BY @LFB *) -(* n IS SPECIFIED BY @LFB^.IOSIZE *) -(* LAST UPDATE: SEPTEMBER 17, 1980 *) -(* MODIFIED BY H. LUCAS 9/1/81 *) - -PROCEDURE @RNB; -VAR - DSTPTR: ^BYTE; - N,I : INTEGER; -BEGIN - MOVE(@LFB^.FBUFADR,DSTPTR,2); (* SET DEST POINTER *) - - IF @LFB^.OPTION = FCONIO THEN (* CON:, DO AN ECHOING READ *) - BEGIN - DSTPTR^ := CHR(@BDOS(1,WRD(0))); (* GO READ A CHAR WITH ECHO *) - IF DSTPTR^ = $0D THEN (* ECHO CR WITH CRLF *) - I := @BDOS(2,WRD($0A)) - ELSE IF DSTPTR^ = $08 THEN (* ECHO BS WITH SP/BS *) - BEGIN - I := @BDOS(2,WRD(' ')); - I := @BDOS(2,WRD($08)) - END; - EXIT - END - ELSE - IF @LFB^.OPTION = FTRMIO THEN (* KBD: DO A NON-ECHO READ *) - BEGIN - DSTPTR^ := CHR(@BDOS(6,WRD($FF))); (* GO READ A CHAR WITH NO ECHO *) - EXIT - END; - - - IF @LFB^.NOSECTRS THEN - BEGIN - @LFB^.FEOF := TRUE; - EXIT - END; - - FOR N := 1 TO @LFB^.IOSIZE DO - BEGIN - WITH @LFB^ DO - BEGIN - IF FSECINX = 128 THEN (* TIME TO READ MORE *) - BEGIN - FSECINX := 0; - IF NOT NOSECTRS THEN - BEGIN - I := @BDOS(26,WRD(ADDR(FSECTOR))); - RESULTIO := @BDOS(20,WRD(ADDR(FCB))); - IF RESULTIO <> 0 THEN NOSECTRS:=TRUE - END; - END; - IF NOSECTRS THEN - DSTPTR^ := CHR($FF) - ELSE - DSTPTR^ := FSECTOR[FSECINX]; - FSECINX := FSECINX + 1 - END; (* WITH *) - DSTPTR := DSTPTR + 1 - END; - @LFB^.BUFIDX := 0 (* SO GNB WORKS *) -END; - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/SBGETCH.SRC b/software/CPM/CPM13_MTPUG_01/SBGETCH.SRC deleted file mode 100644 index 68c3245..0000000 --- a/software/CPM/CPM13_MTPUG_01/SBGETCH.SRC +++ /dev/null @@ -1,31 +0,0 @@ -FUNCTION SB_GETCH:CHAR; -(* CONVERT MOST WORDSTAR COMMANDS TO SPP EQUIV. FRG-14JUL81 *) -VAR - CH : CHAR; - CHI, CHO : INTEGER; -BEGIN - SB_BIOS_CALL(CONIN,0); - INLINE("STA / CH); - CHI := ORD(CH); - CASE CHI OF {NEW COMMAND OLD FUNCTION} - $04 : CHO := $0C; { D L } - $05 : CHO := $0B; { E K } - $06 : CHO := $04; { F D } - $0A : CHO := $15; { J U } - $0B : CHO := $16; { K V } - $0C : CHO := $18; { L X } - $0F : CHO := $13; { O S } - $10 : CHO := $14; { P T } - $13 : CHO := $08; { S H } - $14 : CHO := $0F; { T O } - $15 : CHO := $17; { U W } - $16 : CHO := $06; { V F } - $17 : CHO := $05; { W E } - $18 : CHO := $0A; { X J } - $1F : CHO := $10; { - P } - ELSE CHO := CHI; - END ; (* CASE *) - SB_GETCH := CHR(CHO) -END; - - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/SD.COM b/software/CPM/CPM13_MTPUG_01/SD.COM deleted file mode 100644 index cb3c3e5..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/SD.COM and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/SEND.COM b/software/CPM/CPM13_MTPUG_01/SEND.COM deleted file mode 100644 index 0b53008..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/SEND.COM and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/SHIFT.COM b/software/CPM/CPM13_MTPUG_01/SHIFT.COM deleted file mode 100644 index aa1f66c..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/SHIFT.COM and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/SHIFT.DOC b/software/CPM/CPM13_MTPUG_01/SHIFT.DOC deleted file mode 100644 index 4252917..0000000 --- a/software/CPM/CPM13_MTPUG_01/SHIFT.DOC +++ /dev/null @@ -1,10 +0,0 @@ - - The command 'SHIFT ' reads the pascal source in - file2 and shifts everything not between quotes '' or curly - brackets {} to upper-case. This means that file1 afterwards - contains the program with everything but strings and comments - (curly bracket comments only) in upper case. - - SHIFT was written by T. W. Lougheed in TINY PASCAL (r). - - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/SINCOS.ERL b/software/CPM/CPM13_MTPUG_01/SINCOS.ERL deleted file mode 100644 index 4fab15a..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/SINCOS.ERL and /dev/null differ diff --git a/software/CPM/CPM13_MTPUG_01/SINCOS.SRC b/software/CPM/CPM13_MTPUG_01/SINCOS.SRC deleted file mode 100644 index 3ad0529..0000000 --- a/software/CPM/CPM13_MTPUG_01/SINCOS.SRC +++ /dev/null @@ -1,81 +0,0 @@ -MODULE SINCOS; { Copyright (c) by T. W. Lougheed 24 April 1981 } - -{ This procedure provides a replacement for the SINE function currently -available to the pascal system. It is faster and more accurate. } - -{ First version 5 February 1981 - - By T. W. Lougheed - Dept. T. & A. Mechanics - Thurston Hall, Cornell U. - Ithaca, NY 14853 - - Last version 23 February 1981 - - This software is in the public domain, and may not be sold by any - person or corperation without permission of the author. } - - - -FUNCTION SIN( Z :REAL) :REAL; - -CONST TWO_PI = 6.283185307179586; - PI = 3.141592653589793; - HALF_PI = 1.570796326794897; - -{ The following is from the HANDBOOK OF MATHEMATICAL FUNCTIONS, by -Abramowicz and Stegun, tenth printing. Formula 4.3.97; its error -is less than |X| 10^8 for |X| < PI/2. } - -FUNCTION TCHEBYSHEV( X :REAL) :REAL; - - CONST A2 = -0.1666666664; - A4 = 0.0083333315; - A6 = -0.0001984090; - A8 = 0.0000027526; - A10 = -0.0000000239; - - VAR S :REAL; - BEGIN - S := SQR( X ); - TCHEBYSHEV := (((((A10*S + A8)*S + A6)*S + A4)*S + A2)*S + 1)*X; - END; - - -BEGIN - -{ Map the argument Z onto the interval -PI..PI, rounding -towards the smallest absolute value. } - -IF Z > 0 THEN Z := Z - TWO_PI*ROUND( Z/TWO_PI ) - ELSE Z := Z + TWO_PI*ROUND( -Z/TWO_PI ); - -{ Always ask for TCHEBYSHEV of a number in the interval -PI/2..PI/2. } - -IF Z > HALF_PI THEN SIN := TCHEBYSHEV( PI - Z ) -ELSE IF Z > -HALF_PI THEN SIN := TCHEBYSHEV( Z ) -ELSE SIN := -TCHEBYSHEV( PI + Z ); - -END; - - - -{ Lazy cosine function based on the identity - - cos x = ( 1 - (sin x/2)^2 )/2 - -note that this has been re-arranged somewhat to -improve accuracy. } - -FUNCTION COS( Z :REAL) :REAL; - CONST SQRT_2 = 1.4142135623730950; - VAR S :REAL; - BEGIN - S := SQRT_2*SIN( Z/2 ); - COS := (1 - S)*(1 + S); - END; - - -MODEND -. - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/TRANCEND.DOC b/software/CPM/CPM13_MTPUG_01/TRANCEND.DOC deleted file mode 100644 index 5f9096d..0000000 --- a/software/CPM/CPM13_MTPUG_01/TRANCEND.DOC +++ /dev/null @@ -1,21 +0,0 @@ - - The files - - ARCTAN.TWL EXP.TWL LN.TWL SINCOS.TWL - - provide complete and correct pascal source for all the trancendental - functions vended with PASCAL/MT 5.1. They are in all cases more - or just as accurate and more efficient. The arctangent, as noted in - the source, fixes a bug in the MT 5.1 function, which returns - incorrect answers for large arguments. The logarithm is stable for - large numbers, which the MT 5.1 logarithm is not (starts giving - wild answers). The function EXP is vastly more efficient for - large numbers than the MT 5.1 logarithm. The sine and cosine - are probably just about the same. - - The user may compile and link these modules separately and link - them before linking TRANCEND, or may combine the RELocatable - modules using the MT-Librarian to make a new library to replace - TRANCEND. - - \ No newline at end of file diff --git a/software/CPM/CPM13_MTPUG_01/TRANCEND.TWL b/software/CPM/CPM13_MTPUG_01/TRANCEND.TWL deleted file mode 100644 index 12c14d9..0000000 Binary files a/software/CPM/CPM13_MTPUG_01/TRANCEND.TWL and /dev/null differ diff --git a/software/CPM/CPM14_MTPUG_02/CALCULAT.CMD b/software/CPM/CPM14_MTPUG_02/CALCULAT.CMD deleted file mode 100644 index 33a333c..0000000 --- a/software/CPM/CPM14_MTPUG_02/CALCULAT.CMD +++ /dev/null @@ -1,5 +0,0 @@ -calc -trancend -fpreals -paslib/s - \ No newline at end of file diff --git a/software/CPM/CPM14_MTPUG_02/CALCULAT.COM b/software/CPM/CPM14_MTPUG_02/CALCULAT.COM deleted file mode 100644 index f9eded1..0000000 Binary files a/software/CPM/CPM14_MTPUG_02/CALCULAT.COM and /dev/null differ diff --git a/software/CPM/CPM14_MTPUG_02/CALCULAT.DOC b/software/CPM/CPM14_MTPUG_02/CALCULAT.DOC deleted file mode 100644 index a822b07..0000000 --- a/software/CPM/CPM14_MTPUG_02/CALCULAT.DOC +++ /dev/null @@ -1,40 +0,0 @@ -Scientific Calculator Program by: Warren A. Smith - - This program is only marginally intended to replace a -scientific calculator. Because of the limited accuracy available -from a 32 bit representation of real numbers (as all numbers are -treated in this program) this program has only limited use as a -true calculator. However, it does perform most trigonometric functions -as well as a few others and you may find these useful at times. - The input is an equation where functions are expressed by name -(or more appropriately by mnemonic) and whose arguements follow within -parenthesis. An expample would be - 4.4 * 3.6/sqrt(4.6) -Blanks do not matter (except of course in the middle of a name) and -upper and lower case alpha is interchangeable. - Normal algebraic precedence is followed with unary minus having -the highest, followed by parenthesis, followed by exponentiation '^', -and then multiplication and division '*', '/' having equal precedence. -Addition and subtraction also have equal precedence below multiplication -and division. - Typing in a question mark in response to a request for an -expression will give you a list of the currently implemented functions -along with their appropriate mnemonics. - Typing in an exclamation point will cause the program to -print out intermediate results on its way to the answer. A second -exclamation point will turn this feature off. - The main reason for writting this program was as an exercise -in recursion and parsing of input strings. I took as a flow chart -the Pascal syntax diagrams for a simple expression and extended the -idea to include exponentiation. If you investigate the source code -which I hope everyone will, you will see that it is relatively easy -to add functions to the acceptable input. You can add functions -with one arguement and with no arguements (the way Pi is treated) -simply. If you need a function with two or more arguements, you -are going to have to rethink the section within Factor that is res- -ponsible for functions. It should not take any major rewritting, only -additions. - Good luck and let me know if you come up with any improvements -or functional additions. You can reach me at: - 6150 First Ave. - Sacramento, CA 95817 - \ No newline at end of file diff --git a/software/CPM/CPM14_MTPUG_02/CALCULAT.ERL b/software/CPM/CPM14_MTPUG_02/CALCULAT.ERL deleted file mode 100644 index 70f56f1..0000000 Binary files a/software/CPM/CPM14_MTPUG_02/CALCULAT.ERL and /dev/null differ diff --git a/software/CPM/CPM14_MTPUG_02/CALCULAT.PAS b/software/CPM/CPM14_MTPUG_02/CALCULAT.PAS deleted file mode 100644 index ac03971..0000000 --- a/software/CPM/CPM14_MTPUG_02/CALCULAT.PAS +++ /dev/null @@ -1,581 +0,0 @@ -{$S+} { Turn on recursion ability, must be first line in Pascal/MT+ } -{$X+} { Turn on run-time error checking } - -Program Handcalc ; - -{ This program is intended to act as a scientific calculator, with } -{ exponentiation and trancendental functions. } - -Const - Func_Len = 6; { No. of characters allowed in a function name } - Num_Funcs = 20; { No. of functions recognized } - Pi = 3.1415926535897323846264338; { This is silly of course } - { but the numbers are correct } - -Type - Functions = (ArcTangent, Cosine, Logrithm, Sine, Square, Square_Root, - Exponent, Tangent, CoTangent, Secant, CoSecant, - ArcSine, ArcCosine, ArcCotangent, ArcSecant, - ArcCoSecant, Pie, Radians, Log, Factorial, - Non_Function); - - Set_of_Funcs = Set of Functions; - Func_Name = array [1..Func_Len] of char; - Func_Rec = record - Name : Func_Name; - Func_Type : Functions - end; - Func_List = array [1..Num_Funcs] of Func_Rec; - -Var - Answer : real; - Buf : String; - Z : integer; { Index into Buf } - F_Names : Func_List; - Non_Parm_Funcs : Set_of_Funcs; - Debug_Mode : boolean; - -Procedure ScreenClr; - - Var - I : integer; - - begin { ScreenClr } - { If your terminal can clear the screen (with say a Control-Z) then } - { output what ever characters are needed in place of this loop } - - For I := 1 to 24 do - Writeln - - end; { ScreenClr } - -Procedure Initialization; - - Var - I : integer; - - Procedure Init_Funcs; - - begin { Init_Funcs } - { The order of the strings in F_Names must be alphabetical } - { This should be remembered when adding new functions } - F_Names[1].Name := 'ARCCOS'; F_Names[1].Func_Type := ArcCosine; - F_Names[2].Name := 'ARCCOT'; F_Names[2].Func_Type := ArcCoTangent; - F_Names[3].Name := 'ARCCSC'; F_Names[3].Func_Type := ArcCoSecant; - F_Names[4].Name := 'ARCSEC'; F_Names[4].Func_Type := ArcSecant; - F_Names[5].Name := 'ARCSIN'; F_Names[5].Func_Type := ArcSine; - F_Names[6].Name := 'ARCTAN'; F_Names[6].Func_Type := ArcTangent; - F_Names[7].Name := 'COS '; F_Names[7].Func_Type := Cosine; - F_Names[8].Name := 'COT '; F_Names[8].Func_Type := CoTangent; - F_Names[9].Name := 'CSC '; F_Names[9].Func_Type := CoSecant; - F_Names[10].Name:= 'EXP '; F_Names[10].Func_Type:= Exponent; - F_Names[11].Name:= 'FACTOR'; F_Names[11].Func_Type:= Factorial; - F_Names[12].Name:= 'LN '; F_Names[12].Func_Type:= Logrithm; - F_Names[13].Name:= 'LOG '; F_Names[13].Func_Type:= Log; - F_Names[14].Name:= 'PI '; F_Names[14].Func_Type:= Pie; - F_Names[15].Name:= 'RADIAN'; F_Names[15].Func_Type:= Radians; - F_Names[16].Name:= 'SEC '; F_Names[16].Func_Type:= Secant; - F_Names[17].Name:= 'SIN '; F_Names[17].Func_Type:= Sine; - F_Names[18].Name:= 'SQR '; F_Names[18].Func_Type:= Square; - F_Names[19].Name:= 'SQRT '; F_Names[19].Func_Type:= Square_Root; - F_Names[20].Name:= 'TAN '; F_Names[20].Func_Type:= Tangent; - Non_Parm_Funcs := [Pie] - end; { Init_Funcs } - - begin { Initialization } - { Clear the screen } - ScreenClr; - Writeln ('Calculator'); - Writeln; - Writeln ('by Warren A. Smith -- July 29, 1981'); - Write (Skip_Line(4)); - Writeln ('A ''?'' at the beginning of a line will bring up a listing'); - Writeln (' of possible functions and operators that may be used.'); - Writeln; - Writeln ('A dollar sign ''$'' at the beginning of a line will'); - Writeln (' cause this program to terminate.'); - Writeln; - Debug_Mode := FALSE; - Init_Funcs - end; { Initialization } - -Function Skip_Line (N : integer) : char; - - Var - I : integer; - - begin { Skip_Line } - For I := 1 to N do - Writeln; - Skip_Line := chr(0) - end; { Skip_Line } - -Function Tab (N : integer) : char; - - Var - I : integer; - - begin { Tab } - For I := 1 to N do - Write (' ') - end; { Tab } - -Function Upper (In_Char : char) : char; - - begin { Upper } - If (In_Char >= 'a') AND (In_Char <= 'z') then - Upper := chr(ord(In_Char) + (ord('A') - ord('a'))) - else - Upper := In_Char - end; { Upper } - -Procedure Help; - - Var - Response : char; - - begin { Help } - ScreenClr; - Writeln (' The currently available functions are :'); - Writeln; - Writeln (' ArcCosine - ArcCos ArcCotangent - ArcCot'); - Writeln (' ArcCosecant - ArcCsc ArcSecant - ArcSec'); - Writeln (' ArcSine - ArcSin ArcTangent - ArcTan'); - Writeln (' Cosine - Cos CoTangent - Cot '); - Writeln (' CoSecant - Csc Natural Exponent - Exp '); - Writeln (' Natural Log - Ln Secant - Sec '); - Writeln (' Sine - Sin Square - Sqr '); - Writeln (' Square Root - Sqrt Tangent - Tan '); - Writeln (' Log base 10 - Log Factorial - Factor'); - Writeln (' Value of Pi - Pi '); - Writeln; - Writeln (' Allowable operators are:'); - Writeln (' ''+'', ''-'', ''*'', ''/'', and ''^'' (exponentiation)'); - Writeln; - Writeln (' Upper case and lower case are irrelevant in function names'); - Writeln (' A ''$'' will end the program, a ''!'' turns on debug mode '); - Writeln; - Writeln ('Hit the carriage return to proceed.'); - Read (Response); - end; { Help } - -Function Eoln : boolean; - - begin { Eoln } - Eoln := Z > Length(Buf) - end; { Eoln } - -Procedure Slough_Blanks; - - begin { Slough_Blanks } - While (Buf[Z] = ' ') AND (not Eoln) do - Z := Z + 1 - end; { Slough_Blanks } - -Procedure Get_Expr; - - begin { Get_Expr } - Repeat - Writeln; - Writeln ('Type in an expression to be solved.'); - Readln (Buf); - Z := 1; - Slough_Blanks - Until not Eoln - end; { Get_Expr } - -Function Expr : real; - - Var - Unary, - Answer : real; - - Function Term : real; - - Var - Answer : real; - - Function Expon : real; - - Var - Answer : real; - - Function XtoY (X, Y : real) : real; - - begin { XtoY } - If X >= 0.0 then - XtoY := exp(Y * Ln(X)) - else - XtoY := 0.0 - end; { XtoY } - - Function Factor : real; - - Var - Answer, - X : real; - Func : Functions; - - Procedure Read (Var Answer : real); - - Var - Fact_Power : real; - - begin { Read } - Answer := 0.0; - Slough_Blanks; - While Digit (Buf[Z]) AND not Eoln do - begin - Answer := Answer * 10.0 + (Ord(Buf[Z])-Ord('0')); - Z := Z + 1 - end; - If (Buf[Z] = '.') AND not Eoln then - begin - Z := Z + 1; - Fact_Power := 1.0; - While Digit (Buf[Z]) AND not Eoln do - begin - Fact_Power := Fact_Power / 10.0; - Answer := Answer+(Ord(Buf[Z])-Ord('0'))*Fact_Power; - Z := Z + 1 - end - end - end; { Read } - - Function Digit (In_Char : char) : boolean ; - - begin { Digit } - Digit := In_Char in ['0','1','2','3','4','5','6','7', - '8','9'] - end; { Digit } - - Function Letter (Var In_Char : char) : boolean; - - begin { Letter } - In_Char := Upper (In_Char); - Letter := In_Char in ['A','B','C','D','E','F','G','H', - 'I','J','K','L','M','N','O','P', - 'Q','R','S','T','U','V','W','X', - 'Y','Z'] - end; { Letter } - - Function Get_Func_Type : Functions; - - Var - ID : Func_Name; - Index : integer; - - Function Search_Funcs (ID : Func_Name) : Functions; - - Var - I, J, K : integer; - - begin { Search_Funcs } - I := 1; - J := Num_Funcs; - Repeat - K := (I+J) DIV 2; { Binary search } - With F_Names[K] do - begin - If Name <= ID then - I := K+1; - - If Name >= ID then - J := K-1 - end - - Until I > J; - If F_Names[K].Name <> ID then - Search_Funcs := Non_Function - else - Search_Funcs := F_Names[K].Func_Type - end; { Search_Funcs } - - begin { Get_Func_Type } - Index := 1; - Repeat - ID [Index] := Buf[Z]; - Z := Z + 1; - Index := Index + 1 - Until Not Letter(Buf[Z]) OR Eoln OR (Index > Func_Len); - While Index <= Func_Len do - begin - ID [Index] := ' '; - Index := Index + 1 - end; - - Get_Func_Type := Search_Funcs (ID) - end; { Get_Func_Type } - - Function Tan (X : real) : real; - - begin { Tan } - Tan := Sin(X) / Cos(X) - end; { Tan } - - Function Cot (X : real) : real; - - begin { Cot } - Cot := Cos(X) / Sin(X) - end; { Cot } - - Function Sec (X : real) : real; - - begin { Sec } - Sec := 1.0 / Cos(X) - end; { Sec } - - Function Csc (X : real) : real; - - begin { Csc } - Csc := 1.0 / Sin(X) - end; { Csc } - - Function ArcSin (X : real) : real; - - begin { ArcSin } - ArcSin := ArcTan(X / Sqrt(1.0 - Sqr(X))) - end; { ArcSin } - - Function ArcCos (X : real) : real; - - begin { ArcCos } - ArcCos := Pi / 2.0 - ArcTan (X / Sqrt(1.0 - Sqr(X))) - end; { ArcCos } - - Function ArcCot (X : real) : real; - - begin { ArcCot } - ArcCot := Pi / 2.0 - ArcTan (X) - end; { ArcCot } - - Function ArcSec (X : real) : real; - - begin { ArcSec } - ArcSec := ArcTan (Sqrt(Sqr(X) - 1.0)) - end; { ArcSec } - - Function ArcCsc (X : real) : real; - - begin { ArcCsc } - ArcCsc := ArcTan (1.0 / Sqrt(Sqr(X) - 1.0)) - end; { ArcCsc } - - Function Radian (X : real) : real; - - begin { Radian } - Radian := X * (Pi / 180.0) - end; { Radian } - - Function Log10 (X : real) : real; - - begin { Log10 } - Log10 := Ln(X) / Ln(10.0) - end; { Log10 } - - Function Factorl (X : real) : real; - - Var - Int_X, I : integer; - Product : real; - - begin { Factorl } - Int_X := Round(X); - If Int_X = 0 then - Factorl := 1.0 - else - begin - Product := 1.0; - For I := 2 to Int_X do - Product := Product * I; - Factorl := Product - end - end; { Factorl } - - begin { Factor } - Slough_Blanks; - If Digit (Buf[Z]) OR (Buf[Z] = '.') then - Read (Answer) - else - If Buf[Z] = '(' then - begin - Z := Z + 1; - Answer := Expr; - If Buf[Z] <> ')' then - begin - Write (Tab(Z-1),'^ '); - Writeln ('*** '')'' expected') - end - else - Z := Z + 1 - end - else - If Letter (Buf[Z]) then - begin - Func := Get_Func_Type; - Slough_Blanks; - If not (Func in Non_Parm_Funcs) then - begin - If Buf[Z] = '(' then - begin - Z := Z + 1; - Answer := Expr - end - else - begin - Write (Tab(Z-1), '^ '); - Write ('*** ''('' expected, answer '); - Writeln ('may be in error') - end; - Slough_Blanks; - If Buf[Z] = ')' then - Z := Z + 1 - else - begin - Write (Tab(Z-1), '^ '); - Write ('*** '')'' expected, answer '); - Writeln ('may be in error') - end - end; - Case Func of - Logrithm : Answer := Ln (Answer); - Exponent : Answer := Exp (Answer); - Log : Answer := Log10 (Answer); - Square : Answer := Sqr (Answer); - Square_Root : Answer := Sqrt (Answer); - Factorial : Answer := Factorl (Answer); - Cosine : Answer := - Cos (Radian(Answer)); - Sine : Answer := - Sin (Radian(Answer)); - ArcTangent : Answer := - ArcTan (Radian(Answer)); - Tangent : Answer := - Tan (Radian(Answer)); - CoTangent : Answer := - Cot (Radian(Answer)); - Secant : Answer := - Sec (Radian(Answer)); - CoSecant : Answer := - Cos (Radian(Answer)); - ArcSine : Answer := - ArcSin (Radian(Answer)); - ArcCosine : Answer := - ArcCos (Radian(Answer)); - ArcCoTangent: Answer := - ArcCot (Radian(Answer)); - ArcSecant : Answer := - ArcSec (Radian(Answer)); - ArcCoSecant : Answer := - ArcCsc (Answer); - Pie : Answer := Pi; - Radians : Answer := Radian (Answer); - Non_Function: begin - Write (Tab(Z-1), '^ '); - Writeln - ('*** Uninown function name') - end - end; { CASE } - Slough_Blanks - end - else - begin - Write (Tab(Z-1), '^ '); - Write ('*** Unknown Syntax, answer may '); - Writeln ('be in error') - end; - If Debug_Mode then - Writeln ('Result from FACTOR = ', Answer:20:8); - Factor := Answer - end; { Factor } - - begin { Expon } - Answer := Factor; - Slough_Blanks; - While Buf[Z] = '^' do - begin - Z := Z + 1; - Answer := XtoY (Answer, Factor); - Slough_Blanks - end; - If Debug_Mode then - Writeln ('Result from EXPON = ', Answer:20:8); - Expon := Answer - end; { Expon } - - begin { Term } - Answer := Expon; - Slough_Blanks; - While Buf[Z] in ['*', '/'] do - begin - If Buf[Z] = '*' then - begin - Z := Z + 1; - Answer := Answer * Expon - end - else - begin - Z := Z + 1; - Answer := Answer / Expon; - end; - Slough_Blanks - end; - If Debug_Mode then - Writeln ('Result from TERM = ', Answer:20:8); - Term := Answer - end; { Term } - - begin { Expr } - Slough_Blanks; - Unary := 1.0; - If Buf[Z] in ['+','-'] then - begin - If Buf[Z] = '-' then - Unary := -1.0; - Z := Z + 1 - end; - Answer := Unary * Term; - Slough_Blanks; - While Buf[Z] in ['+', '-'] do - begin - If Buf[Z] = '+' then - begin - Z := Z + 1; - Answer := Answer + Term - end - else - begin - Z := Z + 1; - Answer := Answer - Term - end; - Slough_Blanks - end; - If Debug_Mode then - Writeln ('Result from EXPR =', Answer:20:8); - Expr := Answer - end; { Expr } - -begin { Main } -Initialize; -Get_Expr; -While Buf[Z] <> '$' do - begin - If Buf[Z] = '?' then - Help - else - If Buf[Z] = '!' then - Debug_Mode := not Debug_Mode - else - If Buf[Z] <> '$' then - begin - Answer := Expr; - Writeln; - Writeln ('The answer is :', Answer:9:6) - end; - Get_Expr - end; -Writeln; -Writeln ('Program ended'); -Writeln -end. - \ No newline at end of file diff --git a/software/CPM/CPM14_MTPUG_02/CP#M-DEC.DOC b/software/CPM/CPM14_MTPUG_02/CP#M-DEC.DOC deleted file mode 100644 index a25dbbd..0000000 --- a/software/CPM/CPM14_MTPUG_02/CP#M-DEC.DOC +++ /dev/null @@ -1,113 +0,0 @@ - - -************************************************************************* - - -COVERING: CPMTODEC,DECTOCPM,LISTDEC - -WRITTEN BY: BRIAN T. CHASE CODE 8131 8/26/78 - AT NAVAL OCEAN SYSTEM CENTER - SAN DIEGO, CALIF. 92152 - -FOR: CEASAR CASTRO CODE 8143 - NAVANL OCEAN SYSTEM CENTER - SAN DIEGO, CALIF. 92152 - - - THESE PROGRAMS ENABLE THE CP/M USER TO TRANSFER FILES BETWEEN -CP/M AND DEC FORMAT DISKETTES, AS WELL AS LISTING THE DEC DISK'S -DIRECTORY. - AT PRESENT THE PROGRAM ONLY TRANSFERS ASCII FILES. THERE IS A -BUG WHICH IS PREVENTING OBJECT FILES FROM BEING TRANSFERED. - -________________________________________________________________________ - - -1. LISTDEC: THE PROGRAM IS STARTED BY TYPING "LISTDEC ", AS - IS ANY CP/M TRANSIENT PROGRAM. THE PROGRAM WILL THEN ASK - WHETHER OR NOT THE DEC DISK IS INTERLEAVED (SEE NOTE C.) - AS SOON AS THIS QUESTION IS ANSWERED THE DIRECTORY IS READ IN, - INTERPRETED, AND PRINTED AT THE CONSOLE. THE PROGRAM THEN - IMMEDIATELY RETURNS CONTROL TO CP/M (NO REBOOT). - -2. CPMTODEC: TYPE "CPMTODEC " TO EXECUTE. THE PROGRAM WILL - FIRST ASK IF USER WANTS TO ZERO (INITIALIZE) THE DEC DISK. - IF "Y" IS TYPED, IT WILL ASK "ARE YOU SURE?". IF EITHER OF - THESE QUESTIONS IS ANSWERED BY ANYTHING BUT A "Y", THIS OP- - TION WILL BE SKIPPED. IF DEC DISK IS TO BE ZEROED, THE MES- - SAGE "PLACE DEC DISK ON DRIVE B" WILL BE PRINTED (SEE NOTE - A), FOLLOWED BY THE QUESTION "IS DEC DISK INTERLEAVED?" (SEE - NOTE C). AFTER THIS QUESTION HAS BEEN ANSWERED, THE DISK ON - DRIVE B WILL BE ZEROED. - THE PROGRAM WILL THEN ASK FOR CP/M FILENAME (SOURCE - FILE ON CP/M DISK). ALL KEYBOARD EDITING COMMANDS ARE - AVAILABLE. IT THEN REQUESTS THE DEC FILENAME (DESTINATION - FILE). ALL FILE NAMING CONVENTIONS SHOULD BE OBSERVED. IF - A SYNTAX ERROR OCCURS, THE PROGRAM ASKS FOR BOTH FILENAMES - AGAIN (CHECK CHARACTER COUNT IN NAME). THE "PLACE DEC DISK - ON DRIVE B" MESSAGE IS THEN PRINTED (SEE NOTE A). ANSWER - THE READY(Y/N)? QUESTION WITH A "Y" WHEN READY-"N" WILL ASK - FOR NEW FILENAMES. - WHEN TRANSFER IS COMPLETE, THE MESSAGE "ANOTHER - TRANSFER(Y/N)?" WILL BE PRINTED. "Y" WILL ASK FOR NEW FILE- - NAMES, "N" WILL REBOOT SYSTEM (ZERO FIRST TIME ONLY). - -3. DECTOCPM: TYPE "DECTOCPM " TO EXECUTE. THIS IS SIMILAR - TO #2 ABOVE EXCEPT THAT THE PROGRAM ASKS IF THE DEC FILE - IS ASCII. THIS MEANS: IS THE FILE TO BE TRANSFERRED AN - ASCII SOURCE, LISTING, OR OTHER ASCII-TYPE FILE, OR IS - IT A DATA FILE OR MACHINE CODE,ETC. FILE. NON-ASCII FILES - ARE TRANSFERRED ENTIRELY (ALL BLOCKS TRANSFERRED). FOR - ASCII FILES, THE LAST BLOCK IS CHECKED FOR EOF CHARACTER - (DIFFERENT IN DEC & CP/M FILE FORMATS). (NO ZERO OPTION). - -_________________________________________________________________________ - -NOTES: - - A. THE CP/M STRUCTURE INCLUDES PROVISIONS FOR AT LEAST TWO - DISK DRIVES. IN ALL THREE OF THESE PROGRAMS, THE DEC DISK - IS TO BE PLACED ON DRIVE B. FOR THOSE USERS WITH A SINGLE - DRIVE ON THEIR SYSTEM, CBIOS SHOULD PRINT OUT AN APPROPRIATE - MESSAGE AT THE CONSOLE WHEN ANY PROGRAM SELECTS A DRIVE NOT - CURRENTLY BEING ACCESSED. IN THESE PROGRAMS, THE MESSAGE - "PLACE DEC DISK ON DRIVE B" SHOULD BE IGNORED BY SINGLE - DRIVE USERS-THEY SHOULD WAIT UNTIL THEIR CBIOS NOTIFIES - THEM OF THE SWITCH. - - B. IT SHOULD BE NOTED THAT TO SIMPLIFY THESE PROGRAMS - CONSIDERABLY, THE DEC DISK'S DIRECTORY IS ASSUMED TO BE - EFFECTIVELY ONLY ONE SEGMENT (8 SECTORS) LONG (THEY ARE - NORMALLY INITIALIZED TO 4 SEGMENTS). THIS IS A REASONABLE - ASSUMPTION, SINCE UP TO APPROXIMATELY 72 ENTRIES CAN BE - CONTAINED IN ONE SEGMENT. HOWEVER, IF A FILE CANNOT BE - FOUND ON THE DEC DISK BY THE DECTOCPM PROGRAM AND A SUB- - SEQUENT DIRECTORY LISTING ON A DEC COMPUTER SHOWS THE FILE - PRESENT, THE SOLUTION WOULD BE TO PIP THE DESIRED FILE TO - ANOTHER DEC DISK WITH FEWER OR NO FILES ON IT (EG A FRESH- - LY ZEROED DISK). - - C. THESE PROGRAMS WERE ALSO WRITTEN TO HANDLE TWO DIFFERENT - DEC DISK FORMATS: - - 1. STANDARD DEC FORMAT- LOGICAL SECTORS BEGIN ON TRACK 1 - WITH PHYSICAL SECTORS 1,3,5,7...23,25,2,4,6...24,26 (EVERY - OTHER SECTOR). THIS SEQUENCE IS ALSO SHIFTED BY ADDING AN - AMOUNT B=6*(TRACK#-1) TO THE TRACK 1 VALUES (IN MOD 26). - - 2. CONSECUTIVE- LOGICAL SECTORS ARE PHYSICAL SECTORS. - - EACH PROGRAM ASKS IF THE DEC DISK IS INTERLEAVED. THIS IS - ASKING WHETHER THE DISK IS STANDARD DEC FORMAT OR IF IT IS - CONSECUTIVE (IE LOGICAL SECTORS=PHYSICAL SECTORS). A FLAG IS - SET OR RESET FOR THE DISK B HANDLING ROUTINE. THE USER MAY - WISH TO ALTER THIS FUNCTION IF HE HAS ONLY ONE TYPE OF DEC - DISK. - - D. THE CP/M PROGRAM BEING TRANSFERRED MUST BE ON THE SAME - DISK THAT THE TRANSFERRING PROGRAM (CPMTODEC OR DECTOCPM) IS - ON (DUE TO THE AUTOMATIC READ-ONLY STATUS THAT SWITCHING - DISKS CAUSES IN VERSION 1.4). - -***************************************************************************** - \ No newline at end of file diff --git a/software/CPM/CPM14_MTPUG_02/CPMTODEC.ASM b/software/CPM/CPM14_MTPUG_02/CPMTODEC.ASM deleted file mode 100644 index 61f69e8..0000000 --- a/software/CPM/CPM14_MTPUG_02/CPMTODEC.ASM +++ /dev/null @@ -1,1198 +0,0 @@ -*THIS PROGRAM TRANSFERS A FILE FROM A CP/M FORMAT DISK TO A -* DEC FORMAT DISK -* -* -*CP/M DEFINITIONS FOR PRIMITIVES -* -RDCON EQU 1 ;GET CHAR FROM CONSOLE -WRTCON EQU 2 ;TYPE CHAR ON CONSOLE -RDRDR EQU 3 ;GETCHAR FROM PAPER TAPE READER -WRTPCH EQU 4 ;SEND CHAR TO PUNCH -WRTLST EQU 5 ;SEND CHAR TO LIST DEVICE -IOSTAT EQU 7 ;INTERROGATE I/O STATUS (NOT USED HERE) -ALTIO EQU 8 ;ALTER I/O STATUS (NOT USED HERE) -PCONBF EQU 9 ;PRINT CONSOLE BUFFER -RCONBF EQU 10 ;READ CONSOLE BUFFER -CONST EQU 11 ;CHECK CONSOLE STATUS (BIT0 SET IF READY) -LIFTHD EQU 12 ;LIFT DISK HEAD (NOT USED HERE) -RSTDSK EQU 13 ;DMA ADDR TO 80H,SELECT DISK A -SELDSK EQU 14 ;SELECT DISK -OPENF EQU 15 ;OPEN FILE -CLOSEF EQU 16 ;CLOSE FILE -SRCH1 EQU 17 ;SEARCH FOR FIRST FILE OCCURRENCE -SCHNXT EQU 18 ;SEARCH FOR NEXT FILE OCCURRENCE -DELETF EQU 19 ;DELETE FILE -READF EQU 20 ;READ TO BUFFER -WRITEF EQU 21 ;WRITE TO BUFFER -MAKEF EQU 22 ;CREATE A FILE ENTRY -RENAMF EQU 23 ;RENAME A FILE -INTLOG EQU 24 ;INTERROGATE LOGIN VECTOR -INTDSK EQU 25 ;INTERROGATE DISK (RETURNS SELECTED DISK #) -SETDMA EQU 26 ;SET DMA ADDR -INTALL EQU 27 ;INTERROGATE ALLOCATION VECTOR -* -BDOS EQU 0005H ;DOS ENTRY POINT -FCB EQU 5CH ;DEFAULT FILE CONTROL BLOCK ADDRESS -BUFF EQU 80H ;DEFAULT DMA ADDRESS -* - ORG 0100H -* -*SET UP STACK - LXI SP,STKTOP - JMP EXEC -*STACK AREA -STACK: DS 64 -STKTOP EQU $ -* -*VARIABLES -CONBUF: DS 80 -* -EXEC: MVI A,79 - STA CONBUF ;SET FIRST BYTE TO BUFFER LENGTH - JMP MAIN ;JUMP TO MAIN PROGRAM -*SUBROUTINES -PCHAR: ;PRINT CHAR IN REG A - PUSH H! PUSH D! PUSH B ;ENVIRONMENT SAVED - MVI C,WRTCON - MOV E,A - CALL BDOS - POP B! POP D! POP H ;ENVIRONMENT RESTORED - RET -* -CRLF: ;PRINT A CARRIAGE RETURN & LINE FEED - MVI A,0DH - CALL PCHAR - MVI A,0AH - CALL PCHAR - RET -* -PNIB: ;PRINT NIBBLE IN REG A - ANI 0FH ;LOWER 4 BITS - CPI 10 - JNC P10 - ;LESS THAN OR EQUAL TO 9 - ADI '0' - JMP PRN - ;GREATER THAN 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 -* -CHIN: ;GET A CHAR FROM CONSOLE - PUSH H! PUSH D! PUSH B - MVI C,RDCON - CALL BDOS - POP B! POP D! POP H - RET -* -MSG: ;PRINT A MESSAGE POINTED TO BY HL (END OF MESSAGE=0FFH) - MOV A,M - CPI 0FFH - RZ ;RETURN IF END OF MESSAGE - CALL PCHAR - INX H - JMP MSG -* -SETTRK: ;SET TRACK IN C - LHLD 1 - LXI D,27 - DAD D - PCHL -* -SETSEC: LHLD 1 - LXI D,30 - DAD D - PCHL -* -RDSEC: LHLD 1 - LXI D,36 - DAD D - PCHL -* -WRTSEC: LHLD 1 - LXI D,39 - DAD D - PCHL -* -RDWRT: ;READ/WRITE TO DISK B-LOG.TRACK IN "TRACK",LOG.SECTOR IN "SECTOR" - PUSH B - PUSH D - LDA TRACK - STA BTRACK - LDA SECTOR - STA BSECT - LDA INTLEV ;GET INTERLEAVE FLAG - ORA A - JZ CONSEC ;0 > CONSECUTIVE SECTORS -* -*INTERLEAVE ALGORITHM FOR STANDARD DEC DISKS -* - MVI H,0 - LDA BTRACK - MOV L,A - DCX H ;HL=TRACK-1;NOW MULTIPLY BY 6 - MOV A,L - ADD A - MOV L,A - MOV A,H - RAL - MOV H,A - SHLD X2 ;HL*2 -INTLV3: MOV A,L - ADD A - MOV L,A - MOV A,H - RAL - MOV H,A - XCHG - LHLD X2 - DAD D ;HL*6 IN HL -* 6*(TRACK-1) IN HL -* -INTLV0: MOV A,H - ORA A - JNZ INTLV5 - MOV A,L - CPI 26 - JC INTLV4 -INTLV5: LXI D,0-26 - DAD D - JMP INTLV0 -INTLV4: LDA BSECT - DCR A ;SHIFT SECTOR DOWN (0-25) - PUSH PSW - ADD A - MOV E,A ;SAVE S2 - POP PSW - CPI 13 - MOV A,E ;GET S2 BACK TO ACC. - JM INTLV2 - INR A -INTLV2: ADD L ;ADD BIAS -INTLV1: SUI 26 - JP INTLV1 - ADI 27 - STA BSECT ;NEW PHYSICAL SECTOR TO BSECT -* -*END OF INTERLEAVE ALGORITHM -* -CONSEC: LDA BSECT - MOV C,A - CALL SETSEC - LDA BTRACK - MOV C,A - CALL SETTRK - LDA OPFLAG - CPI 0 - JNZ CONSC1 - CALL RDSEC - POP D - POP B - RET -CONSC1: CALL WRTSEC - POP D - POP B - RET -* -DIRECT: ;IF READ:GET SEG.1 OF DIRECT.TO DRBUFF - ;IF WRITE:WRITE SEG.1 OF DIRECT.ONTO DIRECTORY AREA OF DEC DISK - ;IN BOTH CASES,ASSUME FILE WILL BE IN OR FIT IN SEG.1 - MVI A,2 - STA COUNT - MVI A,01H - STA TRACK - MVI A,19H - STA SECTOR - LXI H,DRBUFF - SHLD BUFFPT ;INIT. BUFFPT - MVI C,SELDSK - MVI E,1 ;B - CALL BDOS - LXI D,0 -GTDIR1: LHLD BUFFPT - DAD D - SHLD BUFFPT - XCHG - MVI C,SETDMA - CALL BDOS - CALL RDWRT ;READ/WRITE SECTOR FROM/TO DISK - LXI D,128 - MVI A,1AH - STA SECTOR - LDA COUNT - DCR A - STA COUNT - JNZ GTDIR1 ;READ IN FIRST 2 SECTORS - MVI A,6 - STA COUNT - MVI A,02 - STA TRACK - DCR A - STA SECTOR -GTDIR2: LXI D,128 ;LENGTH OF A SECTOR - LHLD BUFFPT - DAD D - SHLD BUFFPT - XCHG ;DMA ADDR > DE - MVI C,SETDMA - CALL BDOS - CALL RDWRT - LDA SECTOR - INR A - STA SECTOR - LDA COUNT - DCR A - STA COUNT - JNZ GTDIR2 - RET -* -* -TRSEC: ;CALCULATES TR#,SEC# FROM # OF BLOCKS TO FILE - LHLD BLOCKS ;#OF BLOCKS > HL (4 SECTORS/BLOCK) - MVI B,2 -TRSC1: MOV A,L - ADD A - MOV L,A - MOV A,H - RAL - MOV H,A - DCR B - JNZ TRSC1 ;BLOCKS*4 IN HL -* - MVI A,1 - STA TRACK ;INIT. TRACK -TRSC4: LXI D,0FFE6H ;-26 - DAD D - MOV A,H - RAL - JNC TRSC2 - LXI D,1BH - DAD D - JMP TRSC3 -TRSC2: LDA TRACK - INR A - STA TRACK - JMP TRSC4 -TRSC3: MOV A,L - STA SECTOR - RET ;TR# IS IN TRACK,SEC# IS IN SECTOR -* -NAMCOM: ;COMPARES PERM. FILE NAME WITH NEW FILE NAME AND SETS FLAG - ; "MATCH" IF SAME - PUSH H - PUSH B - MVI C,6 - LXI H,FILE - SHLD FLNMPT - LXI H,FILELO - SHLD FLBFPT -NMCOM1: LHLD FLNMPT - MOV B,M - INX H - SHLD FLNMPT - LHLD FLBFPT - MOV A,M - INX H - SHLD FLBFPT - CMP B - JNZ NOMACH - DCR C - JNZ NMCOM1 - MVI A,1 - STA MATCH - POP B! POP H - RET -NOMACH: XRA A - STA MATCH - POP B! POP H - RET -* -* -* -CHR3: ;TAKES 3 ASCII CHARS FROM A,B,C (SEQ.) & CONVERTS THEM - ; TO A RADIX50 WORD IN R50NUM - PUSH H - PUSH D - CALL ASCR50 ;CONVERT TO RAD50 CHAR - MOV L,A - MVI H,0 - CALL X50 - CALL X50 ;MULTIPLY HL BY 50**2 (OCTAL) - SHLD R50NUM ;C1*50**2 - MOV A,B - CALL ASCR50 - MOV L,A - MVI H,0 - CALL X50 ;C2*50Q - XCHG - LHLD R50NUM - DAD D - SHLD R50NUM ;C1*50**2+C2*50 - MOV A,C - CALL ASCR50 - MOV L,A - MVI H,0 - XCHG - LHLD R50NUM - DAD D - SHLD R50NUM ;C1*50**2+C2*50+C3 - POP D - POP H - RET -* -ASCR50: ;CONVERTS AN ASCII CHAR TO A BASIC RADIX50 CHAR(RET IN A) - CPI 20H - JNZ ASC1 - XRA A - RET -ASC1: CPI '$' - JNZ ASC2 - MVI A,1BH - RET -ASC2: CPI '.' - JNZ ASC3 - MVI A,1CH - RET -ASC3: CPI 'A' - JM ASC4 - CPI 5BH - JP ILLCHR - SUI 40H - RET -ASC4: CPI '0' - JM ILLCHR - CPI 3AH - JP ILLCHR - SUI 12H - RET -ILLCHR: LXI H,M5 ;NON-RAD50 CHAR-TRY AGAIN - CALL MSG - JMP AGAIN -* -X50: ;MULTIPLY HL BY 50Q & RETURN IN HL - PUSH B - PUSH D - MVI B,3 -X50A: MOV A,L - ADD A - MOV L,A - MOV A,H - RAL - MOV H,A - DCR B - JNZ X50A - SHLD X8 - MVI B,2 -X50B: MOV A,L - ADD A - MOV L,A - MOV A,H - RAL - MOV H,A - DCR B - JNZ X50B - XCHG - LHLD X8 - DAD D - POP D - POP B - RET -GETNAM: JMP BEGIN -* -*BUFFER:* -NAMBUF: DS 25 -* -* -BEGIN: MVI A,24 - STA CONBUF - MVI C,RCONBF - LXI D,CONBUF - CALL BDOS - LXI H,CONBUF+1 - LDA CNTMSK - MOV D,A - MOV A,M - STA COUNT - CMP D - JP SYNERR - INX H - LXI B,NAMBUF - LDA COUNT2 - MOV D,A - MVI E,0 -MOVCHR: MOV A,M - CPI '.' - JZ DOT - DCR D - JZ SYNERR - STAX B - INX B - INX H - INR E - JMP MOVCHR -DOT: DCR D - JZ GETEXT - MVI A,20H -DOT1: STAX B - INX B - DCR D - JNZ DOT1 -GETEXT: MVI A,'.' - STAX B - INR E - LDA COUNT - SUB E - CPI 4 - JP SYNERR - MOV D,A - MVI A,3 - SUB D - INR A - MOV E,A - CPI 4 - JZ GTEXT2 -GTEXT1: INX H - INX B - MOV A,M - STAX B - DCR D - JNZ GTEXT1 -GTEXT2: DCR E - JZ PUT$ - MVI A,20H - INX B - STAX B - JMP GTEXT2 -PUT$ INX B - MVI A,'$' - STAX B - RET -SYNERR: CALL CRLF - LXI H,M7 ;SYNTAX ERROR - CALL MSG - JMP AGAIN -* -* -* -MAIN: LXI H,SIGNON ;THIS PROGRAM... - CALL MSG - LXI H,M18 ;ZERO DEC DISK(Y/N)? - CALL MSG - CALL CHIN - CPI 'Y' - JNZ AGAIN - LXI H,M19 ;ARE YOU SURE(Y/N)? - CALL MSG - CALL CHIN - CPI 'Y' - JNZ AGAIN - LXI H,M0 ;PLACE DESTINATION... - CALL MSG -STDIR1: LXI H,M14 ;IS DEC DISK INTERLEAVED? - CALL MSG - CALL CHIN - CPI 'Y' - JNZ STDIR2 - MVI A,1 - STA INTLEV - JMP SETDIR -STDIR2: CPI 'N' - JNZ STDIR1 - XRA A - STA INTLEV -SETDIR: LXI H,4 - SHLD HDWD1 ;SEGMENTS AVAILABLE=4 - LXI H,0 - SHLD HDWD2 ;NEXT SEGMENT=0 - SHLD HDWD4 ;EXTRA WORDS/ENTRY=0 - INX H - SHLD HDWD3 ;HIGHEST OPEN SEG.=1 - LXI H,000EH - SHLD HDWD5 ;FILES START AT BLOCK 000E - LXI H,0200H - SHLD ENTRYS ;SET SW1 TO EMPTY FILE - LXI H,479 - SHLD ENTRYS+8 ;SET EMPTY LENGTH TO ENTIRE DISK (479 BL) - LXI H,0800H - SHLD ENTRYS+14 ;SET SW2 TO END-OF-SEGMENT - MVI A,0FFH - STA OPFLAG - CALL DIRECT ;WRITE OUT NEW DIRECTORY - JMP FINIS -* -* -AGAIN: CALL CRLF - LXI H,M10 ;CP/M FILENAME.TYP= - CALL MSG - MVI A,9 - STA COUNT2 ;COUNT FOR CP/M'S 8 CHARS +1 - MVI A,13 - STA CNTMSK ;MASK FOR TOO MANY CHARS - CALL GETNAM ;GET NAME FROM OPERATOR INTO NAMBUF & PAD - CALL CRLF - LXI H,NAMBUF ;1ST 3 CHARS - LXI D,FCB+1 ;STORE FILENAME.TYP - MVI C,8 -LOOP1: MOV A,M - STAX D - INX H - INX D - DCR C - JNZ LOOP1 - INX H ;GO PAST '.' - MVI C,3 -LOOP2: MOV A,M - STAX D - INX H - INX D - DCR C - JNZ LOOP2 ;FILENAME.TYPE STORED - MVI C,4 - XRA A -LOOP3: STAX D ;ZERO EX,2 UNUSED BYTES,& RC - INX D - DCR C - JNZ LOOP3 - CALL CRLF - LXI H,M6 ;DEC FILNAM.EXT= - CALL MSG - MVI A,7 - STA COUNT2 ;COUNT FOR DEC'S 6 CHARS +1 - MVI A,11 - STA CNTMSK ;MASK FOR TOO MANY CHARS - CALL GETNAM - CALL CRLF - LXI H,NAMBUF - MOV A,M - INX H - MOV B,M - INX H - MOV C,M - CALL CHR3 - LHLD R50NUM - SHLD FILE ;CONVERT 1ST 3 ASCII CHARS - LXI H,NAMBUF+3 - MOV A,M - INX H - MOV B,M - INX H - MOV C,M - CALL CHR3 - LHLD R50NUM - SHLD NAME ;CONVERT 2ND 3 ASCII CHARS - LXI H,NAMBUF+7 - MOV A,M - INX H - MOV B,M - INX H - MOV C,M - CALL CHR3 - LHLD R50NUM - SHLD EXT -GOON: LXI H,M14 ;IS DEC DISK INTERLEAVED (Y/N)? - CALL MSG - CALL CHIN - CPI 'Y' - JNZ NO2 - MVI A,1 - STA INTLEV ;SET INTERLEAVE FLAG - JMP GOON2 -NO2: CPI 'N' - JNZ GOON - XRA A - STA INTLEV -* -GOON2: CALL CRLF - LXI H,M0 ;PLACE DESTINATION (DEC) DISK ON DRIVE B - CALL MSG - LXI H,M0A ;READY (Y/N)? - CALL MSG - CALL CHIN - CPI 'Y' - JNZ AGAIN -*GET DIRECTORY INTO DRBUFF -* - XRA A - STA OPFLAG ;SET FLAG FOR READ - CALL DIRECT ;READ IN DIRECT. -*DIRECTORY READY-SEARCH FOR END - XRA A - STA ENTCNT ;INIT. ENTRY COUNT - LHLD HDWD5 - SHLD BLKCNT ; " BLOCK COUNT - LHLD ENTRYS - SHLD ENTRY ; " ENTRY POINTER - LXI H,ENTRYS - SHLD BUFFPT ; " BUFFER PT. -DRLOOP: LHLD ENTRY - MVI A,08 - CMP H - CNZ FILBLK ;UPDATE BLKCNT,ETC. - JNZ DRLOOP - LDA ENTCNT - CPI 70 - JNZ DIROK - LXI H,M9 ;?DIR FULL? - CALL MSG - JMP FINIS -DIROK: LHLD BUFFPT - LXI D,0-6 - DAD D ;GO BACK TO LAST FILE LENGTH - MOV E,M - INX H - MOV D,M - XCHG - SHLD LENGTH - XCHG - CALL NEGDE - PUSH H - LHLD BLKCNT - DAD D - SHLD BLKCNT ;SUBTRACT EMPTY FILE LENGTH FROM BLKCNT - POP H - LXI D,0-8 - DAD D - MOV A,M - CPI 02 - JZ DIROK2 - LXI H,M9 - CALL MSG - JMP FINIS -DIROK2: DCX H - SHLD BUFFPT ;LEAVE POINT. IN POS. FOR LATER -* -*DEC DIRECTORY HAS BEEN SET UP-NOW OPEN CP/M FILE FOR INPUT -* - MVI C,SELDSK - MVI E,0 - CALL BDOS - MVI C,OPENF - LXI D,FCB - CALL BDOS - CPI 0FFH - JNZ OPENOK - LXI H,M4 ;FIL NOT FND - CALL MSG - JMP AGAIN -OPENOK: XRA A - STA FCB+32 ;ZERO NEXT RECORD - LHLD BLKCNT - SHLD BLOCKS - CALL TRSEC ;LOAD STARTING LOG. TR & SEC TO VARIABLES - CALL CRLF -* - MVI A,0FFH - STA OPFLAG ;SET TO WRITE ON DISK B -* -* -*CALCULATE BUFFER SIZE -* - LXI H,PRGEND - XCHG - CALL NEGDE - LHLD 6 ;GET BDOS ADDR - DAD D - MVI C,7 -DIV128: MOV A,H - RAR - MOV H,A - MOV A,L - RAR - MOV L,A - DCR C - JNZ DIV128 - MOV A,H - ANI 01 - MOV H,A ;DIFFERENCE/128 IN HL -* -* - DCX H - DCX H - SHLD TOPCNT ;SAVE # OF BUFFERS - LXI H,0 - SHLD RCRDS -* -*BEGIN TRANSFER-SET UP BUFFER POINTER -* -XFER0: LXI H,PRGEND - SHLD XFBFPT - LXI H,0 - SHLD PASSCT - LHLD TOPCNT - SHLD COUNT3 - MVI C,SELDSK - MVI E,0 - CALL BDOS ;SELECT DISK A - LXI D,BUFF - MVI C,SETDMA - CALL BDOS ;SET DMA TO DEFAULT BUFFER - LXI D,0 -* -* -XFER: LHLD XFBFPT - DAD D - SHLD XFBFPT - MVI C,READF - LXI D,FCB - CALL BDOS - CPI 255 - JZ CPMERR - CPI 1 - JZ EOFFND - MVI C,80H - LHLD XFBFPT - LXI D,BUFF -XFER3: LDAX D - CPI 1AH - JZ EOF - MOV M,A - INX D - INX H - DCR C - JNZ XFER3 - LHLD PASSCT - INX H - SHLD PASSCT - LHLD RCRDS - INX H - SHLD RCRDS - LXI D,128 - LHLD COUNT3 - CALL DCR16 - SHLD COUNT3 - JC XFER -* -*OUT OF BUFFER ROOM-WRITE OUT BUFFER -* - LHLD TOPCNT - SHLD COUNT4 ;DO ALL SECTORS IN BUFFER - LXI H,PRGEND - SHLD XFBFPT - MVI C,SELDSK - MVI E,1 - CALL BDOS - LXI D,0 -* -XFER1: LHLD XFBFPT - DAD D - SHLD XFBFPT - XCHG - MVI C,SETDMA - CALL BDOS - CALL RDWRT - CALL REGMOD - LXI D,128 - LHLD COUNT4 - CALL DCR16 - SHLD COUNT4 - JC XFER1 -* - JMP XFER0 -* -*EOF CHAR FOUND-CHANGE IT & REST OF BUFFER TO 00'S -* -EOF: XRA A - MOV M,A - INX H - DCR C - JNZ EOF+1 - LHLD RCRDS - INX H - SHLD RCRDS - LHLD PASSCT - INX H - SHLD PASSCT -* -*WRITE OUT BUFFER -* -EOFFND: LXI H,PRGEND - SHLD XFBFPT - LHLD PASSCT - DCX H - SHLD COUNT4 - MVI C,SELDSK - MVI E,1 - CALL BDOS - LXI D,0 -* -XFER2: LHLD XFBFPT - DAD D - SHLD XFBFPT - XCHG - MVI C,SETDMA - CALL BDOS - CALL RDWRT - CALL REGMOD - LXI D,128 - LHLD COUNT4 - CALL DCR16 - SHLD COUNT4 - JC XFER2 -* -*FILE WRITTEN OUT-NOW CALC. # OF BLOCKS,ETC. -* -* - LHLD RCRDS - CALL DIV4 ;DIVIDE RCRDS BY 4 TO GET BLOCKS - CPI 0 - JZ NOXTRA - CPI 4 - JM XTRA - LXI H,M16 ;DIV4 ERROR - CALL MSG - JMP FINIS -XTRA: INX H -NOXTRA: SHLD BLKNUM - STA EXTRA -* -*NOW WRITE "EXTRA" SECTORS OF 00'S (TO FILL PHYSICAL BLOCK) -* - MVI C,SELDSK - MVI E,1 - CALL BDOS - LDA EXTRA - CPI 0 - JZ NEXTRA - MOV B,A - MVI A,4 - SUB B - MOV B,A ;#OF SECT. TO B - XRA A - LXI H,BUFF - MVI C,80H -BFLOOP: MOV M,A - INX H - DCR C - JNZ BFLOOP ;FILL BUFFER W/00 - PUSH B ;SAVE EXTRA COUNT IN B - LXI D,BUFF - MVI C,SETDMA - CALL BDOS ;SET DMA TO BUFF - POP B -BFLOP1: CALL RDWRT - CALL REGMOD - DCR B - JNZ BFLOP1 ;DO B TIMES -* -NEXTRA: LHLD BLKNUM - XCHG - CALL NEGDE - LHLD LENGTH - DAD D - JC LNTHOK - LXI H,M17 ;FILE WON'T FIT - CALL MSG - JMP FINIS -LNTHOK: SHLD LENGTH ;SAVE NEW EMPTY LENGTH -* -* -*CAN CLOSE DEC FILE NOW -* -CLOSE: LHLD BUFFPT ;HL PT. @ NEW FILE SW - INX H - MVI A,04 - MOV M,A ;CHANGE SW TO PERM. FILE - INX H - LDA FILE ;PUT NEW FILNAM.EXT IN ENTRY - MOV M,A - INX H - LDA FILE+1 - MOV M,A - INX H - LDA NAME - MOV M,A - INX H - LDA NAME+1 - MOV M,A - INX H - LDA EXT - MOV M,A - INX H - LDA EXT+1 - MOV M,A - INX H - LDA BLKNUM ;PUT NEW FILE LENGTH IN ENTRY - MOV M,A - INX H - LDA BLKNUM+1 - MOV M,A - INX H - INX H - INX H ;HL PT.@ DATE - XRA A - MOV M,A - INX H - MOV M,A ;ZERO DATE - INX H - MOV M,A ;SET UP NEXT ENTRY (EMPTY) - INX H - MVI A,02 - MOV M,A - LXI D,7 - DAD D ;PT.@ NEW EMPTY FILE LENGTH - LDA LENGTH - MOV M,A - INX H - LDA LENGTH+1 - MOV M,A - LXI D,5 - DAD D ;HL PT.@ NEW EOS SW - XRA A - MOV M,A - INX H - MVI A,08 - MOV M,A ;WRITE END OF SEGMENT CODE -* -*DIRECTORY IS MODIFIED-NOW WRITE IT ON DEC DISK - MVI A,0FFH - STA OPFLAG ;TO BE SURE - CALL DIRECT - JMP FINIS -* -* -* -*SUBROUTINES -* -REGMOD: ;MODIFY DRIVE B REGISTERS AFTER SECTOR READ - LDA SECTOR - CPI 26 - JZ RM1 - INR A - STA SECTOR - RET -RM1: MVI A,1 - STA SECTOR - LDA TRACK - INR A - STA TRACK - CPI 75 - RM ;RET IF LESS THAN 75 - LXI H,M17 - CALL MSG - JMP FINIS -* -DCR16: ;DECREMENT HL BY 1 & SET FLAG C IF RESULT NOT ZERO - ; NC IF RESULT 0 - PUSH D - LXI D,0FFFFH ;-1 - DAD D - POP D - RET -* -DIV4: ;DIVIDES HL BY 4-RESULT IN HL W/ REM. IN A - PUSH B - MVI C,0 - MVI B,2 -DIV4A: MOV A,H - RAR - MOV H,A - MOV A,L - RAR - MOV L,A - MOV A,C - RAR - MOV C,A - DCR B - JNZ DIV4A - MOV A,H - ANI 3FH ;STRIP EXTRA BITS - MOV H,A - MOV A,C - RAR - RAR - RAR - RAR - RAR - RAR - ANI 3 ;STRIP EXTRA BITS - POP B - RET -* -NEGDE: ;NEGATE (2'S COMP.) DE REGISTER - PUSH PSW - MOV A,D - CMA - MOV D,A - MOV A,E - CMA - MOV E,A - INX D - POP PSW - RET -FILBLK: ;UPDATE BLOCK COUNT & SET UP ENTRIES - ; CHANGE PERM SW TO EMPTY SW IF NAMES MATCH - PUSH PSW - MVI A,4 - CMP H - JNZ FLBLK1 - LHLD BUFFPT - INX H - INX H - MOV A,M - STA FILELO - INX H - MOV A,M - STA FILEHI - INX H - MOV A,M - STA NAMELO - INX H - MOV A,M - STA NAMEHI - INX H - MOV A,M - STA EXTLO - INX H - MOV A,M - STA EXTHI - CALL NAMCOM - LDA MATCH - RAR - JC MTCHES - LXI D,0-7 - DAD D - SHLD BUFFPT - JMP FLBLK1 -MTCHES: LXI D,0-6 - DAD D ;PTER @ SW LO BYTE - MVI A,2 - MOV M,A ;CHANGE SW TO EMPTY FILE - DCX H - SHLD BUFFPT -FLBLK1: LHLD BUFFPT - LXI D,8 - DAD D ;PT.@ LENGTH BYTE1 - MOV E,M - INX H - MOV D,M - PUSH H - LHLD BLKCNT - DAD D - SHLD BLKCNT - POP H - LXI D,5 - DAD D ;PT.@NEXT ENTRY BYTE1 - SHLD BUFFPT - MOV A,M - STA ENTRY - INX H - MOV A,M - STA ENTRY+1 - LDA ENTCNT - INR A - STA ENTCNT ;INR ENTRY COUNT - POP PSW - RET -* -CMP16: ;COMPARES HL &DE & SETS USUAL FLAGS - MOV A,H - CMP D - RNZ - MOV A,L - CMP E - RET -* -* -CPMERR: LXI H,M12 ;CP/M WRITE ERROR - CALL MSG - JMP FINIS -* -* -FINIS: LXI H,M15 ;ANOTHER TRANSFER? - CALL MSG - CALL CHIN - CPI 'Y' - JZ AGAIN - JMP 0 ;REBOOT CP/M AND GO TO IT -* -* -*VARIABLES -INTLEV: DS 1 ;INTERLEAVE FLAG -OPFLAG: DS 1 ;OPERATION FLAG- 0>READ,FF>WRITE -EXTRA: DS 1 ;# OF EXTRA SECTORS TO XFER -BLKNUM: DS 2 ;LENGTH OF NEW FILE -ENTCNT: DS 1 ;# OF ENTRIES IN DEC DIRECTORY -X2: DS 2 ;HL*2 -TOPCNT: DS 2 ;# OF BUFFERS IN MEMORY SPACE -XFBFPT: DS 2 ;TRANSFER BUFFER POINTER -PASSCT: DS 2 ;PASS COUNT IN BUFFER -COUNT3: DS 2 ;COUNTER -COUNT4: DS 2 ; " -RCRDS: DS 2 ;#OF FULL SECTORS TO TRANSFER -BSECT: DS 1 ;NEW PHYSICAL SECTOR -CNTMSK: DS 1 ;COUNT MASK (IN GETNAM) -COUNT2: DS 1 ;SECOND UTILITY COUNTER -R50NUM: DS 2 ;RADIX 50 CONVERSION OF 3 ASCII CHARS -X8: DS 2 ;HL*8 -ENTRY: DS 2 ;ENTRY STATUS WORD POINTER -BLKCNT: DS 2 ;BLOCK COUNT (UPDATED EVERY ENTRY) -BLOCKS: DS 2 ;# OF BLOCKS TO FILE (VALID ONLY IF FOUND) -LENGTH: DS 2 ;LENGTH OF FILE FOUND (IN BLOCKS) -TRACK: DS 1 ;TRACK OF FOUND FILE -SECTOR: DS 1 ;SECTOR OF FOUND FILE -FLBFPT: DS 2 ;FILE BUFFER POINTER -FLNMPT: DS 2 ;FILE NAME POINTER -MATCH: DS 1 ;MATCH FLAG -FILELO: DS 1 ;PERM FILE NAME STORAGE -FILEHI: DS 1 -NAMELO: DS 1 -NAMEHI: DS 1 -EXTLO: DS 1 -EXTHI: DS 1 -FILE: DS 2 ;FILE NAME -NAME: DS 2 ; & EXT. OF -EXT: DS 2 ; REQUESTED FILE (DEC) -BTRACK: DS 1 ;PHYSICAL TRACK -COUNT: DS 1 ;UTILITY COUNTER LOCATION -BUFFPT: DS 2 ;DIRECTORY BUFFER POINTER -DRBUFF: ;DIRECTORY BUFFER -HDWD1: DS 2 ;SEGMENTS AVAILABLE -HDWD2: DS 2 ;NEXT SEGMENT -HDWD3: DS 2 ;HIGHEST OPEN SEGMENT -HDWD4: DS 2 ;EXTRA WORDS/ENTRY -HDWD5: DS 2 ;FILE STARTING BLOCK -ENTRYS: DS 1014 ;ENTRIES -ENDBUF: DS 1 -* -* -*MESSAGES -* -SIGNON: DB 0DH,0AH,'THIS PROGRAM TRANSFERS A FILE TO A DEC STANDARD (INTERLEAVED)' - DB 0DH,0AH,'OR A "CONSECUTIVE" FORMATTED DISK FROM THE CP/M SYSTEM DISK',0FFH -M0: DB 0DH,0AH,'PLACE DESTINATION (DEC) DISK ON DRIVE B',0DH,0AH,0FFH -M0A: DB 0DH,0AH,'READY (Y/N)?',0FFH -M1: DB 0DH,0AH,'SEEK ERROR-DISK B',0DH,0AH,0FFH -M2: DB 0DH,0AH,'I/O ERROR ON B',0DH,0AH,0FFH -M3: DB 0DH,0AH,'DIRECTORY ERROR',0DH,0AH,0FFH -M4: DB 0DH,0AH,'?FIL NOT FND?',0DH,0AH,0FFH -M5: DB 0DH,0AH,'NON-RAD50 CHAR-TRY AGAIN',0DH,0AH,0FFH -M6: DB 0DH,0AH,'DEC:FILNAM.EXT=',0FFH -M7: DB 'SYNTAX ERROR',0FFH -M8: DB 0DH,0AH,'?NO EOF?',0FFH -M9: DB 0DH,0AH,'?DIR FULL?',0FFH -M10: DB 0DH,0AH,'CP/M:FILENAME.TYP=',0FFH -M12: DB 0DH,0AH,'CP/M WRITE ERROR',0FFH -M14: DB 'IS DEC DISK INTERLEAVED (Y/N)?',0FFH -M15: DB 0DH,0AH,'ANOTHER TRANSFER (Y/N)?',0FFH -M16: DB 0DH,0AH,'DIV4 ERROR',0FFH -M17: DB 0DH,0AH,'NO ROOM FOR FILE',0FFH -M18: DB 0DH,0AH,0DH,0AH,'ZERO DEC DISK (Y/N)?',0FFH -M19: DB ' ARE YOU SURE (Y/N)?',0FFH -* -BYTBUF: DS 4 ;ISOLATE PROGRAM FROM XFER BUFFER -* -PRGEND EQU $ -* - END - \ No newline at end of file diff --git a/software/CPM/CPM14_MTPUG_02/DECTOCPM.ASM b/software/CPM/CPM14_MTPUG_02/DECTOCPM.ASM deleted file mode 100644 index dc3986c..0000000 --- a/software/CPM/CPM14_MTPUG_02/DECTOCPM.ASM +++ /dev/null @@ -1,1099 +0,0 @@ -*THIS PROGRAM TRANSFERS A FILE FROM A DEC FORMAT DISK TO A -* CP/M FORMAT DISK -* -* -*CP/M DEFINITIONS FOR PRIMITIVES -* -RDCON EQU 1 ;GET CHAR FROM CONSOLE -WRTCON EQU 2 ;TYPE CHAR ON CONSOLE -RDRDR EQU 3 ;GETCHAR FROM PAPER TAPE READER -WRTPCH EQU 4 ;SEND CHAR TO PUNCH -WRTLST EQU 5 ;SEND CHAR TO LIST DEVICE -IOSTAT EQU 7 ;INTERROGATE I/O STATUS (NOT USED HERE) -ALTIO EQU 8 ;ALTER I/O STATUS (NOT USED HERE) -PCONBF EQU 9 ;PRINT CONSOLE BUFFER -RCONBF EQU 10 ;READ CONSOLE BUFFER -CONST EQU 11 ;CHECK CONSOLE STATUS (BIT0 SET IF READY) -LIFTHD EQU 12 ;LIFT DISK HEAD (NOT USED HERE) -RSTDSK EQU 13 ;DMA ADDR TO 80H,SELECT DISK A -SELDSK EQU 14 ;SELECT DISK -OPENF EQU 15 ;OPEN FILE -CLOSEF EQU 16 ;CLOSE FILE -SRCH1 EQU 17 ;SEARCH FOR FIRST FILE OCCURRENCE -SCHNXT EQU 18 ;SEARCH FOR NEXT FILE OCCURRENCE -DELETF EQU 19 ;DELETE FILE -READF EQU 20 ;READ TO BUFFER -WRITEF EQU 21 ;WRITE TO BUFFER -MAKEF EQU 22 ;CREATE A FILE ENTRY -RENAMF EQU 23 ;RENAME A FILE -INTLOG EQU 24 ;INTERROGATE LOGIN VECTOR -INTDSK EQU 25 ;INTERROGATE DISK (RETURNS SELECTED DISK #) -SETDMA EQU 26 ;SET DMA ADDR -INTALL EQU 27 ;INTERROGATE ALLOCATION VECTOR -* -BDOS EQU 0005H ;DOS ENTRY POINT -FCB EQU 5CH ;DEFAULT FILE CONTROL BLOCK ADDRESS -BUFF EQU 80H ;DEFAULT DMA ADDRESS -* - ORG 0100H -* -*SET UP STACK - LXI SP,STKTOP - JMP EXEC -*STACK AREA -STACK: DS 64 -STKTOP EQU $ -* -*VARIABLES -CONBUF: DS 80 -* -EXEC: MVI A,79 - STA CONBUF ;SET FIRST BYTE TO BUFFER LENGTH - JMP MAIN ;JUMP TO MAIN PROGRAM -*SUBROUTINES -PCHAR: ;PRINT CHAR IN REG A - PUSH H! PUSH D! PUSH B ;ENVIRONMENT SAVED - MVI C,WRTCON - MOV E,A - CALL BDOS - POP B! POP D! POP H ;ENVIRONMENT RESTORED - RET -* -CRLF: ;PRINT A CARRIAGE RETURN & LINE FEED - MVI A,0DH - CALL PCHAR - MVI A,0AH - CALL PCHAR - RET -* -PNIB: ;PRINT NIBBLE IN REG A - ANI 0FH ;LOWER 4 BITS - CPI 10 - JNC P10 - ;LESS THAN OR EQUAL TO 9 - ADI '0' - JMP PRN - ;GREATER THAN 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 -* -CHIN: ;GET A CHAR FROM CONSOLE - PUSH H! PUSH D! PUSH B - MVI C,RDCON - CALL BDOS - POP B! POP D! POP H - RET -* -MSG: ;PRINT A MESSAGE POINTED TO BY HL (END OF MESSAGE=0FFH) - MOV A,M - CPI 0FFH - RZ ;RETURN IF END OF MESSAGE - CALL PCHAR - INX H - JMP MSG -* -SETTRK: ;SET TRACK IN C - LHLD 1 - LXI D,27 - DAD D - PCHL -* -SETSEC: LHLD 1 - LXI D,30 - DAD D - PCHL -* -RDSEC: LHLD 1 - LXI D,36 - DAD D - PCHL -* -DISKRD: ;READ FROM DISK B-TRACK IN "TRACK",SECTOR IN "SECTOR" - PUSH B ;SAVE LOGICAL TRACK & SECTOR - LDA TRACK - STA BTRACK - LDA SECTOR - STA BSECT - LDA INTLEV ;GET INTERLEAVE FLAG - ORA A - JZ CONSEC ;0 > CONSECUTIVE SECTORS -* -*INTERLEAVE ALGORITHM FOR STANDARD DEC DISKS -* - PUSH D ;SAVE DMA ADDR - MVI H,0 - LDA BTRACK - MOV L,A - DCX H ;HL=TRACK-1;NOW MULTIPLY BY 6 - MOV A,L - ADD A - MOV L,A - MOV A,H - RAL - MOV H,A - SHLD X2 ;HL*2 -INTLV3: MOV A,L - ADD A - MOV L,A - MOV A,H - RAL - MOV H,A - XCHG - LHLD X2 - DAD D ;HL*6 IN HL -* 6*(TRACK-1) IN HL -* -INTLV0: MOV A,H - ORA A - JNZ INTLV5 - MOV A,L - CPI 26 - JC INTLV4 -INTLV5: LXI D,0-26 - DAD D - JMP INTLV0 -INTLV4: LDA BSECT - DCR A ;SHIFT SECTOR DOWN (0-25) - PUSH PSW - ADD A - MOV E,A ;SAVE S2 - POP PSW - CPI 13 - MOV A,E ;GET S2 BACK TO ACC. - JM INTLV2 - INR A -INTLV2: ADD L ;ADD BIAS -INTLV1: SUI 26 - JP INTLV1 - ADI 27 - STA BSECT ;NEW PHYSICAL SECTOR TO BSECT - POP D ;RESTORE DMA ADDR -CONSEC: LDA BSECT - MOV C,A - CALL SETSEC - LDA BTRACK - MOV C,A - CALL SETTRK - CALL RDSEC - POP B - RET -* -GETDIR: ;GET DIRECTORY SEGMENT 1 INTO THE DIRECTORY BUFFER - ; ASSUME FILE WILL BE IN SEGMENT 1 - MVI C,SELDSK - MVI E,1 - CALL BDOS ;SEL DISK B - MVI A,2 - STA COUNT - LXI D,0 - MVI A,01H - STA TRACK - MVI A,19H - STA SECTOR - LXI H,DRBUFF - SHLD BUFFPT ;INIT. BUFFPT -GTDIR1: LHLD BUFFPT - DAD D - SHLD BUFFPT - XCHG - MVI C,SETDMA - CALL BDOS - CALL DISKRD ;READ SECTOR FROM DISK - LXI D,128 - MVI A,1AH - STA SECTOR - LDA COUNT - DCR A - STA COUNT - JNZ GTDIR1 ;READ IN FIRST 2 SECTORS - MVI A,6 - STA COUNT - MVI A,02 - STA TRACK - DCR A - STA SECTOR -GTDIR2: LXI D,128 ;LENGTH OF A SECTOR - LHLD BUFFPT - DAD D - SHLD BUFFPT - XCHG ;DMA ADDR > DE - MVI C,SETDMA - CALL BDOS - CALL DISKRD - LDA SECTOR - INR A - STA SECTOR - LDA COUNT - DCR A - STA COUNT - JNZ GTDIR2 - RET -* -* -TRSEC: ;CALCULATES TR#,SEC# FROM # OF BLOCKS TO FILE - LHLD BLOCKS ;#OF BLOCKS > HL (4 SECTORS/BLOCK) - MVI B,2 -TRSC1: MOV A,L - ADD A - MOV L,A - MOV A,H - RAL - MOV H,A - DCR B - JNZ TRSC1 ;BLOCKS*4 IN HL -* - MVI A,1 - STA TRACK ;INIT. TRACK -TRSC4: LXI D,0FFE6H ;-26 - DAD D - MOV A,H - RAL - JNC TRSC2 - LXI D,1BH - DAD D - JMP TRSC3 -TRSC2: LDA TRACK - INR A - STA TRACK - JMP TRSC4 -TRSC3: MOV A,L - STA SECTOR - RET ;TR# IS IN TRACK,SEC# IS IN SECTOR -* -NAMCOM: ;COMPARES PERM. FILE NAME & EXT. W/ DESIRED FILE NAME - ; & EXT. & SETS FLAG "MATCH" IF SAME - PUSH H - PUSH B - MVI C,6 - LXI H,FILE - SHLD FLNMPT - LXI H,FILELO - SHLD FLBFPT -NMCOM1: LHLD FLNMPT - MOV B,M - INX H - SHLD FLNMPT - LHLD FLBFPT - MOV A,M - INX H - SHLD FLBFPT - CMP B - JNZ NOMACH - DCR C - JNZ NMCOM1 - MVI A,1 - STA MATCH - POP B - POP H - RET -NOMACH: XRA A - STA MATCH - POP B - POP H - RET -* -* -DIRSCH: ;SEARCH DEC DIRECT. FOR FILE ENTRY MATCHING FILNAM.EXT - ; FROM COMMAND -* - CALL GETDIR ;GET DIRECTORY INTO DRBUFF - LHLD HDWD5 ;FILE STARTING BLOCK - SHLD BLKCNT - LHLD ENTRYS - SHLD ENTRY - LXI H,ENTRYS - SHLD BUFFPT -* -DRLOOP: LHLD ENTRY - MVI A,2 - CMP H - JZ EMPTY ;THIS ENTRY AN EMPTY FILE - MVI A,4 - CMP H - JZ PERM ;THIS ENTRY IS A PERMANENT FILE - MVI A,8 - CMP H - JZ ENDDIR ;END OF DIRECTORY - LXI H,M3 ;DIRECTORY ERROR - CALL MSG - JMP FINIS -* -EMPTY: LHLD BUFFPT - LXI D,8 - DAD D - MOV E,M - INX H - MOV D,M ;FILE LENGTH IN DE - PUSH H ;SAVE POINTER - LHLD BLKCNT - DAD D - SHLD BLKCNT ;UPDATE BLOCK COUNT - POP H - LXI D,5 - DAD D ;IGNORE REST OF ENTRY INFO - SHLD BUFFPT - MOV A,M - STA ENTRY - INX H - MOV A,M - STA ENTRY+1 - JMP DRLOOP ;CHECK NEXT ENTRY -* -PERM: LHLD BUFFPT - INX H - INX H - MOV A,M - STA FILELO ;GET FILNAM.EXT FOR COMPARISON - INX H - MOV A,M - STA FILEHI - INX H - MOV A,M - STA NAMELO - INX H - MOV A,M - STA NAMEHI - INX H - MOV A,M - STA EXTLO - INX H - MOV A,M - STA EXTHI ;FILNAM.EXT STORED - CALL NAMCOM ;CHECK THIS ENTRY FOR MATCH - INX H - MOV E,M - INX H - MOV D,M ;FILE LENGTH IN DE - XCHG - SHLD LENGTH ;SAVE FILE LENGTH - XCHG - PUSH H ;SAVE POINTER - LHLD BLKCNT - SHLD BLOCKS ;# OF BLOCKS TO THIS FILE - DAD D - SHLD BLKCNT ;UPDATE BLOCK COUNT - POP H - LDA MATCH - RAR - JC FOUND ;JUMP IF MATCH TO FOUND - LXI D,5 - DAD D ;IGNORE REST OF ENTRY INFO. - SHLD BUFFPT - MOV A,M - STA ENTRY - INX H - MOV A,M - STA ENTRY+1 ;SET UP FOR NEXT ENTRY - JMP DRLOOP ; & GO TO IT -* -ENDDIR: LXI H,M4 ;?FIL NOT FND? - CALL MSG - MVI A,1 - RET -* -FOUND: CALL TRSEC ;CALCULATE TR#,SEC# WHERE FILE BEGINS - CALL CRLF - XRA A - RET -* -CHR3: ;TAKES 3 ASCII CHARS FROM A,B,C (SEQ.) & CONVERTS THEM - ; TO A RADIX50 WORD IN R50NUM - PUSH H - PUSH D - CALL ASCR50 ;CONVERT TO RAD50 CHAR - MOV L,A - MVI H,0 - CALL X50 - CALL X50 ;MULTIPLY HL BY 50**2 (OCTAL) - SHLD R50NUM ;C1*50**2 - MOV A,B - CALL ASCR50 - MOV L,A - MVI H,0 - CALL X50 ;C2*50Q - XCHG - LHLD R50NUM - DAD D - SHLD R50NUM ;C1*50**2+C2*50 - MOV A,C - CALL ASCR50 - MOV L,A - MVI H,0 - XCHG - LHLD R50NUM - DAD D - SHLD R50NUM ;C1*50**2+C2*50+C3 - POP D - POP H - RET -* -ASCR50: ;CONVERTS AN ASCII CHAR TO A BASIC RADIX50 CHAR(RET IN A) - CPI 20H - JNZ ASC1 - XRA A - RET -ASC1: CPI '$' - JNZ ASC2 - MVI A,1BH - RET -ASC2: CPI '.' - JNZ ASC3 - MVI A,1CH - RET -ASC3: CPI 'A' - JM ASC4 - CPI 5BH - JP ILLCHR - SUI 40H - RET -ASC4: CPI '0' - JM ILLCHR - CPI 3AH - JP ILLCHR - SUI 12H - RET -ILLCHR: LXI H,M5 ;NON-RAD50 CHAR-TRY AGAIN - CALL MSG - JMP MAIN -* -X50: ;MULTIPLY HL BY 50Q & RETURN IN HL - PUSH B - PUSH D - MVI B,3 -X50A: MOV A,L - ADD A - MOV L,A - MOV A,H - RAL - MOV H,A - DCR B - JNZ X50A - SHLD X8 - MVI B,2 -X50B: MOV A,L - ADD A - MOV L,A - MOV A,H - RAL - MOV H,A - DCR B - JNZ X50B - XCHG - LHLD X8 - DAD D - POP D - POP B - RET -GETNAM: JMP BEGIN -* -*BUFFER:* -NAMBUF: DS 25 -* -* -BEGIN: MVI A,24 - STA CONBUF - MVI C,RCONBF - LXI D,CONBUF - CALL BDOS - LXI H,CONBUF+1 - LDA CNTMSK - MOV D,A - MOV A,M - STA COUNT - CMP D - JP SYNERR - INX H - LXI B,NAMBUF - LDA COUNT2 - MOV D,A - MVI E,0 -MOVCHR: MOV A,M - CPI '.' - JZ DOT - DCR D - JZ SYNERR - STAX B - INX B - INX H - INR E - JMP MOVCHR -DOT: DCR D - JZ GETEXT - MVI A,20H -DOT1: STAX B - INX B - DCR D - JNZ DOT1 -GETEXT: MVI A,'.' - STAX B - INR E - LDA COUNT - SUB E - CPI 4 - JP SYNERR - MOV D,A - MVI A,3 - SUB D - INR A - MOV E,A - CPI 4 - JZ GTEXT2 -GTEXT1: INX H - INX B - MOV A,M - STAX B - DCR D - JNZ GTEXT1 -GTEXT2: DCR E - JZ PUT$ - MVI A,20H - INX B - STAX B - JMP GTEXT2 -PUT$ INX B - MVI A,'$' - STAX B - RET -SYNERR: CALL CRLF - LXI H,M7 ;SYNTAX ERROR - CALL MSG - JMP AGAIN -* -* -* -MAIN: LXI H,SIGNON ;THIS PROGRAM... - CALL MSG -AGAIN: CALL CRLF - MVI C,SELDSK - MVI E,0 ;SEL. DK A - CALL BDOS - LXI H,M6 ;DEC FILE NAME&EXT= - CALL MSG - MVI A,7 - STA COUNT2 ;COUNT FOR DEC'S 6 CHARS +1 - MVI A,11 - STA CNTMSK ;MASK FOR TOO MANY CHARS - CALL GETNAM ;GET NAME FROM OPERATOR INTO NAMBUF & PAD - CALL CRLF - LXI H,NAMBUF ;1ST 3 CHARS - MOV A,M - INX H - MOV B,M - INX H - MOV C,M - CALL CHR3 - LHLD R50NUM - SHLD FILE - LXI H,NAMBUF+3 ;NEXT 3 CHARS - MOV A,M - INX H - MOV B,M - INX H - MOV C,M - CALL CHR3 - LHLD R50NUM - SHLD NAME - LXI H,NAMBUF+7 ;EXT. (ACCOUNT FOR '.') - MOV A,M - INX H - MOV B,M - INX H - MOV C,M - CALL CHR3 - LHLD R50NUM - SHLD EXT -ASCII: LXI H,M13 ;ASCII(Y/N)? - CALL MSG - CALL CHIN - CPI 'Y' - JNZ NO - XRA A - STA ASCFLG - JMP GOON - CPI 'N' - JNZ ASCII ;WANT EITHER Y OR N -NO: MVI A,1 - STA ASCFLG -GOON: LXI H,M14 ;IS DEC DISK INTERLEAVED (Y/N)? - CALL MSG - CALL CHIN - CPI 'Y' - JNZ NO2 - MVI A,1 - STA INTLEV ;SET INTERLEAVE FLAG - JMP GOON2 -NO2: CPI 'N' - JNZ GOON - XRA A - STA INTLEV -GOON2: MVI A,9 - STA COUNT2 ;COUNT FOR FILENAME+1 - MVI A,13 - STA CNTMSK ;TOTAL CHAR MASK - CALL CRLF - LXI H,M10 ;CP/M FILENAME.TYP= - CALL MSG - CALL GETNAM ;GET CP/M FILENAME.TYP - CALL CRLF - LXI H,NAMBUF - LXI D,FCB+1 ;STORE FILENAME.TYP - MVI C,8 -LOOP1: MOV A,M - STAX D - INX H - INX D - DCR C - JNZ LOOP1 - INX H ;GO PAST '.' - MVI C,3 -LOOP2: MOV A,M - STAX D - INX H - INX D - DCR C - JNZ LOOP2 ;FILENAME.TYP STORED - MVI C,4 - XRA A -LOOP3: STAX D - INX D - DCR C - JNZ LOOP3 ;ZERO EX,2 UNUSED BYTES,RC -* - LXI H,M0 ;PLACE SOURCE (DEC) DISK ON DRIVE B - CALL MSG -NRDY: LXI H,M0A ;READY (Y/N)? - CALL MSG - CALL CHIN - CPI 'Y' - JNZ AGAIN -* -*DELETE OLD FILE BY SAME NAME IF IT EXISTS - MVI C,DELETF - LXI D,FCB - CALL BDOS -*CREATE A FILE FILENAME.TYP REQUESTED - MVI C,MAKEF - LXI D,FCB - CALL BDOS - CPI 0FFH - JNZ MAKEOK - LXI H,M11 ;CP/M DIRECTORY FULL - CALL MSG - JMP FINIS -MAKEOK: XRA A - STA FCB+32 ;ZERO RECORD COUNT -* - CALL DIRSCH - CPI 0 - JZ OPENOK - MVI C,SELDSK - MVI E,0 - CALL BDOS ;SEL DISK A - LXI D,FCB - MVI C,DELETF - CALL BDOS ;IF FILE NOT FOUND, DELETE OPENED FILE - JMP AGAIN ; AND START AGAIN -* -*READY FOR DATA TRANSFER FROM DEC DISK TO CP/M DISK -*IF FILE TO BE TRANSFERRED IS AN ASCII FILE,THE LAST BLOCK -*WILL BE SEARCHED FOR A DEC EOF CHAR AND 1AH (^Z=CP/M EOF) -*WILL BE INSERTED. OTHERWISE ALL BLOCKS WILL BE -*TRANSFERRED AS IS. -* -*CALCULATE BUFFER SIZE -* -OPENOK: LXI H,PRGEND - XCHG - CALL NEGDE - LHLD 6 ;GET BDOS ADDR - DAD D - MVI C,7 -DIV128: MOV A,H - RAR - MOV H,A - MOV A,L - RAR - MOV L,A - DCR C - JNZ DIV128 - MOV A,H - ANI 1 - MOV H,A ;DIFFERENCE/128 IN HL -* - LXI D,0-5 - DAD D - SHLD TOPCNT ;SAVE # OF BUFFERS (+ MARGIN) -* -*CALCULATE NUMBER OF SECTORS FROM NUMBER 0F BLOCKS -* - LHLD LENGTH - LXI D,1 - CALL CMP16 - JNZ SECTS - LXI D,0-128 - LXI H,PRGEND - DAD D - SHLD XFBFPT - LXI H,0 - SHLD PASSCT - LDA ASCFLG - ORA A - JZ LSTBLK - LXI H,3 - SHLD SECTRS - JMP DATFIL -* -* -SECTS: MVI B,2 -LNTHX4: MOV A,L - ADD A - MOV L,A - MOV A,H - RAL - MOV H,A - DCR B - JNZ LNTHX4 - DCX H - SHLD SECTRS ;SAVE TOTAL # OF SECTORS -* - LDA ASCFLG - ORA A - JNZ DATFIL - LXI D,0-4 - DAD D - SHLD SECTRS ;SUB 4 FROM SECTRS IF ASCII (FOR MONITORING) -* -DATFIL: LXI H,PRGEND - SHLD XFBFPT - LXI H,0 - SHLD PASSCT - LHLD TOPCNT - SHLD COUNT3 - MVI C,SELDSK - MVI E,1 - CALL BDOS - LXI D,0 -* -XFER1: LHLD XFBFPT - DAD D - SHLD XFBFPT - XCHG - MVI C,SETDMA - CALL BDOS - CALL DISKRD ;READ A SECTOR,STORE IN LARGE BUFFER - CALL REGMOD - LHLD PASSCT - INX H - SHLD PASSCT - LHLD SECTRS - CALL DCR16 - SHLD SECTRS - JNC LSTBLK ;JUMP OUT IF DONE WITH ALL BUT LAST BLOCK - LXI D,128 - LHLD COUNT3 - CALL DCR16 - SHLD COUNT3 - JC XFER1 -* -*BUFFER FULL-WRITE IT OUT -* - LXI H,PRGEND - SHLD XFBFPT - LHLD TOPCNT - SHLD COUNT3 - MVI C,SELDSK - MVI E,0 - CALL BDOS ;SELECT DISK A - LXI D,0 -* -XFER2: LHLD XFBFPT - DAD D - SHLD XFBFPT - XCHG - MVI C,SETDMA - CALL BDOS ;SET DMA ADDR - MVI C,WRITEF - LXI D,FCB - CALL BDOS ;WRITE OUT SECTOR - CPI 0 - JNZ CPMERR - LXI D,128 - LHLD COUNT3 - CALL DCR16 - SHLD COUNT3 - JC XFER2 -* -*BUFFER WRITTEN OUT-GO BACK & GET MORE DATA -* - JMP DATFIL -* -*ALL BUT LAST BLOCK HAS BEEN WRITTEN-CHECK LAST 4 SECTORS FOR EOF -* -LSTBLK: MVI A,4 - STA COUNT3 - LDA ASCFLG - ORA A - JZ LSTBL1 - LHLD LENGTH - LXI D,1 - CALL CMP16 - JNZ CLOSE ;IF NON-ASCII FILE >1 BLOCK, CLOSE IT - LXI H,PRGEND - SHLD XFBFPT - MVI C,SELDSK - MVI E,0 - CALL BDOS ;SEL DISK A - LXI D,0 -* -XFER5: LHLD XFBFPT - DAD D - SHLD XFBFPT - XCHG - MVI C,SETDMA - CALL BDOS - MVI C,WRITEF - LXI D,FCB - CALL BDOS ;WRITE SECTOR - CPI 0 - JNZ CPMERR - LXI D,128 - LDA COUNT3 - DCR A - STA COUNT3 - JNZ XFER5 - JMP CLOSE ;GO CLOSE 1 BLOCK DATA FILE -* -* -LSTBL1: MVI C,SELDSK - MVI E,1 - CALL BDOS ;SEL DISK B - LXI D,128 -* -* -XFER3: LHLD XFBFPT - DAD D - SHLD XFBFPT - XCHG - MVI C,SETDMA - CALL BDOS - CALL DISKRD - CALL REGMOD - MVI D,80H - LHLD XFBFPT -CONT: MOV A,M - CPI 0 ;DEC EOF 1 - JZ EOF - CPI 10H ;DEC EOF 2 - JZ EOF - INX H - DCR D - JNZ CONT -*NO EOF IN THIS BUFFER- INC. PASS COUNT & REPEAT - LHLD PASSCT - INX H - SHLD PASSCT - LXI D,128 - LDA COUNT3 - DCR A - STA COUNT3 - JNZ XFER3 -*ASSUME FILE ENDS ON PHYSICAL BOUNDARY-WRITE OUT BUFFER - JMP EOFFND -* -*EOF CHAR FOUND-CHANGE REST OF BUFFER TO 1AH -* -EOF: MVI A,1AH - MOV M,A - INX H - DCR D - JNZ EOF+2 - LHLD PASSCT - INX H - SHLD PASSCT ;INC PASS COUNT -* -*WRITE OUT LAST BUFFER -* -EOFFND: LXI H,PRGEND - SHLD XFBFPT - LHLD PASSCT - DCX H - SHLD COUNT3 - MVI C,SELDSK - MVI E,0 - CALL BDOS ;SEL DISK A - LXI D,0 -* -XFER4: LHLD XFBFPT - DAD D - SHLD XFBFPT - XCHG - MVI C,SETDMA - CALL BDOS ;SET DMA ADDR - MVI C,WRITEF - LXI D,FCB - CALL BDOS ;WRITE OUT SECTOR - CPI 0 - JNZ CPMERR - LXI D,128 - LHLD COUNT3 - CALL DCR16 - SHLD COUNT3 - JC XFER4 -* -*CAN CLOSE CP/M FILE NOW -CLOSE: MVI C,SELDSK - MVI E,0 - CALL BDOS ;SEL DISK A - MVI C,CLOSEF - LXI D,FCB - CALL BDOS - CPI 0FFH - JNZ FINIS - LXI H,M9 ;CLOSE ERROR - CALL MSG - JMP FINIS -* -*SUBROUTINES -* -REGMOD: ;MODIFY DRIVE B REGISTERS AFTER SECTOR READ - LDA SECTOR - CPI 26 - JZ RM1 - INR A - STA SECTOR - RET -RM1: MVI A,1 - STA SECTOR - LDA TRACK - INR A - STA TRACK - RET -* -CMP16: ;COMPARES HL & DE & SETS USUAL FLAGS - MOV A,H - CMP D - RNZ - MOV A,L - CMP E - RET -* -NEGDE: ;NEGATE DE REGISTER (2'S COMP) - PUSH PSW - MOV A,D - CMA - MOV D,A - MOV A,E - CMA - MOV E,A - INX D - POP PSW - RET -* -DCR16: ;DECREMENT HL BY 1 & SET FLAG C IF RESULT >= 0 - ; NC IF RESULT < 0 - PUSH D - LXI D,0FFFFH ;-1 - DAD D - POP D - RET -* -CPMERR: LXI H,M12 ;CP/M WRITE ERROR - CALL MSG - JMP FINIS -* -* -FINIS: LXI H,M15 ;ANOTHER TRANSFER? - CALL MSG - CALL CHIN - CPI 'Y' - JZ AGAIN - JMP 0 ;REBOOT CP/M & GO TO IT -* -* -*VARIABLES -TOPCNT: DS 2 ;TOTAL # OF BUFFERS IN MEMORY SPACE -XFBFPT: DS 2 ;TRANSFER BUFFER POINTER -PASSCT: DS 2 ;PASS COUNT -COUNT3: DS 2 ;COUNTER -INTLEV: DS 1 ;INTERLEAVE FLAG -X2: DS 2 ;HL*2 -SECTRS: DS 2 ;#OF FULL SECTORS TO TRANSFER -BSECT: DS 1 -ASCFLG: DS 1 ;ASCII FLAG -CNTMSK: DS 1 ;COUNT MASK (IN GETNAM) -COUNT2: DS 1 ;SECOND UTILITY COUNTER -R50NUM: DS 2 ;RADIX 50 CONVERSION OF 3 ASCII CHARS -X8: DS 2 ;HL*8 -FILELO: DS 1 ;PERMANENT FILE NAME & EXT. STORAGE -FILEHI: DS 1 -NAMELO DS 1 -NAMEHI DS 1 -EXTLO DS 1 -EXTHI DS 1 ;END OF PERM. NAME STORAGE -ENTRY: DS 2 ;ENTRY STATUS WORD POINTER -BLKCNT: DS 2 ;BLOCK COUNT (UPDATED EVERY ENTRY) -BLOCKS: DS 2 ;# OF BLOCKS TO FILE (VALID ONLY IF FOUND) -LENGTH: DS 2 ;LENGTH OF FILE FOUND (IN BLOCKS) -MATCH: DS 1 ;FILE FOUND FLAG (SET IF FOUND) -TRACK: DS 1 ;TRACK OF FOUND FILE -SECTOR: DS 1 ;SECTOR OF FOUND FILE -FILE: DS 2 ;FILE NAME -NAME: DS 2 ; & EXT. OF -EXT: DS 2 ; REQUESTED FILE (DEC) -FLNMPT: DS 2 ;FILE NAME POINTER -FLBFPT: DS 2 ;PERM. FILE NAME POINTER -BTRACK: DS 1 ;PHYSICAL TRACK -ERRCNT: DS 1 ;ERROR COUNT -COUNT: DS 1 ;UTILITY COUNTER LOCATION -BUFFPT: DS 2 ;DIRECTORY BUFFER POINTER -DRBUFF: ;DIRECTORY BUFFER -HDWD1: DS 2 ;SEGMENTS AVAILABLE -HDWD2: DS 2 ;NEXT SEGMENT -HDWD3: DS 2 ;HIGHEST OPEN SEGMENT -HDWD4: DS 2 ;EXTRA WORDS/ENTRY -HDWD5: DS 2 ;FILE STARTING BLOCK -ENTRYS: DS 1014 ;ENTRIES -ENDBUF: DS 1 -* -* -*MESSAGES -* -SIGNON: DB 0DH,0AH,'THIS PROGRAM TRANSFERS A FILE FROM A DEC STANDARD (INTERLEAVED)' - DB 0DH,0AH,'OR A "CONSECUTIVE" FORMATTED DISK TO THE CP/M SYSTEM DISK',0FFH -M0: DB 0DH,0AH,'PLACE SOURCE (DEC) DISK ON DRIVE B',0DH,0AH,0FFH -M0A: DB 0DH,0AH,'READY (Y/N)?',0FFH -M3: DB 0DH,0AH,'DIRECTORY ERROR',0DH,0AH,0FFH -M4: DB 0DH,0AH,'?FIL NOT FND?',0DH,0AH,0FFH -M5: DB 0DH,0AH,'NON-RAD50 CHAR-TRY AGAIN',0DH,0AH,0FFH -M6: DB 0DH,0AH,'DEC:FILNAM.EXT=',0FFH -M7: DB 'SYNTAX ERROR',0FFH -M8: DB 0DH,0AH,'?NO EOF?',0FFH -M9: DB 0DH,0AH,'CLOSE ERROR',0FFH -M10: DB 0DH,0AH,'CP/M:FILENAME.TYP=',0FFH -M11: DB 0DH,0AH,'CP/M DIRECTORY FULL',0FFH -M12: DB 0DH,0AH,'CP/M WRITE ERROR',0FFH -M13: DB 'ASCII(Y/N)?',0FFH -M14: DB 0DH,0AH,'IS DEC DISK INTERLEAVED (Y/N)?',0FFH -M15: DB 0DH,0AH,'ANOTHER TRANSFER (Y/N)?',0FFH -* -* -PAD: DS 4 -* -PRGEND EQU $ -* -* -* - END - \ No newline at end of file diff --git a/software/CPM/CPM14_MTPUG_02/HEATH.DOC b/software/CPM/CPM14_MTPUG_02/HEATH.DOC deleted file mode 100644 index 4731e43..0000000 --- a/software/CPM/CPM14_MTPUG_02/HEATH.DOC +++ /dev/null @@ -1,72 +0,0 @@ -Program Name: Heath.Pas -Author: Jerome F. Jankura - -Description: - Heath.Paó  provideó aî interfacå betweeî thå Heath/Zenitè 1¹ -terminaì anä Pascaì programs® Procedureó provideä include: - - REVERSEº Thió procedurå ió invokeä tï puô thå H-1¹ intï itó -        reverså  (Blacë  characters¬  whitå  background©  displaù -        mode. - -     NORMALº  Thió  procedurå ió invokeä tï puô thå H-1¹ iî  thå -        normal (Black background, white characters) display mode. - - PUT25º  Thió procedurå enableó thå twenty-fiftè linå oî thå -        H-1¹  terminaì anä positionó thå cursoò aô thå  beginninç -        of the twenty-fifth line. - - SAVECURSORº  Thió procedurå instructó thå H-1¹ tï storå thå -        currenô  cursoò positioî iî itó  internaì  memory®  Thió -        commanä ió useä bù thå procedurå whicè enableó writinç tï -        the twenty-fifth line on the terminal. - - RESTORECURSORº  Thió  procedurå restoreó thå cursoò tï  thå -        positioî  whicè  waó storeä bù thå SAVECURSOÒ  procedure® -        Thió procedurå musô bå invokeä bù thå useò prograí  afteò -        writinç  thå twenty-fiftè linå beforå normaì CRÔ  displaù -        will occur. - - PUTCURSORº  Thió procedurå allowó positionihç thå cursoò aô -        anù  locatioî oî thå CRÔ screen®  Thå procedurå  acceptó -        twï  parameteró  (integer)®  Thå firsô ió  thå  verticaì -        positioî  oæ thå cursor®  Acceptablå valueó rangå froí ± -        tï 25®  Thå seconä parameteò ió thå horizontaì  positioî -        oæ thå cursor® Acceptablå valueó rangå froí ± tï 80® Nï -        range checking is performed in the interests of speed. - - GETCURSORº  Thió  procedurå returnó thå coordinateó oæ  thå -        currenô positioî oæ thå cursor®  GETCURSOÒ mighô bå useä -        bù  menõ  driveî  softwarå tï returî thå  selectioî  codå -        requested by an operator. - - CLEARLINEº  Thió procedurå eraseó thå currenô linå froí thå -        screeî  anä positionó thå cursoò aô thå beginninç oæ  thå -        current line. - - CLEARSCREENº  Thió  procedurå eraseó thå entirå screeî  anä -        puts the cursor in the home position. - - CLEARTOPº  Thió  procedurå erases thå uppeò portioî oæ  thå -        screen from the current position of the cursor. - - CLEARBOTTOMº Thió procedurå eraseó thå loweò portioî oæ thå -        screen from the current position of the cursor. - Š EOLº  Thió  procedurå  performó thå eraså tï  enä  oæ  linå -        function¬  clearinç thå linå froí thå currenô positioî oæ -        thå  cursoò tï thå enä oæ line®  Cursoò positioî remainó -        the same. - - EBLº  Thió  procedurå  eraseó  thå currenô  linå  froí  thå -        currenô  cursoò  positioî tï thå beginninç oæ  thå  line® -        Cursoò  positioî  ió  thå samå  afteò  thå  operatioî  aó -        before. - - FUNCTKEYº  Thió functioî scanó thå incominç datá streaí foò -        aî  escapå  keù  ($1B© anä returnó  thå  characteò  whicè -        immediatelù followó it® Thå functioî keys¬ cursoò posit -        ioninç  keys¬  anä otheò keyó oæ thå numeriã keyboarä caî -        bå seô tï generatå escapå sequences®  Thió functioî  re -        turnó  thå  uniquå  keystrokå  generateä  bù  thå  escapå -        sequence. - \ No newline at end of file diff --git a/software/CPM/CPM14_MTPUG_02/HEATH.ERL b/software/CPM/CPM14_MTPUG_02/HEATH.ERL deleted file mode 100644 index a8cb078..0000000 Binary files a/software/CPM/CPM14_MTPUG_02/HEATH.ERL and /dev/null differ diff --git a/software/CPM/CPM14_MTPUG_02/HEATH.PAS b/software/CPM/CPM14_MTPUG_02/HEATH.PAS deleted file mode 100644 index 4a1f8ca..0000000 --- a/software/CPM/CPM14_MTPUG_02/HEATH.PAS +++ /dev/null @@ -1,285 +0,0 @@ -MODULE HEATHLIB; - -(* This module is a library for the special functions available to the - H-19 terminal *) - -const - cpm = 5; - -procedure reverse; - -(* this procedure sets the H-19 for reverse video *) - -begin - inline ("MVI C / 6 / - "MVI E / $1b / - "CALL / cpm / - "MVI C / 6 / - "MVI E / 'p' / - "CALL / cpm ) -end; - -procedure normal; - -(* this procedure sets the H-19 for normal viedo *) - -begin - inline ("MVI C / 6 / - "MVI E / $1b / - "CALL / cpm / - "MVI C / 6 / - "MVI E / 'q' / - "CALL / cpm ) -end; - -procedure save_cursor; - -(* this procedure saves the location of the cursor. It is - used before attempting to write to the 25th line *) - -begin - inline ("MVI C / 6 / - "MVI E / $1b / - "CALL / cpm / - "MVI C / 6 / - "MVI E / 'j' / - "CALL / cpm ) -end; - -procedure restore_cursor; - -(* this procedure restores the cursor to the position which - was previously saved *) - -begin - inline ("MVI C / 6 / - "MVI E / $1b / - "CALL / cpm / - "MVI C / 6 / - "MVI E / 'k' / - "CALL / cpm ) -end; - -procedure put_cursor (x,y:integer); - -(* this procedure positions the cursor to the location x,y where - allowable values of x are 1 to 25, and y are 1 to 80 inclusive *) - -begin - x := x+31; - y := y+31; - inline ("MVI C / 6 / - "MVI E / $1b / - "CALL / cpm / - "MVI C / 6 / - "MVI E / 'Y' / - "CALL / cpm / - "MVI C / 6 / - "LXI H / x / - "MOV E,M / - "CALL / cpm / - "MVI C / 6 / - "LXI H / y / - "MOV E,M / - "CALL / cpm ) -end; - -procedure get_cursor (var x,y: integer); - -(* this procedure fetches the location of the cursor *) -var - str: array [1..4] of char; - i: integer; - -begin - inline ("MVI C / 6 / - "MVI E / $1b / - "CALL / CPM / - "MVI C / 6 / - "MVI E / 'n' / - "CALL / CPM ); - for i := 1 to 4 do read (str[i]); - x := ord (str[3])-31; - y := ord (str[4])-31 -end; - - - procedure put25; - -(* this procedure enables the 25th line and positions the cursor. - there *) - -begin - save_cursor; - inline ("MVI C / 6 / - "MVI E / $1b / - "CALL / cpm / - "MVI C / 6 / - "MVI E / 'x' / - "CALL / cpm / - "MVI C / 6 / - "MVI E / '1' / - "CALL / cpm ); - put_cursor (25,1) -end; - -procedure clear_line; - -(* This procedure is used to clear a line. Usually, it will be used - before the twenty-fifth line is rewritten. *) - -begin - inline ("MVI C / 6 / - "MVI E / $1b / - "CALL / cpm / - "MVI C / 6 / - "MVI E / 'l' / - "CALL / cpm ) -end; - -procedure clear_screen; - -(* this procedure clears the screen of the H-19 and - homes the cursor to the upper left position *) - -begin - inline ("MVI C / 6 / - "MVI E / $1b / - "CALL / cpm / - "MVI C / 6 / - "MVI E / 'E' / - "CALL / cpm ) -end; - -procedure clear_bottom; - -(* this procedure clears the bottom part of the H-19 screen - including the cursor position *) - -begin - inline ("MVI C / 6 / - "MVI E / $1B / - "CALL / CPM / - "MVI C / 6 / - "MVI E / 'J' / - "CALL / CPM ) -end; - -procedure clear_top; - -(* this procedure clears the upper part of the H-19 screen - including the cursor position *) - -begin - inline ("MVI C / 6 / - "MVI E / $1B / - "CALL / CPM / - "MVI C / 6 / - "MVI E / 'b' / - "CALL / CPM ) -end; - -procedure eol; - -(* this procedure erases to the end of line *) - -begin - inline ("MVI C / 6 / - "MVI E / $1B / - "CALL / CPM / - "MVI C / 6 / - "MVI E / 'K' / - "CALL / CPM ) -end; - -procedure ebl; - -(* this procedure erases to the start of the line *) - -begin - inline ("MVI C / 6 / - "MVI E / $1B / - "CALL / CPM / - "MVI C / 6 / - "MVI E / 'o' / - "CALL / CPM ) -end; - -function funct_key: char; - -(* this function tests the input stream until it finds - the start of an escape sequence. it then returns - the second character in the sequence *) - -var - ch: char; - -begin - inline ("MVI E / $FF / - "MVI C / 6 / - "CALL / CPM / - "CPI / $1B / - "JNZ / *-9 ); (* THIS FETCHES THE ESCAPE KEY *) - inline ("MVI E / $FF / - "MVI C / 6 / - "CALL / CPM / - "ORA A / - "JZ / *-8 / - "STA / CH ); (* THIS GETS THE ESCAPE CHARACTER *) - funct_key := ch -end; - -procedure cursor_up; - -(* this procedure moves the cursor up one line *) - -begin - inline ("MVI C / 6 / - "MVI E / $1B / - "CALL / CPM / - "MVI C / 6 / - "MVI E / 'A' / - "CALL / CPM ) -end; - -procedure cursor_down; - -(* this procedure moves the cursor down one line *) - -begin - inline ("MVI C / 6 / - "MVI E / $1B / - "CALL / CPM / - "MVI C / 6 / - "MVI E / 'B' / - "CALL / CPM ) -end; - -procedure cursor_left; - -(* this procedure moves the cursor to the left one character *) - -begin - inline ("MVI C / 6 / - "MVI E / $1B / - "CALL / CPM / - "MVI C / 6 / - "MVI E / 'D' / - "CALL / CPM ) -end; - -procedure cursor_right; - -(* this procedure moves the cursor to the right one character *) - -begin - inline ("MVI C / 6 / - "MVI E / $1B / - "CALL / CPM / - "MVI C / 6 / - "MVI E / 'C' / - "CALL / CPM ) -end; - -modend. - diff --git a/software/CPM/CPM14_MTPUG_02/LISTDEC.ASM b/software/CPM/CPM14_MTPUG_02/LISTDEC.ASM deleted file mode 100644 index fd67be5..0000000 --- a/software/CPM/CPM14_MTPUG_02/LISTDEC.ASM +++ /dev/null @@ -1,625 +0,0 @@ -*THIS PROGRAM TRANSFERS A FILE FROM A DEC FORMAT DISK TO A -* CP/M FORMAT DISK -* -* -*CP/M DEFINITIONS FOR PRIMITIVES -* -RDCON EQU 1 ;GET CHAR FROM CONSOLE -WRTCON EQU 2 ;TYPE CHAR ON CONSOLE -RDRDR EQU 3 ;GETCHAR FROM PAPER TAPE READER -WRTPCH EQU 4 ;SEND CHAR TO PUNCH -WRTLST EQU 5 ;SEND CHAR TO LIST DEVICE -IOSTAT EQU 7 ;INTERROGATE I/O STATUS (NOT USED HERE) -ALTIO EQU 8 ;ALTER I/O STATUS (NOT USED HERE) -PCONBF EQU 9 ;PRINT CONSOLE BUFFER -RCONBF EQU 10 ;READ CONSOLE BUFFER -CONST EQU 11 ;CHECK CONSOLE STATUS (BIT0 SET IF READY) -LIFTHD EQU 12 ;LIFT DISK HEAD (NOT USED HERE) -RSTDSK EQU 13 ;DMA ADDR TO 80H,SELECT DISK A -SELDSK EQU 14 ;SELECT DISK -OPENF EQU 15 ;OPEN FILE -CLOSEF EQU 16 ;CLOSE FILE -SRCH1 EQU 17 ;SEARCH FOR FIRST FILE OCCURRENCE -SCHNXT EQU 18 ;SEARCH FOR NEXT FILE OCCURRENCE -DELETF EQU 19 ;DELETE FILE -READF EQU 20 ;READ TO BUFFER -WRITEF EQU 21 ;WRITE TO BUFFER -MAKEF EQU 22 ;CREATE A FILE ENTRY -RENAMF EQU 23 ;RENAME A FILE -INTLOG EQU 24 ;INTERROGATE LOGIN VECTOR -INTDSK EQU 25 ;INTERROGATE DISK (RETURNS SELECTED DISK #) -SETDMA EQU 26 ;SET DMA ADDR -INTALL EQU 27 ;INTERROGATE ALLOCATION VECTOR -* -BDOS EQU 0005H ;DOS ENTRY POINT -FCB EQU 5CH ;DEFAULT FILE CONTROL BLOCK ADDRESS -BUFF EQU 80H ;DEFAULT DMA ADDRESS -* - ORG 0100H -* -*SET UP STACK - LXI H,0 - DAD SP - SHLD OLDSP - LXI SP,STKTOP - JMP MAIN -* -*STACK AREA -OLDSP: DS 2 -STACK: DS 64 -STKTOP EQU $ -* -* -*SUBROUTINES -PCHAR: ;PRINT CHAR IN REG A - PUSH H! PUSH D! PUSH B ;ENVIRONMENT SAVED - MVI C,WRTCON - MOV E,A - CALL BDOS - POP B! POP D! POP H ;ENVIRONMENT RESTORED - RET -* -CRLF: ;PRINT A CARRIAGE RETURN & LINE FEED - MVI A,0DH - CALL PCHAR - MVI A,0AH - CALL PCHAR - RET -* -PNIB: ;PRINT NIBBLE IN REG A - ANI 0FH ;LOWER 4 BITS - CPI 10 - JNC P10 - ;LESS THAN OR EQUAL TO 9 - ADI '0' - JMP PRN - ;GREATER THAN 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 -* -CHIN: ;GET A CHAR FROM CONSOLE - PUSH H! PUSH D! PUSH B - MVI C,RDCON - CALL BDOS - POP B! POP D! POP H - RET -* -MSG: ;PRINT A MESSAGE POINTED TO BY HL (END OF MESSAGE=0FFH) - MOV A,M - CPI 0FFH - RZ ;RETURN IF END OF MESSAGE - CALL PCHAR - INX H - JMP MSG -* -SETTRK: ;SET TRACK IN C - LHLD 1 - LXI D,27 - DAD D - PCHL -* -SETSEC: LHLD 1 - LXI D,30 - DAD D - PCHL -* -RDSEC: LHLD 1 - LXI D,36 - DAD D - PCHL -* -DISKRD: ;READ FROM DISK B-TRACK IN "TRACK",SECTOR IN "SECTOR" - PUSH B ;SAVE LOGICAL TRACK & SECTOR - LDA TRACK - STA BTRACK - LDA SECTOR - STA BSECT - LDA INTLEV ;GET INTERLEAVE FLAG - ORA A - JZ CONSEC ;0 > CONSECUTIVE SECTORS -* -*INTERLEAVE ALGORITHM FOR STANDARD DEC DISKS -* - PUSH D ;SAVE DMA ADDR - MVI H,0 - LDA BTRACK - MOV L,A - DCX H ;HL=TRACK-1;NOW MULTIPLY BY 6 - MOV A,L - ADD A - MOV L,A - MOV A,H - RAL - MOV H,A - SHLD X2 ;HL*2 -INTLV3: MOV A,L - ADD A - MOV L,A - MOV A,H - RAL - MOV H,A - XCHG - LHLD X2 - DAD D ;HL*6 IN HL -* 6*(TRACK-1) IN HL -* -INTLV0: MOV A,H - ORA A - JNZ INTLV5 - MOV A,L - CPI 26 - JM INTLV4 -INTLV5: LXI D,0-26 - DAD D - JMP INTLV0 -INTLV4: LDA BSECT - DCR A ;SHIFT SECTOR DOWN (0-25) - PUSH PSW - ADD A - MOV E,A ;SAVE S2 - POP PSW - CPI 13 - MOV A,E ;GET S2 BACK TO ACC. - JM INTLV2 - INR A -INTLV2: ADD L ;ADD BIAS -INTLV1: SUI 26 - JP INTLV1 - ADI 27 - STA BSECT ;NEW PHYSICAL SECTOR TO BSECT - POP D ;RESTORE DMA ADDR -CONSEC: LDA BSECT - MOV C,A - CALL SETSEC - LDA BTRACK - MOV C,A - CALL SETTRK - CALL RDSEC - POP B - RET -* -GETDIR: ;GET DIRECTORY SEGMENT 1 INTO THE DIRECTORY BUFFER - ; ASSUME FILE WILL BE IN SEGMENT 1 - MVI C,SELDSK - MVI E,1 - CALL BDOS ;SEL DISK B - MVI A,2 - STA COUNT - LXI D,0 - MVI A,01H - STA TRACK - MVI A,19H - STA SECTOR - LXI H,DRBUFF - SHLD BUFFPT ;INIT. BUFFPT -GTDIR1: LHLD BUFFPT - DAD D - SHLD BUFFPT - XCHG - MVI C,SETDMA - CALL BDOS - CALL DISKRD ;READ SECTOR FROM DISK - LXI D,128 - MVI A,1AH - STA SECTOR - LDA COUNT - DCR A - STA COUNT - JNZ GTDIR1 ;READ IN FIRST 2 SECTORS - MVI A,6 - STA COUNT - MVI A,02 - STA TRACK - DCR A - STA SECTOR -GTDIR2: LXI D,128 ;LENGTH OF A SECTOR - LHLD BUFFPT - DAD D - SHLD BUFFPT - XCHG ;DMA ADDR > DE - MVI C,SETDMA - CALL BDOS - CALL DISKRD - LDA SECTOR - INR A - STA SECTOR - LDA COUNT - DCR A - STA COUNT - JNZ GTDIR2 - RET -* -X50: ;MULTIPLY HL BY 50Q & RETURN IN HL - PUSH B - PUSH D - MVI B,3 -X50A: MOV A,L - ADD A - MOV L,A - MOV A,H - RAL - MOV H,A - DCR B - JNZ X50A - SHLD X8 - MVI B,2 -X50B: MOV A,L - ADD A - MOV L,A - MOV A,H - RAL - MOV H,A - DCR B - JNZ X50B - XCHG - LHLD X8 - DAD D - POP D - POP B - RET -REGMOD: ;MODIFY DRIVE B REGISTERS AFTER SECTOR READ - LDA SECTOR - CPI 26 - JZ RM1 - INR A - STA SECTOR - RET -RM1: MVI A,1 - STA SECTOR - LDA TRACK - INR A - STA TRACK - RET -* -CMP16: ;COMPARES HL & DE & SETS USUAL FLAGS - MOV A,H - CMP D - RNZ - MOV A,L - CMP E - RET -* -NEGDE: ;NEGATE DE REGISTER (2'S COMP) - PUSH PSW - MOV A,D - CMA - MOV D,A - MOV A,E - CMA - MOV E,A - INX D - POP PSW - RET -* -DCR16: ;DECREMENT HL BY 1 & SET FLAG C IF RESULT >= 0 - ; NC IF RESULT < 0 - PUSH D - LXI D,0FFFFH ;-1 - DAD D - POP D - RET -* -* -* -FINIS: CALL CRLF - LHLD OLDSP - SPHL - RET -* -SPACE: ;PRINTS A SPACE ON CRT - PUSH PSW - MVI A,20H - CALL PCHAR - POP PSW - RET -* -R50ASC: ;CONVERTS A BASIC RADIX 50 CHAR TO ASCII - CPI 0 - JNZ RASC1 - MVI A,20H - RET -RASC1: CPI 1BH - JP RASC2 - ADI 40H - RET -RASC2: CPI 1BH - JNZ RASC3 - MVI A,24H - RET -RASC3: CPI 1CH - JNZ RASC4 - MVI A,2EH - RET -RASC4: ADI 12H - RET -* -RAD50: ;DECODES RADIX 50 WORD TO 3 ASCII CHARS & PRINTS THEM - SHLD R50 - LXI D,0-1600 - MVI C,0 -RAD1: DAD D - JNC RAD2 - INR C - JMP RAD1 -RAD2: MOV A,C - STA CHAR1 - MOV L,A - MVI H,0 - CALL X50 - CALL X50 - XCHG - CALL NEGDE - LHLD R50 - DAD D - SHLD R50 - LXI D,0-40 - MVI C,0 -RAD3: DAD D - JNC RAD4 - INR C - JMP RAD3 -RAD4: MOV A,C - STA CHAR2 - MOV L,A - MVI H,0 - CALL X50 - XCHG - CALL NEGDE - LHLD R50 - DAD D - MOV A,L - STA CHAR3 - LDA CHAR1 - CALL R50ASC - CALL PCHAR - LDA CHAR2 - CALL R50ASC - CALL PCHAR - LDA CHAR3 - CALL R50ASC - CALL PCHAR - RET -* -LDECWD: ;PRINTS DECIMAL EQUIV. OF HL - PUSH B! PUSH PSW! PUSH H! PUSH D! - XRA A - STA BLANK0 - MVI B,30H - LXI D,10000 - CALL LDEC0 - LXI D,1000 - CALL LDEC0 -LDECB1: LXI D,100 - CALL LDEC0 - MVI E,10 - CALL LDEC0 - MVI E,1 - CALL LDEC0 - POP D! POP H! POP PSW! POP B - RET -* -LDEC0: MVI C,30H -LDEC1: MOV A,L - SUB E - MOV L,A - MOV A,H - SBB D - MOV H,A - JC LDEC2 - INR C - JMP LDEC1 -LDEC2: DAD D - MOV A,C - CPI 30H - JNZ LDEC3 - MOV A,B - JMP CO -LDEC3: MVI B,30H - JMP CO -CO: CPI 30H - JNZ CO1 - PUSH PSW - LDA BLANK0 - RAR - JNC CO2 - POP PSW - JMP PCHAR -CO2: POP PSW - MVI A,20H - JMP PCHAR -CO1: PUSH PSW - MVI A,1 - STA BLANK0 - POP PSW - JMP PCHAR -* -* -* -* -* -MAIN: ;MAIN BODY OF PROGRAM-LISTS DEC DIRECTORY - CALL CRLF -* -DECINT: LXI H,M0 ;IS DEC DISK INTERLEAVED? - CALL MSG - CALL CHIN - CPI 'Y' - JNZ NO1 - MVI A,1 - STA INTLEV ;SET INTERLEAVE FLAG - JMP REDY -NO1: CPI 'N' - JNZ DECINT - XRA A - STA INTLEV - CALL CRLF -* -REDY: MVI C,SELDSK - MVI E,1 - CALL BDOS ;SEL DISK B - CALL GETDIR ;GET DIRECTORY INTO DRBUFF - LHLD ENTRYS - SHLD ENTNUM - LXI H,ENTRYS - SHLD DRBFPT -* -DRLOOP: LHLD ENTNUM - MVI A,2 - CMP H - JZ EMPTFL ;THIS ENTRY AN EMPTY FILE - MVI A,4 - CMP H - JZ PERMFL ;THIS ENTRY IS A PERMANENT FILE - MVI A,8 - CMP H - JZ FINIS ;END OF DIRECTORY - LXI H,M2 ;ILLEGAL STATUS WORD - CALL MSG - JMP DECINT -* -EMPTFL: CALL CRLF - LXI H,M3 ;< UNUSED > - CALL MSG - LHLD DRBFPT - LXI D,8 - DAD D - MOV E,M - INX H - MOV D,M ;FILE LENGTH IN DE - XCHG - CALL SPACE - CALL SPACE - CALL LDECWD - XCHG - LXI D,5 - DAD D ;IGNORE REST OF ENTRY INFO - SHLD DRBFPT - MOV A,M - STA ENTNUM - INX H - MOV A,M - STA ENTNUM+1 - JMP DRLOOP ;DO NEXT ENTRY -* -PERMFL: CALL CRLF - LHLD DRBFPT - INX H - INX H - MOV A,M - STA FILELO ;GET FILNAM.EXT FOR LISTING - INX H - MOV A,M - STA FILEHI - INX H - MOV A,M - STA NAMELO - INX H - MOV A,M - STA NAMEHI - INX H - MOV A,M - STA EXTLO - INX H - MOV A,M - STA EXTHI ;FILNAM.EXT STORED - PUSH H - LHLD FILELO - CALL RAD50 ;PRINT OUT FIL - LHLD NAMELO - CALL RAD50 ;PRINT OUT NAM - MVI A,'.' - CALL PCHAR ;PRINT OUT '.' - LHLD EXTLO - CALL RAD50 ;PRINT OUT EXT - CALL SPACE - CALL SPACE - POP H ;RESTORE BUFFER POINTER - INX H - MOV E,M - INX H - MOV D,M ;FILE LENGTH IN DE - XCHG - CALL LDECWD ;PRINT LENGTH IN DECIMAL - XCHG - LXI D,5 - DAD D ;IGNORE REST OF ENTRY INFO. - SHLD DRBFPT - MOV A,M - STA ENTNUM - INX H - MOV A,M - STA ENTNUM+1 ;SET UP FOR NEXT ENTRY - JMP DRLOOP ; & GO TO IT -* -* -*VARIABLES -ENTNUM: DS 2 ;ENTRY POINTER -BUFFPT: DS 2 ;XFER BUFFER POINTER -INTLEV: DS 1 ;INTERLEAVE FLAG -BLANK0: DS 1 ;SUPRESS LEADING 0 FLAG -CHAR1: DS 1 ;1ST RAD50 CHAR -CHAR2: DS 1 ;2ND " -CHAR3: DS 1 ;3RD " -R50: DS 2 ;TEMP RADIX 50 STORAGE -X2: DS 2 ;HL*2 -BSECT: DS 1 -COUNT2: DS 1 ;SECOND UTILITY COUNTER -R50NUM: DS 2 ;RADIX 50 CONVERSION OF 3 ASCII CHARS -X8: DS 2 ;HL*8 -FILELO: DS 1 ;PERMANENT FILE NAME & EXT. STORAGE -FILEHI: DS 1 -NAMELO DS 1 -NAMEHI DS 1 -EXTLO DS 1 -EXTHI DS 1 ;END OF PERM. NAME STORAGE -ENTRY: DS 2 ;ENTRY STATUS WORD POINTER -BLKCNT: DS 2 ;BLOCK COUNT (UPDATED EVERY ENTRY) -BLOCKS: DS 2 ;# OF BLOCKS TO FILE (VALID ONLY IF FOUND) -LENGTH: DS 2 ;LENGTH OF FILE FOUND (IN BLOCKS) -TRACK: DS 1 ;TRACK OF FOUND FILE -SECTOR: DS 1 ;SECTOR OF FOUND FILE -FILE: DS 2 ;FILE NAME -NAME: DS 2 ; & EXT. OF -EXT: DS 2 ; REQUESTED FILE (DEC) -FLNMPT: DS 2 ;FILE NAME POINTER -FLBFPT: DS 2 ;PERM. FILE NAME POINTER -BTRACK: DS 1 ;PHYSICAL TRACK -COUNT: DS 1 ;UTILITY COUNTER LOCATION -DRBFPT: DS 2 ;DIRECTORY BUFFER POINTER -DRBUFF: ;DIRECTORY BUFFER -HDWD1: DS 2 ;SEGMENTS AVAILABLE -HDWD2: DS 2 ;NEXT SEGMENT -HDWD3: DS 2 ;HIGHEST OPEN SEGMENT -HDWD4: DS 2 ;EXTRA WORDS/ENTRY -HDWD5: DS 2 ;FILE STARTING BLOCK -ENTRYS: DS 1014 ;ENTRIES -ENDBUF: DS 1 -* -* -*MESSAGES -* -M0: DB 0DH,0AH,'IS DEC DISK INTERLEAVED (Y/N)?',0FFH -M2: DB 0DH,0AH,'ILLEGAL STATUS WORD ENCOUNTERED',0FFH -M3: DB '< UNUSED >',0FFH -* -* -PAD: DS 4 -* -PRGEND EQU $ -* -* -* - END - \ No newline at end of file diff --git a/software/CPM/CPM14_MTPUG_02/MTPUG.002 b/software/CPM/CPM14_MTPUG_02/MTPUG.002 deleted file mode 100644 index c5dd622..0000000 --- a/software/CPM/CPM14_MTPUG_02/MTPUG.002 +++ /dev/null @@ -1,35 +0,0 @@ -CALCULAT/CMD/COM/DOC/ERL/PAS Intended to replace a Scientific - Calculator, but because of the limited - accuracy should be used with caution. - Excellent example of statement parsing, - and recursion. Written by Warren Smith. - -XREF/CMD/COM/DOC/ERL/PAS A comprehensive cross reference program - with a graphical listing in which the - block structure is delimited by - lines connected between each begin and - end statement. Written by Warren Smith. - - - -CP/M-DEC/DOC The source code for the programs to -CPMTODEC/ASM read and write DEC files from CP/M. -DECTOCPM/ASM Written by Brian Chase under the -LISTDEC/ASM direction of Ceasar Castro. - He reports that there is one bug in - the program as it will not transfer - DEC object files.(Normally not needed). - - -HEATH/DOC/PAS/ERL A module which implements all the - functions available to the Heath H-19 - terminal. (Includes cursor and screen - controls). Written by Jerome Jankura. - -SPEAKER/DOC/PAS/ERL This program is a software driver for - the Votrax SC-01 voice synthesis chip. - You can enter a word, say a word, modify - the word, or disassemble the word into its - phonemes. WRitten by Jerome Jankura. - - \ No newline at end of file diff --git a/software/CPM/CPM14_MTPUG_02/MTPUG.BAK b/software/CPM/CPM14_MTPUG_02/MTPUG.BAK deleted file mode 100644 index 280ae57..0000000 --- a/software/CPM/CPM14_MTPUG_02/MTPUG.BAK +++ /dev/null @@ -1,35 +0,0 @@ -CALCULAT/CMD/COM/DOC/ERL/PAS Intended to replace a Scientific - Calculator, but because of the limited - accuracy should be used with caution. - Excellent example of statement parsing, - and recursion. Written by Warren Smith. - -XREF/CMD/COM/DOC/ERL/PAS A comprehensive cross reference program - with a graphical listing in which the - block structure is delimited by - lines connected between each begin and - end statement. Written by Warren Smith. - - - -CP/M-DEC/DOC The source code for the programs to -CPMTODEC/ASM read and write DEC files from CP/M. -DECTOCPM/ASM Written by Brian Chase under the -LISTDEC/ASM direction of Ceasar Castro. - He reports that there is one bug in - the program as it will not transfer - DEC object files.(Normally not needed). - - -HEATH/DOC/PAS/ERL A module which implements all the - functions available to the Heath H-19 - terminal. (Includes cursor and screen - controls). Written by Jerome Jankura. - -SPEAKER/DOC/PAS/ERL This program is a software driver for - the Votrax SC-01 voice synthesis chip. - You can enter a word, say a word, modify - the word, or dissamble the word into its - phonemes. WRitten by Jerome Jankura. - - \ No newline at end of file diff --git a/software/CPM/CPM14_MTPUG_02/SEND.COM b/software/CPM/CPM14_MTPUG_02/SEND.COM deleted file mode 100644 index 0b53008..0000000 Binary files a/software/CPM/CPM14_MTPUG_02/SEND.COM and /dev/null differ diff --git a/software/CPM/CPM14_MTPUG_02/SPEAKER.DOC b/software/CPM/CPM14_MTPUG_02/SPEAKER.DOC deleted file mode 100644 index aaca2aa..0000000 --- a/software/CPM/CPM14_MTPUG_02/SPEAKER.DOC +++ /dev/null @@ -1,43 +0,0 @@ -Name: Speaker.pas -Author: Jerome F. Jankura -Description: - - SPEAKER.PAS ió á softwarå developmenô systeí designed foò thå -Votraø  SC-0±  voicå  synthesió  unit®  Thå  hardwarå  interfacå -consistó oæ partó oæ threå paralleì ports®  Thå firsô porô ió aî -outpuô port®  Lineó 0-µ consisô oæ phonemå data®  Lineó 6-· caî -bå  useä  foò  inflectioî data®  Inflectioî informatioî  ió  noô -currentlù implemented®  Thå seconä porô ió aî inpuô  port®  Onå -linå  oæ thió porô ió useä tï senså thå statuó oæ thå SC-0± unit® -Thió  statuó linå ió logiã zerï (<½ 0.¸ volts© wheî thå SC-0±  ió -busù anä logiã ± (=¾ 2.´ volts© wheî thå SC-0± ió readù tï accepô -thå nexô phoneme®  Thå interfacå ió similaò tï thå onå presenteä -iî  Ciarcia'ó  Circuiô Celleò iî thå September¬  1981¬  issuå  oæ -Byte. - - SPEAKER.PAÓ  useó  standarä CP/Í I/Ï tï interfacå  witè  thå -console®  Thå consolå ió modelleä aó thå Heath/Zeintè 1¹  termi -nal® Iô ió interfaceä tï thå SPEAKER.PAÓ prograí througè á serieó -oæ  procedureó anä functionó implementeä bù thå HEATH.PAÓ prograí -module®  Simplù rewritå thå modulå tï suiô á differenô terminal® -Twï difficultieó ariså iæ thå modulå ió  rewritten®  First¬  thå -softwarå  ió menõ driveî anä utilizeó severaì functioî keyó whicè -forí thå toð ro÷ oæ thå terminal®  Thå functioî FUNCTKEÙ caî  bå -rewritteî  tï uså controì keyó instead®  Secondly¬  thå softwarå -useó  thå  twenty-fiftè linå tï writå thå  abbreviationó  oæ  thå -commandó oî thå screen®  Oî thå Heatè terminal¬ thå twenty-fiftè -linå behaveó aó á separatelù accessiblå onå linå terminal®  Pro -cedureó  iî HEATH.PAÓ arå useä tï makå fulì uså oæ thió  feature® -Iæ  anotheò terminaì ió used¬  thå menõ softwarå wilì havå tï  bå -rewritteî  tï  displaù thå lisô oæ commandó availablå anä  accepô -thå correcô entry. - - Thå  softwarå  ió  designeä tï allo÷ thå useò tï  builä  anä -maintaiî  severaì  dictionarieó oæ onå hundreä  utteranceó  each® -Procedureó  tï builä thå dictionary¬  storå iô oî disk¬  anä  re -trievå  á disë filå arå provided®  Somå leveló providå á  "HELP¢ -functioî  tï displaù thå commandó  available®  Otheò  procedureó -allo÷  modificatioî  oæ  dictionarù entries®  Wordó iî  á  giveî -dictionarù  caî  bå concatenateä tï  forí  sentences®  Á  samplå -vocabulary (WORDS.VOC) is included as a beginning. - \ No newline at end of file diff --git a/software/CPM/CPM14_MTPUG_02/SPEAKER.ERL b/software/CPM/CPM14_MTPUG_02/SPEAKER.ERL deleted file mode 100644 index 73843fb..0000000 Binary files a/software/CPM/CPM14_MTPUG_02/SPEAKER.ERL and /dev/null differ diff --git a/software/CPM/CPM14_MTPUG_02/SPEAKER.PAS b/software/CPM/CPM14_MTPUG_02/SPEAKER.PAS deleted file mode 100644 index 96aed22..0000000 --- a/software/CPM/CPM14_MTPUG_02/SPEAKER.PAS +++ /dev/null @@ -1,958 +0,0 @@ -Program speaker; - -(* this program is a software driver for the votrax - SC-01 voice synthesis chip. Using this software - package, one can enter a word, say the word, modify - the word, or disassemble the word into its phonemes. - The system will be expanded to write a vocabulary - file onto a disk and to read a file from a disk. *) - -const - (* these values are particular to the hardware - configuration of the SC-01 chip. Port assignments, - control words, and masks will have to be changed - to adapt this software to a different system. - This can be done by changing the equates in this - constant block. *) - - voice = $8c; (* i/o port for voice data *) - status = $8e; (* sc-01 status port *) - parctl = $8f; (* 8255 control port *) - strobe = $0f; (* sets sc-01 strobe hi *) - nostrb = $0e; (* sets sc-01 strobe low *) - ready = $01; (* mask bit for ready bit *) - ctrpar = $83; (* control word for 8255 *) - -type - word_def = record - spelling: string[14]; - phonemes: string[20]; - filled: boolean - end; - - nmen = array [0..63] of string[4]; - -var - token: byte; (* built by parsing routines *) - i,j,k: integer; (* general purpose *) - command: char; (* the command interpreter *) - ch:char; - data_valid: boolean; (* to eliminate extraneous spaces *) - utterance: word_def; - dictionary: array [1..100] of word_def; - accept: boolean; - entry: integer; (* number of entries in dictionary *) - in_file: file of word_def; (* name of file from which dict comes *) - out_file: file of word_def; (* name of file written by this program *) - word_spelling: string [14]; (* used to locate one word in dictionary *) - sentenct: string; - nmptr : ^nmen; - - external PROCEDURE reverse; - external PROCEDURE normal; - external PROCEDURE save_cursor; - external PROCEDURE restore_cursor; - external PROCEDURE put_cursor (x,y: integer); - external PROCEDURE get_cursor (var x,y: integer); - external PROCEDURE put25; - external PROCEDURE clear_line; - external PROCEDURE clear_screen; - external PROCEDURE cursor_up; - external PROCEDURE cursor_down; - external PROCEDURE cursor_left; - external PROCEDURE cursor_right; - external PROCEDURE clear_bottom; - external PROCEDURE clear_top; - external PROCEDURE eol; - external PROCEDURE ebl; - external FUNCTION funct_key: char; - - PROCEDURE say (what: char); - (* this PROCEDURE waits until the status bit - returns ready. It then writes a phoneme code - passed to it to the SC-01 *) - -BEGIN - while (inp[status] & ready) = 0 do; - out[voice] := what; - out[parctl] := strobe; - out[parctl] := nostrb - end; - - PROCEDURE sayit (var str: string); - (* this PROCEDURE enunciates an utterance whose - address is passed to it *) - - var - i: integer; - - BEGIN - for i := 1 to length (str) do - say (str[i]) - end; - - PROCEDURE nmentable; - - BEGIN - INLINE ( 3 / 'EH3 ' / - 3 / 'EH2 ' / - 3 / 'EH1 ' / - 3 / 'PA0 ' / - 2 / 'DT ' / - 2 / 'A2 ' / - 2 / 'A1 ' / - 2 / 'ZH ' / - 3 / 'AH2 ' / - 2 / 'I3 ' / - 2 / 'I2 ' / - 2 / 'I1 ' / - 1 / 'M ' / - 1 / 'N ' / - 1 / 'B ' / - 1 / 'V ' / - 2 / 'CH ' / - 2 / 'SH ' / - 1 / 'Z ' / - 3 / 'AW1 ' / - 2 / 'NG ' / - 3 / 'AH1 ' / - 3 / 'OO1 ' / - 2 / 'OO ' / - 1 / 'L ' / - 1 / 'K ' / - 1 / 'J ' / - 1 / 'H ' / - 1 / 'G ' / - 1 / 'F ' / - 1 / 'D ' / - 1 / 'S ' / - 1 / 'A ' / - 2 / 'AY ' / - 2 / 'Y1 ' / - 3 / 'UH3 ' / - 2 / 'AH ' / - 1 / 'P ' / - 1 / 'O ' / - 1 / 'I ' / - 1 / 'U ' / - 1 / 'Y ' / - 1 / 'T ' / - 1 / 'R ' / - 1 / 'E ' / - 1 / 'W ' / - 2 / 'AE ' / - 3 / 'AE1 ' / - 3 / 'AW2 ' / - 3 / 'UH2 ' / - 3 / 'UH1 ' / - 2 / 'UH ' / - 2 / 'O2 ' / - 2 / 'O1 ' / - 2 / 'IU ' / - 2 / 'U1 ' / - 3 / 'THV ' / - 2 / 'TH ' / - 2 / 'ER ' / - 2 / 'EH ' / - 2 / 'E1 ' / - 2 / 'AW ' / - 3 / 'PA1 ' / - 4 / 'STOP' ) - END; - - PROCEDURE disasm (ch: char; var str: string); - (* this PROCEDURE disassembles a phoneme code into its - nmemonic *) - - BEGIN - nmptr := addr (nmentable); - str := nmptr^[ord(ch)] - END; - - PROCEDURE parse_a; - (* this PROCEDURE is used to encode the phonemes which - BEGIN with the letter A *) - - BEGIN - read (ch); - case ch of - ' ': token := $20; - '1': token := $6; - '2': token := $5; - 'Y': token := $21; - 'E': BEGIN - read (ch); - case ch of - ' ': token := $2e; - '1': BEGIN - read(ch); - if ch = ' ' then token := $2f - end - end (* case *) - end; (* AE sequence *) - 'H': BEGIN - read (ch); - case ch of - ' ': token := $24; - '1': token := $15; - '2': token := $8 - end (* case *) - end; (* AH sequence *) - 'W': BEGIN - read (ch); - case ch of - ' ': token := $3d; - '1': token := $13; - '2': token := $30 - end (* case *) - end (* AW sequence *) - end (* A-something sequence *) - end; (* Case A *) - - PROCEDURE parse_e; - (* this PROCEDURE is used to parse out the phonemes - which start with the letter E *) - - BEGIN - read (ch); - case ch of - ' ': token := $2c; - '1': token := $3c; - 'H': BEGIN - read (ch); - case ch of - ' ': token := $3b; - '1': token := $2; - '2': token := $1; - '3': token := 0 - end (* case *) - end; (* EH phoneme sequence *) - 'R': token := $3a - end (* case *) - end; (* E phoneme sequence *) - - PROCEDURE parse_i; - (* this PROCEDURE parses the phonemes which start with - the letter I *) - - BEGIN - read (ch); - case ch of - ' ': token := $27; - '1': token := $b; - '2': token := $a; - '3': token := $9; - 'U': token := $36 - end (* case *) - end; (* I phoneme sequence *) - - PROCEDURE parse_o; - (* this PROCEDURE parses the phonemes which start with - the letter O *) - - BEGIN - read (ch); - case ch of - ' ': token := $26; - '1': token := $35; - '2': token := $34; - 'O': BEGIN - read (ch); - case ch of - ' ': token := $17; - '1': token := $16; - end (* case OO *) - end (* OO phoneme sequence *) - end (* case *) - end; (* O sequence *) - - PROCEDURE parse_u; - (* this PROCEDURE parses the phonemes that start with - the letter U *) - - BEGIN - read (ch); - case ch of - ' ': token := $28; - '1': token := $37; - 'H': BEGIN - read (ch); - case ch of - ' ': token := $33; - '1': token := $32; - '2': token := $31; - '3': token := $23 - end - end (* UH Sequence *) - end (* case *) - end; (* U phoneme sequence *) - - PROCEDURE parse_p; - (* this PROCEDURE parses the phoneme codes which - BEGIN with the letter P *) - - BEGIN - read (ch); - case ch of - ' ': token := $25; - 'A': BEGIN - read (ch); - case ch of - '0': token := $3; - '1': token := $3e - end (* case *) - end - end (* case *) - end; (* P phoneme sequence *) - - PROCEDURE parse_t; - (* this PROCEDURE parses the phonemes which start - with the letter T *) - - BEGIN - read (ch); - case ch of - ' ': token := $2a; - 'H': BEGIN - read (ch); - case ch of - ' ': token := $39; - 'V': token := $38 - end (* case *) - end (* TH sequence *) - end (* case *) - end; (* T phoneme sequence *) - - FUNCTION getphoneme: char; - (* this PROCEDURE fetches characters from the keyboard input - and returns a phoneme code which corresponds to the - input character string *) - - BEGIN - data_valid := true; - read (ch); (* get a character *) - case ch of - 'A': parse_a; - 'B': token := $0e; - 'C': BEGIN - read (ch); - if ch = 'H' then token := $10 - end; (* CH phoneme *) - 'D': BEGIN - read (ch); - case ch of - ' ': token := $1e; - 'T': token := $4 - end (* case *) - end; (* D sequence *) - 'E': parse_e; - 'F': token := $1d; - 'G': token := $1c; - 'H': token := $1b; - 'I': parse_i; - 'J': token := $1a; - 'K': token := $19; - 'L': token := $18; - 'M': token := $c; - 'N': BEGIN - read (ch); - case ch of - ' ': token := $d; - 'G': token := $14 - end (* case *) - end; (* N phoneme sequence *) - 'O': parse_o; - 'P': parse_p; - 'R': token := $2b; - 'S': BEGIN - read (ch); - case ch of - ' ': token := $1f; - 'H': token := $11; - 'T': token := $3f - end (* case *) - end; (* S phoneme sequence *) - 'T': parse_t; - 'U': parse_u; - 'V': token := $f; - 'W': token := $2d; - 'Y': BEGIN - read (ch); - case ch of - ' ': token := $29; - '1': token := $22 - end - end; (* Y phoneme sequence *) - 'Z': BEGIN - read (ch); - case ch of - ' ': token := $12; - 'H': token := $7 - end - end (* Z phoneme sequence *) - else data_valid := false - end; - getphoneme := token - end; (* phoneme fetching & decoding *) - - PROCEDURE get_entry; - (* this PROCEDURE fetches an entry from the user and stores - in a temporary location called utterance *) - - var - phoneme: char; - - BEGIN - clear_screen; - list_phonemes; - put_cursor (16,1); - write ('Enter the ENGLISH spelling of a word: '); - readln (utterance.spelling); - put_cursor (17,1); - writeln ('And its PHONETIC spelling'); - writeln ('(Insert a space between each phoneme)'); - utterance.phonemes := ''; (* reset utterance *) - - repeat - phoneme := getphoneme; - if data_valid then - utterance.phonemes := concat (utterance.phonemes,phoneme) - until eoln - end; - - PROCEDURE put_in_dictionary; - (* this PROCEDURE loads the utterance into the next available - dictionary position *) - VAR - I: integer; - - BEGIN - put_cursor (15,20); - write ('Save Word Information in Dictionary'); - i := 0; - repeat - i := i + 1 - until (i>100) or not dictionary[i].filled; - if entry < i then entry := i; - if entry >100 - then - BEGIN - writeln; - write ('Dictionary FULL, Save it on Disk and try again') - end - else - BEGIN - dictionary[i] := utterance; - dictionary[i].filled := true; - put_cursor (17,20); - write (utterance.spelling,' saved as entry ',i) - end; - for i := 1 to 30000 do - end; - - PROCEDURE save_on_disk; - (* this PROCEDURE writes a dictionary disk file *) - - var - file_name: string[17]; - i,j: integer; - - BEGIN - put_cursor (15,20); - write ('Save Dictionary on Disk FUNCTION'); - put_cursor (17,1); - write ('Enter Dictionary Name: '); - readln (file_name); - assign (out_file,filename); - rewrite (out_file); - if ioresult = 255 - then - BEGIN - put_cursor (18,1); - write ('Disk directory full'); - for i := 1 to 30000 do - end - else - BEGIN - j := 0; - for i := 1 to entry do - BEGIN - if dictionary[i].filled then - BEGIN - j := j + 1; - out_file^ := dictionary[i]; - put (out_file) - end - end; (* for *) - close (outfile,i) - end; (* if *) - put_cursor (17,1); - clear_line; - write (j,' Words written to File ',file_name); - for i := 1 to 30000 do - end; - - PROCEDURE get_from_disk; - (* this PROCEDURE loads a dictionary disk file into - the workspace dictionary *) - - var - file_name: string[17]; - i,j: integer; - - BEGIN - put_cursor (15,20); - write ('Get Dictionary From Disk File'); - put_cursor (17,1); - write ('Enter File Name: '); - readln (file_name); - assign (in_file,file_name); - reset (in_file); - if ioresult = 255 - then writeln ('file does not exist') - else - BEGIN - for i := 1 to 100 do dictionary[1].filled := false; - i := 0; - repeat - i := i+1; - dictionary[i] := in_file^; - get (infile) - until eof(in_file); - entry := i; - put_cursor (19,1); - write (entry,' Words Written into Workspace') - end; (* if *) - for i := 1 to 30000 do - end; - - PROCEDURE rpt_word; - (* this PROCEDURE repeats the utterance *) - - BEGIN - sayit (utterance.phonemes); - say (chr($3f)) - end; - - - PROCEDURE LIST_PHONEMES; - - (* This procedure lists the phonemes which are available *) - - BEGIN - put_cursor (4,30); - write ('Phonemes available:'); - put_cursor (6,1); - writeln ('E EH AE UH OO1 Z B T S M PA0'); - writeln ('E1 EH1 AE1 UH1 R ZH D DT SH N PA1'); - writeln ('Y EH2 AH UH2 ER J G K CH NG ST'); - writeln ('Y1 EH3 AH1 UH3 L V P TH'); - writeln ('I A AH2 O IU THV F'); - writeln ('I1 A1 AW O1 U H'); - writeln ('I2 A2 AW1 O2 U1'); - writeln ('I3 AY AW2 OO W') - END; - - - PROCEDURE encode; - (* this PROCEDURE encodes a word into the string - passed to it *) - - var - i: integer; - phoneme: char; - nmemonic: string [4]; - continue: boolean; - - PROCEDURE help; - (* this PROCEDURE writes the meaning of the FUNCTION keys - onto the screen. By convention, the grey (white) FUNCTION - key toggles in and out of this mode *) - - var - i: integer; - - BEGIN - put_cursor (15,20); - write ('Command Summary'); - for i := 1 to 9 do - BEGIN - put_cursor (i+15,5); - case i of - 1: write ('GET (f1): Encode a user utterance'); - 2: write ('WRT (f2): Write current utterance into dictionary'); - 3: write ('SOD (f3): Save current dictionary on disk file'); - 4: write ('GFD (f4): Load disk file into dictionary'); - 5: write ('XIT (f5): Exit to main menu'); - 6: write ('DLE (ERASE) : Delete selected dictionary entry'); - 7: write ('RPT (blue): repeat current utterance'); - 8: write ('MOD (red): Modify a word'); - 9: write ('HLP (white): display help messages') - end (* case *) - end; (* for *) - while funct_key <> 'R' do - end; - - PROCEDURE KILL_WORD; - (* This procedure is used to delete a word from the dictionary *) - - var - i: integer; - - BEGIN - clear_screen; - list_words; - put_cursor (24,1); - write ('Delete Which? '); - read (word_spelling); - i := 0; - repeat - i := i+1 - until (i>100) or (word_spelling = dictionary[i].spelling); - if i > 100 then write ('Word not in dictionary') - else - BEGIN - dictionary[i].spelling := ''; - dictionary[i].filled := false - end; - clear_screen - END; - - PROCEDURE MODIFY_PHONEMES; - (* This prodecure is used to modify the phonemes in a word *) - (* which has already been encoded. *) - - var - i,j,k: integer; - test_phoneme: string[20]; - - PROCEDURE INS_PHONEME; - - var - index: integer; - phoneme: char; - - BEGIN - put_cursor (15,1); - clear_bottom; - write (dictionary[i].spelling,' = '); - display (test_phoneme); - put_cursor (23,1); - write ('Insert where? '); - readln (index); - put_cursor (23,30); - write ('Insert what? '); - phoneme := get_phoneme; - insert (phoneme,test_phoneme,index); - put_cursor (15,1); - clear_line; - write (dictionary[i].spelling,' = '); - display (test_phoneme); - sayit (test_phoneme); - say (chr($3f)) - END; - - PROCEDURE KILL_PHONEME; - - var - index: integer; - - BEGIN - put_cursor (15,1); - clear_bottom; - write (dictionary[i].spelling,' = '); - display (test_phoneme); - put_cursor (23,1); - write ('Delete where? '); - readln (index); - delete (test_phoneme,index,1); - put_cursor (15,1); - eol; - write(dictionary[i].spelling,' = '); - display (test_phoneme); - sayit (test_phoneme); - say (chr($3f)) - END; - - - BEGIN - clear_screen; - list_words; - put_cursor (24,1); - write ('Modify which word? '); - read (word_spelling); - i := 0; - repeat - i := i + 1 - until (i>100) or (word_spelling = dictionary[i].spelling); - if i > 100 then - begin - put_cursor (24,1); - clear_line; - write ('cannot find ',word_spelling,' in the dictionary'); - for i := 1 to 30000 do; - clear_screen; - exit - end; - clear_screen; - list_phonemes; - put_cursor (15,1); - write (dictionary[i].spelling,' = '); - display (dictionary[i].phonemes); - put_25; - clear_line; - write (' INS DLE SAY ACC XIT NEW'); - restore_cursor; - test_phoneme := dictionary[i].phonemes; - repeat - put_cursor (16,1); - clear_bottom; - case funct_key of - 'S': ins_phoneme; - 'T': kill_phoneme; - 'U': begin - sayit (test_phoneme); - say (chr($3f)) - end; - 'V': dictionary[i].phonemes := test_phoneme; - 'W': exit; - 'J': test_phoneme := dictionary[i].phonemes - end - until false - end; - - BEGIN - clear_screen; - put_cursor (3,30); - write ('Encode Word FUNCTION'); - continue := true; - while continue do - BEGIN - put_25; - clear_line; - write (' GET WRT SOD GFD XIT DLE RPT MOD HLP'); - restore_cursor; - put_cursor (15,1); - clear_bottom; - case funct_key of - 'S': get_entry; - 'T': put_in_dictionary; - 'U': save_on_disk; - 'V': get_from_disk; - 'W': continue := false; - 'P': rpt_word; - 'J': kill_word; - 'R': help; - 'Q': modify_phonemes - end (* case *) - end; (* while *) - put_25; - clear_line; - restore_cursor - end; - - Procedure help; - - (* this PROCEDURE displays the summary of the commands - allowed in the main menu *) - - var - i: integer; - - BEGIN - clear_screen; - put_cursor (3,30); - write ('Summary of Commands'); - for i := 1 to 8 do - BEGIN - put_cursor (i+4,20); - case i of - 1: write ('ENC (f1): Encode a word'); - 2: write ('DIS (f2): Disassemble a word into its phonemes'); - 3: write ('CHA (f3): Modify the phonemes within a word'); - 4: write ('SAY (f4): Say a word'); - 5: write ('CPM (f5): Return to CP/M operating system'); - 6: write ('LST (blue): List the current dictionary'); - 7: write ('SEN (red): Enunciate a sentence'); - 8: write ('HLP (grey): Display summary of commands') - end (* case *) - end; (* for *) - for i := 1 to 30000 do - end; - - PROCEDURE display (var str: string); - (* this PROCEDURE displays the phoneme codes for - an utterance passed to it *) - - var - i: integer; - nmemonic: string[4]; - - BEGIN - for i := 1 to length(str) do - BEGIN - disasm (str[i],nmemonic); - write (nmemonic,' ') - end - end; - - PROCEDURE LIST_WORDS; - - var - i,j,k: integer; - - BEGIN - clear_screen; - put_cursor (1,20); - write ('Dictionary Contents (',entry,' entries)'); - k := 1; - for i := 0 to (entry div 20) do - BEGIN - for j := 1 to 20 do - BEGIN - put_cursor(j+1,1+15*i); - if dictionary[k].filled then - write (k:3,' ',dictionary[k].spelling); - k := k + 1; - if (k > entry) or (k > 100) then exit - end (* for j *) - end (* for i *) - end; - -procedure say_sentence; -(* this procedure implements the function which will enunciate - a sentence entered on the console keyboard *) - -var - sentence: string; - phon_string: string [40]; - word_list: array [1..40] of integer; - test_spell: string [14]; - dummy_spell: string [14]; - dummy_ch: char; - i,j,k: integer; - -BEGIN - list_words; - put_cursor (22,1); - write ('Enter a SENTENCE in all CAPITAL letters'); - put_cursor (23,1); - clear_line; - read (sentence); - i := 1; - j := 1; - repeat - test_spell := ''; (* clear out the test string *) - repeat - test_spell := concat(test_spell,sentence[j]); - j := j + 1 - until (sentence[j] = ' ') or (j = length(sentence)); - j := j + 1; (* skip over the space *) - k := 0; - repeat - k := k + 1 - until (test_spell = dictionary[k].spelling) or (k > entry); - if k <= entry then - sayit (dictionary[k].phonemes); - i := i + 1 - until (i > 40) or (j >= length(sentence)); - say (chr ($3f)) - -(* put_cursor (23,1); - clear_line; - for i := 1 to 20 do - begin - k := word_list[i]; - write (dictionary[k].spelling,' '); - phon_string := dictionary[k].phonemes; - sayit (phon_string); - say (chr($3f)) - end *) -end; - -BEGIN (* MAIN PROGRAM STARTS HERE *) - - out [parctl] := ctrpar; - say (chr($3f)); (* turn off SC-01 chip *) - for i := 1 to 100 do dictionary[1].spelling := ''; - repeat - clear_screen; - put_cursor (3,10); - write ('Voice Synthesis Development Software Package 10-25-81'); - - put_25; - clear_line; - write ( -' ENC DIS SAY CPM LST SEN HLP'); - restore_cursor; - - put_cursor (23,10); - write ('Select a FUNCTION:'); - - case funct_key of - 'S': encode; - 'T': BEGIN - put_cursor (11,5); - clear_bottom; - write ('Which word? '); - read (word_spelling); - i := 0; - repeat - i := i + 1; - until (i>100) or (word_spelling = dictionary[i].spelling); - if i > 100 then - begin - put_cursor (13,5); - write (word_spelling,' not found'); - exit - end; - put_cursor (13,5); - write (dictionary[i].spelling,' = '); - display (dictionary[i].phonemes); - while funct_key <> 'T' do - end; - 'V': BEGIN - put_cursor (11,5); - clear_bottom; - write ('Which word? '); - word_spelling := ''; - read (word_spelling); - i := 0; - repeat - i := i+1; - until (word_spelling = dictionary[i].spelling) or - (i > entry); - if i <= entry then - begin - sayit (dictionary[i].phonemes); - say (chr($3f)) - end - else - begin - put_cursor (11,5); - clear_bottom; - write (word_spelling,' is not in this dictionary'); - while funct_key <> 'V' do - end - end; - 'W': BEGIN - put_25; - clear_line; - restore_cursor; - clear_screen; - exit - end; - 'P': begin - list_words; - while funct_key <> 'P' do - end; - 'Q': say_sentence; - 'R': help - end (* case *) - until false -end. - -end. -se -end. -e * \ No newline at end of file diff --git a/software/CPM/CPM14_MTPUG_02/XREF.CMD b/software/CPM/CPM14_MTPUG_02/XREF.CMD deleted file mode 100644 index 4c02e56..0000000 --- a/software/CPM/CPM14_MTPUG_02/XREF.CMD +++ /dev/null @@ -1,3 +0,0 @@ -xref -paslib/s - \ No newline at end of file diff --git a/software/CPM/CPM14_MTPUG_02/XREF.COM b/software/CPM/CPM14_MTPUG_02/XREF.COM deleted file mode 100644 index 22be477..0000000 Binary files a/software/CPM/CPM14_MTPUG_02/XREF.COM and /dev/null differ diff --git a/software/CPM/CPM14_MTPUG_02/XREF.DOC b/software/CPM/CPM14_MTPUG_02/XREF.DOC deleted file mode 100644 index 10d90bf..0000000 --- a/software/CPM/CPM14_MTPUG_02/XREF.DOC +++ /dev/null @@ -1,38 +0,0 @@ - - - - Cross Reference Program by: Warren A. Smith - - Thió prograí camå mainlù froí Nikolauó Wirtè aó yoõ wilì - seå iæ yoõ reaä thå sourcå code® However¬ É havå addeä onå majoò - iteí whicè É likå verù much¬ anä thaô ió á graphicaì listinç oæ - the block structuring of your program. - Alì compounä statementó arå delimiteä bù lineó whicè arå - connecteä anä nesteä (iæ thå statementó arå nested)® Aî examplå - might be: - - B-------------begin - ! If True then - ! B-------------begin - ! ! statement; - ! ! statement - ! E-------------end - ! else - ! statement; - ! statement - E-------------end; - - This can be very helpful in a large, complex program. - - Onå oæ thå sidå benefitó ió iî findinç missinç ENÄ - statements® Iæ yoõ dï noô havå matchinç BEGIÎ anä END'ó yoõ wilì - noticå thaô thå verticaì baró traiì ofæ aô thå enä oæ youò - program® Bù followinç thoså lineó tï theiò matchinç BEGIÎ yoõ - will have found the culprit. - Onå probleí - therå ió nï waù thå outpuô oæ thió prograí caî - takå aî inpuô sourcå filå whicè maù bå 8° columnó widå anä puô - thå outpuô (witè thå graphó aó above© oî youò terminaì withouô iô - lookinç verù bad® Sï É recommenä á 13² columî printeò oò á disë - filå thaô yoõ caî scaî aô leisure¬ preferablù witè somethinç thaô - will not wrap the excess lines around your screen. - \ No newline at end of file diff --git a/software/CPM/CPM14_MTPUG_02/XREF.ERL b/software/CPM/CPM14_MTPUG_02/XREF.ERL deleted file mode 100644 index fd45ee8..0000000 Binary files a/software/CPM/CPM14_MTPUG_02/XREF.ERL and /dev/null differ diff --git a/software/CPM/CPM14_MTPUG_02/XREF.PAS b/software/CPM/CPM14_MTPUG_02/XREF.PAS deleted file mode 100644 index 8c58f3c..0000000 --- a/software/CPM/CPM14_MTPUG_02/XREF.PAS +++ /dev/null @@ -1,717 +0,0 @@ -(*====================================================================*) -(* PROGRAM TITLE: PASCAL CROSS-REFERENCING PROGRAM *) -(* *) -(* PROGRAM NAME: XREF *) -(* *) -(* LAST UPDATE: 14-JUL-81 by Warren A. Smith *) -(* *) -(* NOTE: THIS PROGRAM WAS ORIGINALLY WRITTEN BY N. WIRTH AND *) -(* ADAPTED FOR UCSD PASCAL (I.4 - THE PUBLIC DOMAIN VERSION) *) -(* BY SHAWN FANNING (IN 1978) AND SUBSEQUENTLY ADAPTED FOR *) -(* PASCAL/MT+ BY MIKE LEHMAN (IN 1981). THIS VERSION WAS THEN *) -(* MODIFIED BE WARREN A. SMITH TO TRY TO GET BACK TO ISO STAN- *) -(* DARD PASCAL AND TO ADD THE ADDITIONAL FEATURE OF MAPPING *) -(* OUT THE COMPOUND STATEMENTS. THIS IS A PUBLIC DOMAIN PROGRAM. *) -(* IF YOU MAKE REVISIONS, ETC. PLEASE LEAVE THE AUTHOR *) -(* AND ALL MODIFIERS NAMES IN THE SOURCE FILE. THANK YOU. *) -(* *) -(* PROGRAM SUMMARY: *) -(* *) -(* THIS PROGRAM PRODUCES A CROSS-REFERENCE LISTING FOR ANY *) -(* PASCAL PROGRAM. OCCURENCES ONLY ARE LISTED. NO DISTINCTION IS *) -(* MADE BETWEEN DEFINITIONS AND REFERENCES. IT WILL ALSO GIVE A *) -(* GRAPHICAL REPRESENTATION OF THE BLOCK STRUCTURE OF THE PROGRAM. *) -(* THIS FEATURE WAS ADDED BY WARREN A. SMITH (IN JULY 1981) *) -(*====================================================================*) - - -PROGRAM XREF; - -(*CROSS REFERENCE GENERATOR FOR PASCAL PROGRAMS. N.WIRTH, 7.5.74*) -(*'QUADRATIC QUOTIENT' HASH METHOD*) - -CONST - P = 749; (*SIZE OF HASHTABLE*) - NK = 45; (*NO. OF KEYWORDS*) - PAGESIZE = 60; (*LINES PER PAGE*) - ALFALEN = 8; (*SIZE OF IDENTIFIERS*) - REFSPERLINE = 15; - REFSPERITEM = 5; - NESTMAX = 10 ; - -TYPE - ALFA = PACKED ARRAY[1..ALFALEN] OF CHAR; - INDEX = 0..P; - ITEMPTR = ^ITEM; - WORD = RECORD - KEY: ALFA; - FIRST, LAST: ITEMPTR; - FOL: INDEX - END ; - NUMREFS = 1..REFSPERITEM; - REFTYPE = (COUNT, PTR); - ITEM = RECORD - REF : ARRAY[NUMREFS] OF INTEGER; - CASE REFTYPE OF - COUNT: (REFNUM: NUMREFS); - PTR: (NEXT: ITEMPTR) - END ; - BUFFER = PACKED ARRAY[0..131] OF CHAR; - -VAR - TOP: INDEX; (*TOP OF CHAIN LINKING ALL ENTRIES IN T*) - I,LINECOUNT,BUFCURSOR: INTEGER; (*CURRENT LINE NUMBER*) - FF,CH: CHAR; (*CURRENT CHAR SCANNED *) - BUF : BUFFER; - T: ARRAY [INDEX] OF WORD; (*HASH TABLE*) - KEY: ARRAY [1..NK] OF ALFA; (* RESERVED KEYWORD TABLE *) - ERROR, (* ERROR FLAG *) - LISTING: BOOLEAN; (* LISTING OPTION *) - INFILE: TEXT; - LST : TEXT; - LSTFILENAME : STRING; - INPUT_LINE : STRING; - PAGE_NUM, - NESTLVL, - LAST_KEY : INTEGER ; - ABORT, - LITERAL, - ACOMMENT, - BCOMMENT, - EOL, - NESTUP, - NESTDN : BOOLEAN ; - BAR : CHAR ; - -FUNCTION UPPER (CH : CHAR) : CHAR ; - - BEGIN (* UPPER *) - IF (CH >= 'a') AND (CH <= 'z') THEN - UPPER := CHR(ORD(CH) + (ORD('A') - ORD('a'))) - ELSE - UPPER := CH - END ; (* UPPER *) - -PROCEDURE INITIALIZE; -VAR - I : INTEGER; - -PROCEDURE FIRSTHALF; -BEGIN - KEY[ 1] := 'AND '; - KEY[ 2] := 'ARRAY '; - KEY[ 3] := 'BEGIN '; - KEY[ 4] := 'BOOLEAN '; - KEY[ 5] := 'CASE '; - KEY[ 6] := 'CHAR '; - KEY[ 7] := 'CONST '; - KEY[ 8] := 'DIV '; - KEY[ 9] := 'DOWNTO '; - KEY[10] := 'DO '; - KEY[11] := 'ELSE '; - KEY[12] := 'END '; - KEY[13] := 'EXIT '; - KEY[14] := 'FILE '; - KEY[15] := 'FOR '; - KEY[16] := 'FUNCTION'; -END; - -PROCEDURE SECONDHALF; -BEGIN - KEY[17] := 'GOTO '; - KEY[18] := 'IF '; - KEY[19] := 'IN '; - KEY[20] := 'INPUT '; - KEY[21] := 'INTEGER '; - KEY[22] := 'MOD '; - KEY[23] := 'NIL '; - KEY[24] := 'NOT '; - KEY[25] := 'OF '; - KEY[26] := 'OR '; - KEY[27] := 'OUTPUT '; - KEY[28] := 'PACKED '; - KEY[29] := 'PROCEDUR'; - KEY[30] := 'PROGRAM '; - KEY[31] := 'REAL '; - KEY[32] := 'RECORD '; - KEY[33] := 'REPEAT '; - KEY[34] := 'SET '; - KEY[35] := 'STRING '; - KEY[36] := 'TEXT '; - KEY[37] := 'THEN '; - KEY[38] := 'TO '; - KEY[39] := 'TYPE '; - KEY[40] := 'UNTIL '; - KEY[41] := 'VAR '; - KEY[42] := 'WHILE '; - KEY[43] := 'WITH '; - KEY[44] := 'WRITE '; - KEY[45] := 'WRITELN '; -END; - -BEGIN (* INITIALIZE *) - FOR I := 1 TO 25 DO { clear the screen } - WRITELN ; - WRITELN('Pascal Program Xref Utility'); - WRITELN('This program is public domain'); - WRITELN('Contributed by Warren A. Smith -- July 14, 1981'); - FOR I := 1 TO 13 DO - WRITELN ; - FF:=CHR(12); - ERROR := FALSE; - FOR I := 0 TO P DO - T[I].KEY := ' '; - FIRSTHALF; - SECONDHALF; - LINECOUNT:= 1; - TOP := P; - PAGE_NUM := 1 ; - LITERAL := FALSE ; - ACOMMENT := FALSE ; - BCOMMENT := FALSE ; - NESTLVL := 0 ; - LAST_KEY := 0 ; - BAR := '|' ; - CH := ' ' -END; (* INITIALIZE *) - -PROCEDURE OPENFILES; -VAR - I : INTEGER ; - NUMBLOCKS: INTEGER; - OPENOK: BOOLEAN; - OPENERRNUM : INTEGER; - LISTOPTION: CHAR; - FILENAME: STRING; - -BEGIN (* OPEN *) - WRITELN ; - WRITELN ('An answer of a $ character to any question') ; - WRITELN (' will cause the program to abort.') ; - ABORT := FALSE ; - REPEAT - WRITELN; - WRITELN('Type in the name of the file you want cross-referenced.' ); - WRITELN(' The file will also have the compound statements displayed'); - WRITELN(' if you select the list option. '); - READLN( FILENAME ); - IF LENGTH(FILENAME) > 0 THEN - BEGIN - FOR I := 1 TO LENGTH(FILENAME) DO - FILENAME[I] := UPPER(FILENAME[I]) ; - ABORT := FILENAME[1] = '$' ; - IF NOT ABORT THEN - BEGIN - -{---------------------------------------------------------------} -{ This section is implementation dependent. It will work } -{ for UCSD Pascal or Pascal/MT+ but not for Pascal/Z. } -{ For Pascal/Z, use } -{ RESET (FILENAME,INFILE); } -{---------------------------------------------------------------} -{} ASSIGN(INFILE,FILENAME); {} -{} RESET(INFILE); {} -{---------------------------------------------------------------} - - OPENERRNUM := IORESULT; - OPENOK := ( OPENERRNUM <> 255 ); - ABORT := EOF (INFILE) ; - IF NOT OPENOK THEN - WRITELN( '*** INPUT OPEN ERROR #', OPENERRNUM ) - ELSE - IF ABORT THEN - WRITELN ('*** FILE ', FILENAME,' IS EMPTY, PROGRAM ABORTING') - END - END; - UNTIL OPENOK OR ABORT; - - IF NOT ABORT THEN - BEGIN - WRITELN; - WRITELN('Destination file or device name?'); - WRITE (' The default is LST: - '); - READLN(LSTFILENAME); - WRITELN; - IF LENGTH (LSTFILENAME) <= 0 THEN - LSTFILENAME := 'LST:' ; - ABORT := LSTFILENAME [1] = '$' ; - IF NOT ABORT THEN - BEGIN - FOR I := 1 TO LENGTH(LSTFILENAME) DO - LSTFILENAME[I] := UPPER(LSTFILENAME[I]) ; - -{---------------------------------------------------------------} -{ This section is implementation dependent. It will work } -{ for UCSD Pascal or Pascal/MT+ but not for Pascal/Z. } -{ For Pascal/Z, use } -{ REWRITE (LSTFILENAME, LST); } -{---------------------------------------------------------------} -{} ASSIGN(LST,LSTFILENAME); {} -{} REWRITE(LST) {} -{---------------------------------------------------------------} - END - END ; - - IF NOT ABORT THEN - BEGIN - REPEAT - WRITE( 'Do you want a listing (y or n)? ' ); - READ( LISTOPTION ); - WRITELN ; - ABORT := LISTOPTION = '$' - UNTIL ABORT OR (LISTOPTION IN ['Y','y','N','n']); - IF NOT ABORT THEN - BEGIN - LISTING := NOT(LISTOPTION in ['N','n']) ; - WRITELN ; - IF LISTING THEN - WRITELN ('LIST OPTION ON') - ELSE - WRITELN - END - END -END; (* OPEN *) - -FUNCTION TAB (NUM : INTEGER) : CHAR ; - - VAR - I : INTEGER ; - - BEGIN - FOR I := 1 TO NUM DO - WRITE (LST, ' ') ; - TAB := CHR(0) - END ; (* TAB *) - -PROCEDURE LPWRITELN; -VAR - I : INTEGER; -BEGIN - BUF[BUFCURSOR]:=CHR(13); - BUFCURSOR:=BUFCURSOR+1; - FOR I := 0 TO BUFCURSOR-1 DO - WRITE(LST,BUF[I]); - BUFCURSOR:=0; - LINECOUNT:=LINECOUNT+1; - IF (LINECOUNT MOD PAGESIZE) = 0 THEN - PAGE(LST); -END; - -PROCEDURE PUTALFA(S:ALFA); -BEGIN - MOVELEFT(S[1],BUF[BUFCURSOR],8); - BUFCURSOR:=BUFCURSOR+8; -END; - -PROCEDURE PUTNUMBER(NUM: INTEGER); -VAR I,IPOT:INTEGER; - A: ALFA; - CH: CHAR; - ZAP:BOOLEAN; - -BEGIN - ZAP:=TRUE; - IPOT:=10000; - A[1]:=' '; - FOR I:= 2 TO 6 DO - BEGIN - CH:=CHR(NUM DIV IPOT + ORD('0')); - IF I <> 6 THEN - IF ZAP THEN - IF CH = '0' THEN - CH:=' ' - ELSE ZAP:=FALSE; - A[I]:=CH; - NUM:=NUM MOD IPOT; - IPOT:=IPOT DIV 10; - END; - A[7]:=' '; - MOVELEFT(A,BUF[BUFCURSOR],7); - BUFCURSOR:=BUFCURSOR+7; -END; - -PROCEDURE SEARCH( ID: ALFA ); (*MODULO P HASH SEARCH*) -(*GLOBAL: T, TOP*) -VAR - I,J,H,D : INTEGER; - X : ITEMPTR; - F : BOOLEAN; - -BEGIN - J:=0; - FOR I:= 1 TO ALFALEN DO - J:= J*10+ORD(ID[I]); - H := ABS(J) MOD P; - F := FALSE; - D := 1; - REPEAT - IF T[H].KEY = ID - THEN - BEGIN (*FOUND*) - F := TRUE; - IF T[H].LAST^.REFNUM = REFSPERITEM - THEN - BEGIN - NEW(X); - X^.REFNUM := 1; - X^.REF[1] := LINECOUNT; - T[H].LAST^.NEXT:= X; - T[H].LAST := X; - END - ELSE - WITH T[H].LAST^ DO - BEGIN - REFNUM := REFNUM + 1; - REF[REFNUM] := LINECOUNT - END - END - ELSE - IF T[H].KEY = ' ' - THEN - BEGIN (*NEW ENTRY*) - F := TRUE; - NEW(X); - X^.REFNUM := 1; - X^.REF[1] := LINECOUNT; - T[H].KEY := ID; - T[H].FIRST := X; - T[H].LAST := X; - T[H].FOL := TOP; - TOP := H - END - ELSE - BEGIN (*COLLISION*) - H := H+D; - D := D+2; - IF H >= P - THEN - H := H - P; - IF D = P - THEN - BEGIN - WRITELN(OUTPUT,'TBLE OVFLW'); - ERROR := TRUE - END ; - END - UNTIL F OR ERROR -END (*SEARCH*) ; - - - -PROCEDURE PRINTWORD(W: WORD); -VAR - L: INTEGER; - X: ITEMPTR; - NEXTREF : INTEGER; - THISREF: NUMREFS; -BEGIN - PUTALFA(W.KEY); - X := W.FIRST; - L := 0; - REPEAT - IF L = REFSPERLINE - THEN - BEGIN - L := 0; - LPWRITELN; - PUTALFA(' '); - END ; - L := L+1; - THISREF := (L-1) MOD REFSPERITEM + 1; - NEXTREF := X^.REF[ THISREF ]; - IF THISREF = X^.REFNUM - THEN - X := NIL - ELSE - IF THISREF = REFSPERITEM - THEN - X := X^.NEXT; - PUTNUMBER(NEXTREF); - UNTIL X = NIL; - LPWRITELN; -END (*PRINTWORD*) ; - -PROCEDURE PRINTTABLE; - -VAR - I,J,M: INDEX; - -BEGIN - I := TOP; - WHILE I <> P DO - BEGIN (*FIND MINIMAL WORD*) - M := I; - J := T[I].FOL; - WHILE J <> P DO - BEGIN - IF T[J].KEY < T[M].KEY - THEN - M := J; - J := T[J].FOL - END ; - PRINTWORD(T[M]); - IF M <> I THEN - BEGIN - T[M].KEY:=T[I].KEY; - T[M].FIRST:=T[I].FIRST; - T[M].LAST:=T[I].LAST; - END; - I := T[I].FOL - END -END (*PRINTTABLE*) ; - -PROCEDURE OUTPUT_LINE (BUF : BUFFER) ; - - VAR - I : INTEGER ; - - PROCEDURE FILL_LINE (VAR LINE : BUFFER) ; - - VAR I : INTEGER ; - - BEGIN (* FILL_LINE *) - I := 1 ; - WHILE (LINE[I] = ' ') DO - BEGIN - LINE[I] := '-' ; - I := I + 1 - END - END ; (* FILL_LINE *) - - - - PROCEDURE PRTNEST (VAR LINE : BUFFER) ; - - VAR COL : INTEGER ; - - - BEGIN (* PRTNEST *) - FOR COL := 1 TO NESTLVL - 1 DO - WRITE (LST, BAR, ' ') ; - IF NESTLVL > 0 THEN - IF NESTUP OR NESTDN THEN - BEGIN - IF NESTDN THEN - BEGIN - WRITE (LST, BAR, ' ') ; - WRITE (LST, 'E--') ; - FOR COL := NESTLVL+2 TO NESTMAX DO - WRITE (LST, '---') - END - ELSE - BEGIN - WRITE (LST, 'B--') ; - FOR COL := NESTLVL+1 TO NESTMAX DO - WRITE (LST, '---') - END ; - FILL_LINE (LINE) - END - ELSE - BEGIN - WRITE (LST, BAR, ' ') ; - FOR COL := NESTLVL+1 TO NESTMAX DO - WRITE (LST, ' ') - END - ELSE - IF NESTDN THEN - BEGIN - WRITE (LST, 'E--') ; - FOR COL := 2 TO NESTMAX DO - WRITE (LST, '---') ; - FILL_LINE (LINE) - END - ELSE - FOR COL := 1 TO NESTMAX DO - WRITE (LST, ' ') - END ; (* PRTNEST *) - - BEGIN (* OUTPUT_LINE *) - IF ((LINECOUNT MOD PAGESIZE) = 0) OR (PAGE_NUM = 1) THEN - BEGIN - IF LISTING THEN - BEGIN - PAGE (LST) ; - WRITELN (LST, TAB(70), 'PAGE ', PAGE_NUM:1) ; - WRITELN (LST) ; - PAGE_NUM := PAGE_NUM + 1 - END ; - IF (LSTFILENAME <> 'CON:') AND ((LINECOUNT MOD PAGESIZE) = 0) THEN - WRITELN (OUTPUT, '< ', LINECOUNT:4, ',', MEMAVAIL:5, ' >') - END ; - WRITE (LST, LINECOUNT:4, ' ') ; - PRTNEST (BUF) ; - FOR I := 1 TO BUFCURSOR DO - WRITE (LST, BUF[I]) ; - WRITELN (LST) ; - IF LSTFILENAME <> 'CON:' THEN - WRITE (OUTPUT, '.') - END ; (* OUTPUT_LINE *) - - -PROCEDURE GETNEXTCHAR; -VAR I : INTEGER; - -BEGIN (* GETNEXTCHAR *) -IF BUFCURSOR >= LENGTH (INPUT_LINE) THEN - BEGIN - EOL := TRUE ; - CH := ' ' ; - ERROR := EOF(INFILE) - END -ELSE - BEGIN - BUFCURSOR := BUFCURSOR + 1 ; - CH := INPUT_LINE [BUFCURSOR] ; - BUF [BUFCURSOR] := CH ; - CH := UPPER(CH) - END -END; (* GETNEXTCHAR *) - - -PROCEDURE GETIDENTIFIER; -VAR - J,K,I: INTEGER; - ID: ALFA; - -BEGIN (* GETIDENTIFIER *) - I := 0; - ID := ' '; - REPEAT - IF I < ALFALEN - THEN - BEGIN - I := I+1; - ID[I] := CH - END; - GETNEXTCHAR - UNTIL ( NOT(((CH>='A') AND (CH<='Z')) OR (CH='_') - OR ((CH>='0') AND (CH<='9')))) OR (ERROR); - I := 1; - J := NK; - REPEAT - K := (I+J) DIV 2; (*BINARY SEARCH*) - IF KEY[K] <= ID - THEN - I := K+1; - - IF KEY[K] >= ID - THEN - J := K-1; - - UNTIL I > J; - IF KEY[K] <> ID THEN - SEARCH(ID) - ELSE - BEGIN - IF (K=3) OR ((K=5) AND (LAST_KEY<>32)) OR { BEGIN or CASE } - (K=32) OR (K=33) THEN { RECORD or REPEAT } - BEGIN - LAST_KEY := K ; - IF NESTLVL = NESTMAX THEN - WRITE (LST, '----Too many levels') - ELSE - BEGIN - NESTLVL := NESTLVL + 1 ; - NESTUP := TRUE - END - END ; - IF (K=12) OR (K=40) THEN { END or UNTIL } - IF NESTLVL = 0 THEN - WRITE (LST, '----Nesting error ') - ELSE - BEGIN - NESTLVL := NESTLVL - 1 ; - NESTDN := TRUE - END - END - -END; (* GETIDENTIFIER *) - -BEGIN (* CROSSREF *) - - INITIALIZE; - - OPENFILES; - - WHILE NOT EOF(INFILE) AND (NOT ABORT) DO - BEGIN - BUFCURSOR:= 0; - NESTUP := FALSE ; - NESTDN := FALSE ; - READLN (INFILE, INPUT_LINE) ; - IF LENGTH (INPUT_LINE) > 0 THEN - BEGIN - EOL := FALSE ; - BUFCURSOR := BUFCURSOR + 1 ; - CH := INPUT_LINE [BUFCURSOR] ; - BUF [BUFCURSOR] := CH ; - CH := UPPER (CH) - END - ELSE - BEGIN - EOL := TRUE ; - CH := ' ' - END ; - WHILE NOT EOL DO - BEGIN - IF ((CH >= 'A') AND (CH <= 'Z')) AND (NOT LITERAL) AND - (NOT ACOMMENT) AND (NOT BCOMMENT) THEN - GETIDENTIFIER - ELSE - IF (CH = '''') OR LITERAL THEN - BEGIN - REPEAT - GETNEXTCHAR; - UNTIL (CH = '''') OR (ERROR) OR EOL; - LITERAL := EOL ; - GETNEXTCHAR - END - ELSE - IF (CH = '{') OR ACOMMENT THEN - BEGIN - WHILE (CH <> '}') AND (NOT ERROR) AND (NOT EOL) DO - GETNEXTCHAR ; - ACOMMENT := EOL ; - GETNEXTCHAR - END - ELSE - IF (CH = '(') OR BCOMMENT THEN - BEGIN - IF NOT BCOMMENT THEN - GETNEXTCHAR; - IF (CH = '*') OR BCOMMENT THEN - BEGIN - IF NOT BCOMMENT THEN - GETNEXTCHAR; - REPEAT - WHILE (CH <> '*') AND (NOT ERROR) AND (NOT EOL) DO - GETNEXTCHAR ; - BCOMMENT := EOL ; - IF NOT EOL THEN - GETNEXTCHAR - UNTIL (CH = ')') OR ERROR OR EOL ; - IF NOT EOL THEN - GETNEXTCHAR - END - END - ELSE - GETNEXTCHAR; - - END; (* WHILE *) - EOL := FALSE ; - OUTPUT_LINE (BUF) ; - LINECOUNT := LINECOUNT + 1 - END ; - IF NOT ABORT THEN - BEGIN - PAGE(LST); - LINECOUNT := 0; - BUFCURSOR := 0; - PRINTTABLE; - PAGE(LST); - CLOSE(LST,I); - IF I = 255 THEN - WRITELN('Error closing output file') - END -END. - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/-MTPUG.003 b/software/CPM/CPM15_MTPUG_03/-MTPUG.003 deleted file mode 100644 index e69de29..0000000 diff --git a/software/CPM/CPM15_MTPUG_03/ACOUSTIC.PAS b/software/CPM/CPM15_MTPUG_03/ACOUSTIC.PAS deleted file mode 100644 index e962c3d..0000000 --- a/software/CPM/CPM15_MTPUG_03/ACOUSTIC.PAS +++ /dev/null @@ -1,214 +0,0 @@ -Module Acoustic_Coupler; - -{ Written by Warren A. Smith } -{ intended for the public domain } -{ 01/30/82 } - -{ This set of routines is meant to be compatible with those found in } -{ DCMODEM (for the D.C. Hayes modem). It is intended that with these } -{ routines you will be able to write programs that can utilize either } -{ the D.C. Hayes modem (or the PMMI modem when I get around to it) or } -{ an acoustic coupler and use them interchangeably by re-linking with } -{ the appropriate library. } - -{ Port assignments for serial port of acoustic coupler } -Const - Status_Reg_Modem= $03; - Modem_Rcv_Reg = $02; - Modem_Xmit_Reg = $02; - - -Procedure Init_Modem; - - Const Char_Length = 3; { 8 data bits } - Stop_bits = 0; { 1 stop bits } - Parity_Inhibit = 1; { no parity } - Parity_Type = 1; { even parity } - Baud = 300; { 300 baud } - - begin { Init_Modem } - { This routine is intended for use as an initializing routine } - { if your serial port needs it. You should set up your port } - { to match the comments above. } - end; { Init_Modem } - -Procedure Set_Modem (Modebyte : byte); - - begin { Set_Modem } - { This routine lets you change the various modes of the modem, } - { most acoustic couplers can't do anything. } - end; { Set_Modem } - -Procedure Go_Onhook (Var Modem_Mode : byte); - - begin { Go_Onhook } - Clrbit (Modem_Mode, 7); - Set_Modem (Modem_Mode) - end; { Go_Onhook } - -Procedure Go_Offhook (Var Modem_Mode : byte); - - begin { Go_Offhook } - SetBit (Modem_Mode, 7); - Set_Modem (Modem_Mode) - end; { Go_Offhook } - -Procedure Set_Ans_Mode (Var Modem_Mode : byte); - - begin { Set_Ans_Mode } - Clrbit (Modem_Mode, 2); - Set_Modem (Modem_Mode) - end; { Set_Modem_Mode } - -Procedure Set_Org_Mode (Var Modem_Mode : byte); - - begin { Set_Org_Mode } - Setbit (Modem_Mode, 2); - Set_Modem (Modem_Mode) - end; { Set_Org_Mode } - -Procedure Set_Baud (Baud : integer; Var Modem_Mode : byte); - - begin { Set_Baud } - Case Baud of - 110 : Clrbit (Modem_Mode, 0); - 300 : Setbit (Modem_Mode, 0); - else Setbit (Modem_Mode, 0); - end; - Set_Modem (Modem_Mode) - end; { Set_Baud } - -Procedure Enable_Xmit (Var Modem_Mode : byte); - - begin { Enable_Xmit } - Setbit (Modem_Mode, 1); - Set_Modem (Modem_mode) - end; { Enable_Xmit } - -Procedure Disable_Xmit (Var Modem_Mode : byte); - - begin { Disable_Xmit } - Clrbit (Modem_Mode, 1); - Set_Modem (Modem_Mode) - end; { Disable_Xmit } - -Function Carrier_Present : boolean; - - begin { Carrier_Present } - { If you have your serial port wired up to recieve a carrier } - { detect signal then you should test for that bit, otherwise } - { just return TRUE. } - Carrier_Present := TRUE -{ Carrier_Present := Tstbit (Inp[Status_Reg_Modem], 6) } - end; { Carrier_Present } - -Function Ringing : boolean; - - begin { Ringing } - { Most ports can't detect ringing so just return FALSE. } - Ringing := FALSE -{ Ringing := not Tstbit (Inp[Status_Reg_Modem]), 7) } - end; { Ringing } - -Function Modem_Char_Rdy : boolean; - - begin { Modem_Char_Rdy } - { Returns TRUE if data is available in the input port } - { (does NOT read the data) } - Modem_Char_Rdy := Tstbit (Inp[Status_Reg_Modem], 1) - end; { Modem_Char_Rdy } - -Function Modem_In : char; - - begin { Modem_In } - { Reads the data port of the acoustic coupler. May have to } - { mask off bit 7 of the data if the sender is not treating it } - { as part of the data byte sent. } - Modem_In := chr(Inp[Modem_Rcv_Reg] & $7F) - end; { Modem_In } - -Function Modem_Out (OutChar : char) : boolean; - - Function Modem_Busy : boolean; - - begin { Modem_Busy } - { Returns TRUE if the transmit buffer empty bit of status port } - { indicates that the UART is still transmitting. } - Modem_Busy := not Tstbit (Inp[Status_Reg_Modem], 0) - end; { Modem_Busy } - - begin { Modem_Out } - While Modem_Busy do; - If Carrier_Present then - begin - Out [Modem_Xmit_Reg] := ord(OutChar); - Modem_Out := TRUE - end - else - Modem_Out := FALSE - end; { Modem_Out } - -Procedure Delay; { delay's for 10 millisecond } - - Const - Count = 477; - Var - I : integer; - - begin { Delay } - { Very machine dependent. I am using a 5 MHz 8085, running } - { Pascal MT+ 5.5 if that helps. } - For I := 1 to Count do - end; { Delay } - -Procedure Dial_a_Number (Var Modem_Mode : byte; Number : string); - - Var - I, J, Pulse_Count : integer; - - Procedure Pulse_Line; - - Var - I : integer; - begin { Pulse_Line } - Go_Onhook (Modem_Mode); - For I := 1 to 5 do - Delay; { leave on for 50 ms } - Go_Offhook (Modem_Mode); - For I := 1 to 5 do - Delay { leave off for 50 ms } - end; { Pulse_Line } - - begin { Dial_a_Number } - { Included as an example of how to do it. } - Go_Offhook (Modem_Mode); - For I := 1 to 100 do - Delay; - For I := 1 to Length(Number) do - If (Number[I] < '0') OR (Number[I] > '9') then - begin - Write (Number[I]); - For J := 1 to 300 do { wait 3 seconds for non_digit } - Delay - end - else - begin - Pulse_Count := ord(Number[I]) - $30; - If Pulse_Count = 0 then - Pulse_Count := 10; - Write (Number[I]); - For J := 1 to Pulse_Count do - Pulse_Line; - For J := 1 to 60 do - Delay { 600 ms delay between digits } - end; - Writeln; - Writeln('All right dummy, now that you''ve watched me, let''s see if'); - Writeln('you know how to dial a phone. Make the connection, and hit'); - Writeln('RETURN when you get a carrier.'); - Readln - end; { Dial_a_Number } - - -Modend. - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/CALCAL.SRC b/software/CPM/CPM15_MTPUG_03/CALCAL.SRC deleted file mode 100644 index 735589f..0000000 Binary files a/software/CPM/CPM15_MTPUG_03/CALCAL.SRC and /dev/null differ diff --git a/software/CPM/CPM15_MTPUG_03/CIRCQUE.PAS b/software/CPM/CPM15_MTPUG_03/CIRCQUE.PAS deleted file mode 100644 index 6a727b9..0000000 --- a/software/CPM/CPM15_MTPUG_03/CIRCQUE.PAS +++ /dev/null @@ -1,72 +0,0 @@ -Module Circular_Queue ; - -{ Written by Warren A. Smith } -{ Intended for use in the public domain } -{ 01/30/82 } - -{ These routines are meant to give you a way to handle circular queues. } -{ Or FIFO buffers, whatever you want to call them. They are very handy } -{ for buffering between asynchronous events and I got tired of having } -{ to rewrite them so I put them into this library. I hope you find } -{ them useful (or instructive, whatever). } - -Type - Q_range = Min_Q..Max_Q ; - Q_Type = byte ; { Could be any type } - Queue = record - Q_not_empty, - Q_not_full : boolean ; - Q_head, - Q_tail : Q_Range ; - Q : array [Q_Range] of Q_Type ; - end ; - -Function Put_Q (Var Cur_Q : Queue ; Var Cur_Entry : Q_Type) : boolean ; - - begin { Put_Q } - With Cur_Q do - If Q_not_full then - begin - Q[Q_head] := Cur_Entry ; - If Q_head = Max_Q then - Q_head := Min_Q - else - Q_head := Q_head + 1 ; - Q_not_full := Q_head <> Q_tail ; - Q_not_empty := TRUE ; - Put_Q := TRUE - end - else - Put_Q := FALSE - end ; { Put_Q } - -Function Get_Q (Var Cur_Q : Queue ; Var Cur_Entry : Q_Type) : boolean ; - - begin { Get_Q } - With Cur_Q do - If Q_not_empty then - begin - Cur_Entry := Q[Q_tail] ; - If Q_tail = Max_Q then - Q_tail := Min_Q - else - Q_tail := Q_tail + 1 ; - Q_not_full := TRUE ; - Q_not_empty := Q_head <> Q_tail ; - Get_Q := TRUE - end - else - Get_Q := FALSE - end ; { Get_Q } - -Procedure Init_Q (Var Cur_Q : Queue); - - begin { Init_Q } - Q_not_Empty := FALSE; - Q_not_Full := TRUE; - Q_head := Min_Q; - Q_tail := Q_head - end; { Init_Q } - -ModEnd. - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/CMPXLIB.DOC b/software/CPM/CPM15_MTPUG_03/CMPXLIB.DOC deleted file mode 100644 index 2294073..0000000 --- a/software/CPM/CPM15_MTPUG_03/CMPXLIB.DOC +++ /dev/null @@ -1,39 +0,0 @@ -CMPXLIB: Complex math library for Pascal; by Ficomp, Inc., Fairfax, Va. -This library uses pointer variables so that functions rather than procedures -can be used. Reference: "Information Hiding in Pascal", Michael B. Feldman, -BYTE, November 1981, pp. 493-498. - -As pointed out in the reference, the problem with pointer variables is that -a new record is created every time a complex function is called. Temporary -record space is not reused unless it is specifically released with the -built-in function DISPOSE( ). These library functions create temporary -records that will automatically be erased when used in a subsequent complex -operation. The CPERM( ) procedure will mark a complex number so that it will -not be erased until DISPOSE( ) is used. The program segment below illustrates -the use of the functions: - -1 T1:=CMPLX(SQR(COS(RPSI)),0.0); -2 T1:=CSQRT(CMPXO(N2,'-',T1)); -3 CPERM(T1); -4 T2:=CMPLX(SIN(RPSI),0.0); -5 IF POL = 'V' THEN -6 T2:=CMPXO(T2,'*',N2); -7 CPERM(T2); -8 GAMA:=POLAR(CMPXO(CMPXO(T2,'-',T1),'/',CMPXO(T2,'+',T1))); -9 DISPOSE(T1); -10 DISPOSE(T2); -11 LAG:=-ANG(GAMA); -12 IF LAG < 0 THEN -13 LAG:=LAG+PI_2; -14 WRITELN(MAG(GAMA),LAG); -15 DISPOSE(GAMA); - -In line 1, complex variable T1 is created. In line 2 T1 is replaced by a new -T1. The old T1 was erased by CMPXO function call. That intermediate variable -was also erased by the CSQRT function. In line 3, T1 is made permanent because -it will be used twice in line number 8. T2 is treated in the same manner in -lines 4 to 7. Lines 9 and 10 erase T1 & T2 since they are no longer needed. -All of the intermediate complex numbers created in line 8 are automatically -erased as they are used. In line 15, GAMA is specifically erased, since it -is no longer needed. - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/CMPXLIB.SRC b/software/CPM/CPM15_MTPUG_03/CMPXLIB.SRC deleted file mode 100644 index 9375b8b..0000000 --- a/software/CPM/CPM15_MTPUG_03/CMPXLIB.SRC +++ /dev/null @@ -1,234 +0,0 @@ -{CMPXLIB: Complex math library for Pascal; by Ficomp, Inc., Fairfax, Va. -This library uses pointer variables so that functions rather than procedures -can be used. Reference: "Information Hiding in Pascal", Michael B. Feldman, -BYTE, November 1981, pp. 493-498. - -As pointed out in the reference, the problem with pointer variables is that -a new record is created every time a complex function is called. Temporary -record space is not reused unless it is specifically released with the -built-in function DISPOSE( ). These library functions create temporary -records that will automatically be erased when used in a subsequent complex -operation. The CPERM( ) procedure will mark a complex number so that it will -not be erased until DISPOSE( ) is used. The program segment below illustrates -the use of the functions: - -1 T1:=CMPLX(SQR(COS(RPSI)),0.0); -2 T1:=CSQRT(CMPXO(N2,'-',T1)); -3 CPERM(T1); -4 T2:=CMPLX(SIN(RPSI),0.0); -5 IF POL = 'V' THEN -6 T2:=CMPXO(T2,'*',N2); -7 CPERM(T2); -8 GAMA:=POLAR(CMPXO(CMPXO(T2,'-',T1),'/',CMPXO(T2,'+',T1))); -9 DISPOSE(T1); -10 DISPOSE(T2); -11 LAG:=-ANG(GAMA); -12 IF LAG < 0 THEN -13 LAG:=LAG+PI_2; -14 WRITELN(MAG(GAMA),LAG); -15 DISPOSE(GAMA); - -In line 1, complex variable T1 is created. In line 2 T1 is replaced by a new -T1. The old T1 was erased by CMPXO function call. That intermediate variable -was also erased by the CSQRT function. In line 3, T1 is made permanent because -it will be used twice in line number 8. T2 is treated in the same manner in -lines 4 to 7. Lines 9 and 10 erase T1 & T2 since they are no longer needed. -All of the intermediate complex numbers created in line 8 are automatically -erased as they are used. In line 15, GAMA is specifically erased, since it -is no longer needed. -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} - -MODULE CMPXLIB; -{$M CMPLX} -{$M RE} -{$M IM} -{$M PHASOR} -{$M MAG} -{$M ANG} -{$M CMPXO} -{$M POLAR} -{$M CART} -{$M CSQR} -{$M CSQRT} -{$M CRECP} -{$M CONJG} -{$M CABS} -{$M CPERM} -{$M *} - -TYPE - CMPXNUM = RECORD - RE_PART,IM_PART: REAL - TEMPSTO: BOOLEAN - END; - COMPLEX = ^CMPXNUM; - -VAR - P:COMPLEX; - NR,NI,NRE,NIM,T:REAL; - -EXTERNAL PROCEDURE @ERR(AN_ERROR:BOOLEAN;ERRNUM:INTEGER); -EXTERNAL FUNCTION ATAN2(X,Y:REAL): REAL; - -FUNCTION CMPLX(R,I:REAL): COMPLEX; -{to create complex number with cartesian coordinates} -BEGIN - NEW(P); - P^.RE_PART := R; - P^.IM_PART := I; - P^.TEMPSTO := TRUE; - CMPLX := P -END; - -FUNCTION RE(N:COMPLEX): REAL; -{returns real part of complex number} -BEGIN - RE := N^.RE_PART -END; - -FUNCTION IM(N:COMPLEX): REAL; -{returns imaginary part of complex number} -BEGIN - IM := N^.IM_PART -END; - -FUNCTION PHASOR(M,A:REAL): COMPLEX; -{to create phasor from magnitude and angle} -BEGIN - NEW(P); - P^.RE_PART := M; - P^.IM_PART := A; - P^.TEMPSTO := TRUE; - PHASOR := P -END; - -FUNCTION MAG(N:COMPLEX): REAL; -{returns magnitude part of phasor} -BEGIN - MAG := N^.RE_PART -END; - -FUNCTION ANG(N:COMPLEX): REAL; -{returns angle part of phasor} -BEGIN - ANG := N^.IM_PART -END; - -FUNCTION CMPXO(N1:COMPLEX;OP:CHAR;N2:COMPLEX): COMPLEX; -{to add, subtract, miltiply, or divide complex numbers} -BEGIN - NR := RE(N1); - NI := IM(N1); - NRE := RE(N2); - NIM := IM(N2); - CASE OP OF - '+': {complex sum of 2 complex numbers, N1+N2} - CMPXO := CMPLX(NR+NRE,NI+NIM); - '-': {complex difference of 2 complex numbers, N1-N2} - CMPXO := CMPLX(NR-NRE,NI-NIM); - '*': {complex product of 2 complex numbers, N1*N2} - CMPXO := CMPLX(NR*NRE-NI*NIM,NR*NIM+NI*NRE); - '/': {complex quotient of 2 complex numbers, N1/N2} - BEGIN - T := SQR(NRE)+SQR(NIM); - CMPXO := CMPLX((NR*NRE+NI*NIM)/T,(NRE*NI-NR*NIM)/T) - END; - ELSE - BEGIN - @ERR(TRUE,4); - WRITELN(OP,' is an illegal complex operator'); - CMPXO := CMPLX(0.0,0.0) - END; - END; - CERASE(N1); - CERASE(N2) -END; - -FUNCTION POLAR(N:COMPLEX): COMPLEX; -{to convert complex number from cartesian to polar coordinates} -BEGIN - NR := RE(N); - NI := IM(N); - POLAR := PHASOR(SQRT(SQR(NR)+SQR(NI)),ATAN2(NR,NI)); - CERASE(N) -END; - -FUNCTION CART(N:COMPLEX): COMPLEX; -{to convert complex number from polar to cartesian coordinates} -BEGIN - NR := MAG(N); - NI := ANG(N); - CART := CMPLX(NR*COS(NI),NR*SIN(NI)); - CERASE(N) -END; - -FUNCTION CSQR(N:COMPLEX): COMPLEX; -{square of complex number, SQR(N)} -BEGIN - NR := RE(N); - NI := IM(N); - CSQR := CMPLX(SQR(NR)-SQR(NI),2*NR*NI); - CERASE(N) -END; - -FUNCTION CSQRT(N:COMPLEX): COMPLEX; -{square root of complex number, SQRT(N)} -BEGIN - NR := RE(N); - NI := IM(N); - T := SQRT((NR+SQRT(SQR(NR)+SQR(NI)))/2); - CSQRT := CMPLX(T,NI/(2*T)); - CERASE(N) -END; - -FUNCTION CRECP(N:COMPLEX): COMPLEX; -{recripical of complex number, 1/N} -BEGIN - NR := RE(N); - NI := IM(N); - T := SQR(NR)+SQR(NI); - CRECP := CMPLX(NR/T,-NI/T); - CERASE(N) -END; - -FUNCTION CONJG(N:COMPLEX): COMPLEX; -{conjugate of a complex number} -BEGIN - CONJG := CMPLX(RE(N),-IM(N)); - CERASE(N) -END; - -FUNCTION CABS(N:COMPLEX): REAL; -{absolute value of complex number, ABS(N)} -BEGIN - CABS := SQRT(SQR(RE(N))+SQR(IM(N))); - CERASE(N) -END; - -PROCEDURE CPERM(N:COMPLEX); -{to make complex number permanent} -BEGIN - N^.TEMPSTO := FALSE -END; - -PROCEDURE CERASE(N:COMPLEX); -{to release temporary complex variables} -BEGIN - IF N^.TEMPSTO THEN - DISPOSE(N) -END; - -MODEND. - - - -ASE(N:COMPLEX); -{to release temporary complex variables} -BEGIN - IF N^.TEMPSTO THEN - DISPOSE(N) -END; - -MODEND. - - diff --git a/software/CPM/CPM15_MTPUG_03/CRT.PAS b/software/CPM/CPM15_MTPUG_03/CRT.PAS deleted file mode 100644 index 9edacae..0000000 --- a/software/CPM/CPM15_MTPUG_03/CRT.PAS +++ /dev/null @@ -1,136 +0,0 @@ -Module CRT_Televideo; - -{ Written by Warren A. Smith } -{ Intended for use in the Public Domain } -{ 01/30/82 } - -{ This set of routines is designed to support a Televideo 912/920 type } -{ of terminal using direct I/O in CP/M (mainly for full screen type } -{ applications). } - -{$E-} { These constants are not to be used by external routines. } -Const - Direct_IO = 6 ; { CP/M direct I/O function } - -{ Constants used by GOTOXY routine, may have to be changed for your } -{ terminal. It is assumed the upper left corner is 0,0. } -{ The following constants are set up for a Televideo 912/920. } - Load_Cursor_Char = '='; - X_PLAC = 4 ; { Byte position of the X coordinate of escape seq. } - Y_PLAC = 3 ; { Byte position of the Y coordinate of escape seq. } - MAX_X = 79 ; { how many characters wide your screen is -1 } - MAX_Y = 23 ; { how many rows your screen has - 1 } - X_OFF = 32 ; { offset added to X coordinate before sending to crt } - Y_OFF = 32 ; { offset added to Y coordinate before sending to crt } -{$E+} - -External Function @BDOS(Func,Parm:integer):integer; - -Function Con_In : char ; { non-echoed input from the console } - - Const - Parm = 255; - - Begin { Con_In } - Con_In := chr(@BDOS(Direct_IO, Parm)) - end ; { Con_In } - -Procedure Con_Out (Out_Char : char) ; - - Var - Dummy : integer ; - - Begin { Con_Out } - Dummy := @BDOS(Direct_IO, ord(Out_Char)) - end ; { Con_Out } - -Function KeyPressed (Var In_Char : char) : Boolean ; - - Begin { KeyPressed } - In_Char := chr (@BDOS(Direct_IO, -1)); - KeyPressed := In_Char <> chr(0) - end ; { KeyPressed } - -Function Get_Console : char ; { waits for a single character from the } - { console. Does not echo it. } - - Var - In_Char : char; - - Begin { Get_Console } - While not KeyPressed (In_Char) do; - Get_Console := In_Char - end ; { Get_Console } - -Procedure GoToXY (X, Y : integer) ; - - Var - BUFFER : array [1..4] of char ; - - Begin { GoToXY } - BUFFER [1] := chr(27); { Escape character } - BUFFER [2] := Load_Cursor_Char; - If X < 0 Then - BUFFER [X_PLAC] := chr(X_OFF) - else - If X > MAX_X then - BUFFER [X_PLAC] := chr(MAX_X + X_OFF) - else - BUFFER [X_PLAC] := chr(X + X_OFF) ; - - If Y < 0 then - BUFFER [Y_PLAC] := chr(Y_OFF) - else - If Y > MAX_Y then - BUFFER [Y_PLAC] := chr(MAX_Y + Y_OFF) - else - BUFFER [Y_PLAC] := chr(Y + Y_OFF) ; - - Con_Out(Buffer[1]) ; - Con_Out(Buffer[2]) ; - Con_Out(Buffer[3]) ; - Con_Out(Buffer[4]) - - end ; { GoToXY } - -Procedure Home ; - - Begin { Home } - Con_Out (chr($1E)) - end ; { Home } - -Procedure ScreenClr ; - - Begin { ScreenClr } - Con_Out (chr(26)) - end ; { ScreenClr } - -Procedure LineClr; - - Begin { LineClr } - Con_Out (chr(27)); - Con_Out ('t') - end; { LineClr } - -Procedure Read_Cursor (Var X, Y : integer); - - Var - In_Char : char; - - begin { Read_Cursor } - { Request cursor coordinates from TeleVideo 912 or 920. A 2 MHz} - { 8080 may have trouble getting this from a 9600 baud line. } - { If this routine doesn't work, try slowing your terminals baud } - { rate down to 4800 or 2400. } - ConOut (chr(27)); - ConOut ('?'); - While not KeyPressed (In_Char) do; - Y := ord(In_Char) - Y_OFF; - While not KeyPressed (In_Char) do; - X := ord(In_Char) - X_OFF; - While not KeyPressed (In_Char) do; - { this last character is supposed to be a CR, it can be ignored. } - end; { Read_Cursor } - -ModEnd. - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/CUBE.COM b/software/CPM/CPM15_MTPUG_03/CUBE.COM deleted file mode 100644 index 5daf3b8..0000000 Binary files a/software/CPM/CPM15_MTPUG_03/CUBE.COM and /dev/null differ diff --git a/software/CPM/CPM15_MTPUG_03/CUBE.ERL b/software/CPM/CPM15_MTPUG_03/CUBE.ERL deleted file mode 100644 index 61f4649..0000000 Binary files a/software/CPM/CPM15_MTPUG_03/CUBE.ERL and /dev/null differ diff --git a/software/CPM/CPM15_MTPUG_03/CUBE.SRC b/software/CPM/CPM15_MTPUG_03/CUBE.SRC deleted file mode 100644 index 41f6e16..0000000 --- a/software/CPM/CPM15_MTPUG_03/CUBE.SRC +++ /dev/null @@ -1,285 +0,0 @@ -PROGRAM CUBE; - -{By Ed Reed - Tailored Computer Solutions - 1919 S. Newport - Kennewick, WA 99336 - - This program allows the user to manipulate Rubik's Cube without the hazards - of Cuber's Thumb, but somehow I can't imagine going blind at one's screen - being any better. There is a companion program, CUBESOLV, which can be - chained to or started independently which solves any mess a person can - create here which still represents a legitimate cube.} - -LABEL 1, 2; - -TYPE - - ROW = STRING[7]; {Length of seven is chosen for ease of output, which} - FACE = {is unfolded so that all faces are visible. Positions} - RECORD {1, 4, and 7 are the colors and the rest are blank.} - A : ROW; - B : ROW; - C : ROW - END; - -VAR - - U : ABSOLUTE [$7000] FACE; {Up (top)} {Faces are left in core where} - D : ABSOLUTE [$7020] FACE; {Down (bottom)} {CUBESOLV can access them.} - F : ABSOLUTE [$7040] FACE; {Front} - B : ABSOLUTE [$7060] FACE; {Back} - L : ABSOLUTE [$7080] FACE; {Left} - R : ABSOLUTE [$70A0] FACE; {Right} - S : FACE; {Spare} - ESC, OPTN, HOME, COLOR : CHAR; - MOVES, XPOS, YPOS : INTEGER; - CHAINFIL : FILE; - MSTORE : ARRAY [-80 .. 400] OF CHAR; -{ -\NP -} -{The repertoire of legal moves is as follows. Anything else is ignored. - R -- Rotate right face clockwise. - r -- Rotate right face counterclockwise. - L -- Rotate left face clockwise. - l -- Rotate left face counterclockwise. - U -- Rotate up face clockwise. - u -- Rotate up face counterclockwise. - D -- Rotate down face clockwise. - d -- Rotate down face counterclockwise. - F -- Rotate front face clockwise. - f -- Rotate front face counterclockwise. - B -- Rotate back face clockwise. - b -- Rotate back face counterclockwise. - V -- Rotate vertical slice up. - v -- Rotate vertical slice down. - H -- Rotate horizontal slice right. - h -- Rotate horizontal slice left. - I -- Rotate invisible slice clockwise - i -- Rotate invisible slice counterclockwise. - X -- Rotate whole cube on X axis, front face to top. - x -- Rotate whole cube on X axis, front face to bottom. - Y -- Rotate whole cube on Y axis, top face to right. - y -- Rotate whole cube on Y axis, top face to left. - Z -- Rotate whole cube on Z axis, front face to right. - z -- Rotate whole cube on Z axis, front face to left. - Backspace -- Reverse the last move. - / -- Start over. - ? -- Quit. - > -- Proceed to CUBESOLV, which solves the mess you made. - Ctrl/E -- Enter your own pattern, any 6 characters for colors, except - do not use upper and lower case of the same letter. - Crtl/Z -- Loop forever (sorry about that). - - Note: A slice is a plane through the center of the cube containing four - face-center cubelets. Horizontal, vertical, and invisible are - as viewed from the front. - -\NP -} -PROCEDURE ENTER; - - LABEL 3; - - VAR NF, I, J : INTEGER; - - BEGIN - 3: - - FOR NF := 1 TO 6 DO - BEGIN - CASE NF OF - 1 : FIL_FACE (U, 12, 1); - 2 : FIL_FACE (L, 1, 8); - 3 : FIL_FACE (F, 12, 8); - 4 : FIL_FACE (R, 23, 8); - 5 : FIL_FACE (B, 34, 8); - 6 : FIL_FACE (D, 12, 15); - END; - END; - GOTOXY (1, 21); - WRITE (ESC, 'YHit return or blank if all O.K., ', - 'otherwise any other character.'); - READ (OPTN); - IF OPTN <> ' ' THEN GOTO 3; - WRITE (HOME, ESC, 'Y'); - FOR I := 1 TO 6 DO - BEGIN - CASE I OF - 1 : BEGIN COLOR := U.B[4]; OPTN := 'U' END; - 2 : BEGIN COLOR := L.B[4]; OPTN := 'L' END; - 3 : BEGIN COLOR := F.B[4]; OPTN := 'F' END; - 4 : BEGIN COLOR := R.B[4]; OPTN := 'R' END; - 5 : BEGIN COLOR := B.B[4]; OPTN := 'P' END; - 6 : BEGIN COLOR := D.B[4]; OPTN := 'D' END; - END; - FOR J := 1 TO 6 DO - BEGIN - CASE J OF - 1 : REPAINT (U); - 2 : REPAINT (L); - 3 : REPAINT (F); - 4 : REPAINT (R); - 5 : REPAINT (B); - 6 : REPAINT (D); - END - END - END - - END; -{ -\NP -} -PROCEDURE FIL_FACE (VAR X : FACE; XX, YY : INTEGER); - - VAR I, ROW : INTEGER; - - BEGIN - - WITH X DO - FOR ROW := 0 TO 2 DO - FOR I := 0 TO 2 DO - BEGIN - GOTOXY ((3 * I) + XX, (2 * ROW) + YY); - READ (OPTN); - CASE ROW OF - 0 : IF OPTN <> ' ' THEN A[(3 * I) + 1] := LCASE (OPTN); - 1 : IF OPTN <> ' ' THEN B[(3 * I) + 1] := LCASE (OPTN); - 2 : IF OPTN <> ' ' THEN C[(3 * I) + 1] := LCASE (OPTN) - END - END - - END; - -PROCEDURE REPAINT (VAR X : FACE); - - BEGIN - - WITH X DO - BEGIN - IF A[1] = COLOR THEN A[1] := OPTN; - IF A[4] = COLOR THEN A[4] := OPTN; - IF A[7] = COLOR THEN A[7] := OPTN; - IF B[1] = COLOR THEN B[1] := OPTN; - IF B[4] = COLOR THEN B[4] := OPTN; - IF B[7] = COLOR THEN B[7] := OPTN; - IF C[1] = COLOR THEN C[1] := OPTN; - IF C[4] = COLOR THEN C[4] := OPTN; - IF C[7] = COLOR THEN C[7] := OPTN; - END; - - END; - -FUNCTION LCASE (CC : CHAR) : CHAR; - - BEGIN - - IF CC IN ['A' .. 'Z'] THEN - LCASE := CHR (ORD (CC) + 32) - ELSE - LCASE := CC - - END; - -{$I B:CUBEUTIL} {Include the text of file CUBEUTIL.} -{ -\NP -} -BEGIN {CUBE} - - HOME := CHR ($1E); - ESC := CHR ($1B); -1: - WRITE (HOME, CHR ($1B), 'Y'); -{Initialize the cube.} - U.A := 'U U U'; U.B := 'U U U'; U.C := 'U U U'; - D.A := 'D D D'; D.B := 'D D D'; D.C := 'D D D'; - L.A := 'L L L'; L.B := 'L L L'; L.C := 'L L L'; - R.A := 'R R R'; R.B := 'R R R'; R.C := 'R R R'; - F.A := 'F F F'; F.B := 'F F F'; F.C := 'F F F'; - B.A := 'B B B'; B.B := 'B B B'; B.C := 'B B B'; -2: - OPTN := ' '; - FOR MOVES := -80 TO 400 DO - MSTORE[MOVES] := ' '; - MOVES := -1; -{Run it.} - WHILE OPTN <> '?' DO - BEGIN - DISPLAY; - MOVES := MOVES + 1; - XPOS := (MOVES MOD 80) + 1; - YPOS := (MOVES DIV 80) + 21; - GOTOXY (XPOS, YPOS); - READ (OPTN); - IF ORD (OPTN) = 8 THEN - BEGIN - OPTN := MSTORE[MOVES - 1]; - IF OPTN IN ['A' .. 'Z'] THEN - OPTN := CHR (ORD (OPTN) + 32) - ELSE - OPTN := CHR (ORD (OPTN) - 32); - MOVES := MOVES - 2 - END - ELSE IF ORD (OPTN) = 5 THEN - BEGIN - ENTER; - GOTO 2; - END - ELSE - MSTORE[MOVES] := OPTN; -{ -\NP -} - CASE OPTN OF - -'R' : BEGIN CW (R); VUP (7) END; -'r' : BEGIN CCW (R); VDOWN (7) END; -'L' : BEGIN CW (L); VDOWN (1) END; -'l' : BEGIN CCW (L); VUP (1) END; -'U' : BEGIN CW (U); HLEFT (1) END; -'u' : BEGIN CCW (U); HRIGHT (1) END; -'D' : BEGIN CW (D); HRIGHT (3) END; -'d' : BEGIN CCW (D); HLEFT (3) END; -'F' : BEGIN CW (F); ICW (1) END; -'f' : BEGIN CCW (F); ICCW (1) END; -'B' : BEGIN CW (B); ICCW (3) END; -'b' : BEGIN CCW (B); ICW (3) END; -'V' : BEGIN VUP (4) END; -'v' : BEGIN VDOWN (4) END; -'H' : BEGIN HRIGHT (2) END; -'h' : BEGIN HLEFT (2) END; -'I' : BEGIN ICW (2) END; -'i' : BEGIN ICCW (2) END; -'X' : BEGIN CW (R); VUP (1); VUP (4); VUP (7); CCW (L) END; -'x' : BEGIN CCW (R); VDOWN (1); VDOWN (4); VDOWN (7); CW (L) END; -'Y' : BEGIN CW (F); ICW (1); ICW (2); ICW (3); CCW (B) END; -'y' : BEGIN CCW (F); ICCW (1); ICCW (2); ICCW (3); CW (B) END; -'Z' : BEGIN CCW (U); HRIGHT (1); HRIGHT (2); HRIGHT (3); CW (D) END; -'z' : BEGIN CW (U); HLEFT (1); HLEFT (2); HLEFT (3); CCW (D) END; -'/' : GOTO 1; -'>' : BEGIN - ASSIGN (CHAINFIL, 'A:CUBESOLV.COM'); - RESET (CHAINFIL); - IF IORESULT = 255 THEN - BEGIN - ASSIGN (CHAINFIL, 'B:CUBESOLV.COM'); - RESET (CHAINFIL); - IF IORESULT = 255 THEN - BEGIN - WRITELN ('Error opening solution program file.'); - EXIT - END; - END; - CHAIN (CHAINFIL); - END; - - ELSE - MOVES := MOVES - 1 - END - END; - -END. - -EEªƒEAM CUBEnÿNŠ$…Hÿþ$J \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/CUBESOLV.COM b/software/CPM/CPM15_MTPUG_03/CUBESOLV.COM deleted file mode 100644 index 13ccbbd..0000000 Binary files a/software/CPM/CPM15_MTPUG_03/CUBESOLV.COM and /dev/null differ diff --git a/software/CPM/CPM15_MTPUG_03/CUBESOLV.ERL b/software/CPM/CPM15_MTPUG_03/CUBESOLV.ERL deleted file mode 100644 index aae99a1..0000000 Binary files a/software/CPM/CPM15_MTPUG_03/CUBESOLV.ERL and /dev/null differ diff --git a/software/CPM/CPM15_MTPUG_03/CUBESOLV.SRC b/software/CPM/CPM15_MTPUG_03/CUBESOLV.SRC deleted file mode 100644 index 9256bfd..0000000 --- a/software/CPM/CPM15_MTPUG_03/CUBESOLV.SRC +++ /dev/null @@ -1,583 +0,0 @@ -PROGRAM CUBESOLV; - -{Adapted from the book - The Simple Solution to Rubik's Cube, by James G. Nourse.} - -TYPE - - ROW = STRING[7]; - FACE = - RECORD - A : ROW; - B : ROW; - C : ROW - END; - -VAR - - U : ABSOLUTE [$7000] FACE; - D : ABSOLUTE [$7020] FACE; - F : ABSOLUTE [$7040] FACE; - B : ABSOLUTE [$7060] FACE; - L : ABSOLUTE [$7080] FACE; - R : ABSOLUTE [$70A0] FACE; - S : FACE; - OPTN, HOME, GO : CHAR; - MOVES : STRING[255]; - TEST, EDGE, CORN : STRING[3]; - ERS : STRING[2]; - DOWNERS : ARRAY [0 .. 8] OF STRING[12]; - COUNT : INTEGER; - -{$I B:CUBEUTIL} {Include the text of file CUBEUTIL.} - -FUNCTION MATCH (S1, S2 : STRING) : BOOLEAN; - -{True if S1 and S2 contain the same elements in any order.} - -VAR L1, I : INTEGER; - -BEGIN - - L1 := LENGTH (S1); - IF L1 = LENGTH (S2) THEN - BEGIN - MATCH := TRUE; - FOR I := 1 TO L1 DO - IF POS (S1[I], S2) = 0 THEN - BEGIN - MATCH := FALSE; - EXIT - END - END - ELSE - MATCH := FALSE - -END; -{ -\NP -} -PROCEDURE FLIP; - -VAR XPOS, YPOS : INTEGER; - -{Make a quarter-turn move for each character in the MOVES string. - See Program Cube for list of legitimate moves.} - -BEGIN - - XPOS := (COUNT MOD 80) + 1; - YPOS := (COUNT DIV 80) + 21; - GOTOXY (XPOS, YPOS); - WRITE (MOVES); - COUNT := COUNT + LENGTH (MOVES); - WHILE MOVES <> '' DO - BEGIN - OPTN := MOVES[1]; - DELETE (MOVES, 1, 1); - CASE OPTN OF - -'R' : BEGIN CW (R); VUP (7) END; -'r' : BEGIN CCW (R); VDOWN (7) END; -'L' : BEGIN CW (L); VDOWN (1) END; -'l' : BEGIN CCW (L); VUP (1) END; -'U' : BEGIN CW (U); HLEFT (1) END; -'u' : BEGIN CCW (U); HRIGHT (1) END; -'D' : BEGIN CW (D); HRIGHT (3) END; -'d' : BEGIN CCW (D); HLEFT (3) END; -'F' : BEGIN CW (F); ICW (1) END; -'f' : BEGIN CCW (F); ICCW (1) END; -'B' : BEGIN CW (B); ICCW (3) END; -'b' : BEGIN CCW (B); ICW (3) END; -'V' : BEGIN VUP (4) END; -'v' : BEGIN VDOWN (4) END; -'H' : BEGIN HRIGHT (2) END; -'h' : BEGIN HLEFT (2) END; -'I' : BEGIN ICW (2) END; -'i' : BEGIN ICCW (2) END; -'X' : BEGIN CW (R); VUP (1); VUP (4); VUP (7); CCW (L) END; -'x' : BEGIN CCW (R); VDOWN (1); VDOWN (4); VDOWN (7); CW (L) END; -'Y' : BEGIN CW (F); ICW (1); ICW (2); ICW (3); CCW (B) END; -'y' : BEGIN CCW (F); ICCW (1); ICCW (2); ICCW (3); CW (B) END; -'Z' : BEGIN CCW (U); HRIGHT (1); HRIGHT (2); HRIGHT (3); CW (D) END; -'z' : BEGIN CW (U); HLEFT (1); HLEFT (2); HLEFT (3); CCW (D) END; - - END - END - -END; -{ -\NP -} -PROCEDURE UP_EDG; - -VAR - - K, I : INTEGER; - -BEGIN - - FOR I := 1 TO 4 DO - BEGIN - -{Move up edges up to correct positions.} - - EDGE := CONCAT (U.B[4], F.B[4]); -{FU} IF MATCH (CONCAT (U.C[4], F.A[4]), EDGE) THEN - MOVES := '' - ELSE -{RU} IF MATCH (CONCAT (R.A[4], U.B[7]), EDGE) THEN - MOVES := 'rf' - ELSE -{BU} IF MATCH (CONCAT (U.A[4], B.A[4]), EDGE) THEN - MOVES := 'Uruf' - ELSE -{LU} IF MATCH (CONCAT (L.A[4], U.B[1]), EDGE) THEN - MOVES := 'LF' - ELSE -{FR} IF MATCH (CONCAT (F.B[7], R.B[1]), EDGE) THEN - MOVES := 'f' - ELSE -{BR} IF MATCH (CONCAT (R.B[7], B.B[1]), EDGE) THEN - MOVES := 'rrfrr' - ELSE -{BL} IF MATCH (CONCAT (B.B[7], L.B[1]), EDGE) THEN - MOVES := 'LLFLL' - ELSE -{FL} IF MATCH (CONCAT (F.B[1], L.B[7]), EDGE) THEN - MOVES := 'F' - ELSE -{DF} IF MATCH (CONCAT (F.C[4], D.A[4]), EDGE) THEN - MOVES := 'FF' - ELSE -{DR} IF MATCH (CONCAT (R.C[4], D.B[7]), EDGE) THEN - MOVES := 'dff' - ELSE -{DB} IF MATCH (CONCAT (D.C[4], B.C[4]), EDGE) THEN - MOVES := 'DDFF' - ELSE -{DL} IF MATCH (CONCAT (D.B[1], L.C[4]), EDGE) THEN - MOVES := 'DFF' - ELSE - BEGIN - DISPLAY; GOTOXY (40, 1); - WRITE (ERS, 'Up edge positioning error.'); - READ (GO) - END; - FLIP; - -{Orient up edges properly and rotate cube to next position.} - - IF ((U.C[4] = U.B[4]) AND (F.A[4] = F.B[4])) THEN - MOVES := 'Z' - ELSE IF ((U.C[4] = F.B[4]) AND (F.A[4] = U.B[4])) THEN - MOVES := 'fUluZ' - ELSE - BEGIN - DISPLAY; GOTOXY (40, 1); - WRITE (ERS, 'Up edge orientation error.'); READ (GO) - END; - FLIP - END; - IF GO = ' ' THEN DISPLAY; GOTOXY (35, 15); - WRITE ('Up edges finished in ', COUNT, ' moves.'); - IF GO = ' ' THEN READ (GO); - -END; -{ -\NP -} -PROCEDURE UP_CRN; - -VAR - - I, J, K : INTEGER; - -BEGIN - - FOR I := 1 TO 4 DO - BEGIN - -{Position up corners.} - - CORN := CONCAT (U.B[4], F.B[4], R.B[4]); - {Look on the down face first for desired cublet.} - J := 1; K := 0; - WHILE (K = 0) AND (J < 5) DO - BEGIN - J := J + 1; - TEST := CONCAT (F.C[7], D.A[7], R.C[1]); - IF MATCH (TEST, CORN) THEN - BEGIN - K := 9; - {Move it up, orienting it at the same time.} - IF R.C[1] = U.B[4] THEN - MOVES := 'rdRZ' - ELSE IF F.C[7] = U.B[4] THEN - MOVES := 'FDfZ' - ELSE - MOVES := 'rDRFDDfZ' - END - ELSE - MOVES := 'D'; - FLIP - END; - {If it wasn't on the down face, look on the up face.} - IF K <> 9 THEN - BEGIN - J := 1; - WHILE (K = 0) AND (J < 5) DO - BEGIN - TEST := CONCAT (U.C[7], F.A[7], R.A[1]); - IF MATCH (TEST, CORN) THEN - K := J - ELSE - BEGIN - J := J + 1; - MOVES := 'u'; FLIP - END - END; - {If positioned correctly, orient it correctly.} - IF K = 1 THEN - BEGIN - IF F.A[7] = U.B[4] THEN - MOVES := 'FDDfrDDRZ' - ELSE IF R.A[1] = U.B[4] THEN - MOVES := 'rddRFddfZ' - ELSE - MOVES := 'Z'; - END - ELSE IF K = 0 THEN - BEGIN - DISPLAY; GOTOXY (40, 1); - WRITE (ERS, 'Up corner positioning error.'); READ (GO) - END - {Wrong up corner. Move it down, then under desired position, then up.} - ELSE - BEGIN - MOVES := 'rdRD'; - FOR K := 2 TO J DO - MOVES := CONCAT (MOVES, 'U'); - FLIP; - IF R.C[1] = U.B[4] THEN - MOVES := 'rdRZ' - ELSE IF F.C[7] = U.B[4] THEN - MOVES := 'FDfZ' - ELSE - MOVES := 'rDRFDDfZ'; - END; - FLIP - END - END; - IF GO = ' ' THEN DISPLAY; GOTOXY (35, 16); - WRITE ('Up corners finished in ', COUNT, ' moves.'); - IF GO = ' ' THEN READ (GO); - -END; -{ -\NP -} -PROCEDURE VRT_EDG; - -{Position and orient vertical edges.} - -VAR - - I, J, K : INTEGER; - -BEGIN - - FOR I := 1 TO 4 DO - BEGIN - EDGE := CONCAT (F.B[4], R.B[4]); - TEST := CONCAT (F.B[7], R.B[1]); - IF MATCH (EDGE, TEST) THEN - {Right position.} - BEGIN - IF F.B[7] = F.B[4] THEN - MOVES := 'Z' {Correct} - ELSE - MOVES := 'rDRDFdfDrDRDFdfZ' {Backward} - END - ELSE - {Move it to the bottom if necessary.} - BEGIN - FOR J := 1 TO 3 DO - BEGIN - MOVES := 'Z'; FLIP; - TEST := CONCAT (F.B[7], R.B[1]); - IF MATCH (TEST, EDGE) THEN - BEGIN - MOVES := 'rDRDFdf'; FLIP - END - END; - MOVES := 'Z'; FLIP; - {Move it to the front.} - J := 0; - TEST := CONCAT (F.C[4], D.A[4]); - WHILE (NOT MATCH (TEST, EDGE)) AND (J < 4) DO - BEGIN - J := J + 1; - MOVES := 'D'; FLIP; - TEST := CONCAT (F.C[4], D.A[4]); - END; - {Move it into position, oriented correctly.} - IF (F.C[4] = F.B[4]) AND (D.A[4] = R.B[4]) THEN - MOVES := 'drDRDFdfZ' - ELSE IF (F.C[4] = R.B[4]) AND (D.A[4] = F.B[4]) THEN - MOVES := 'ddFdfdrDRZ' - ELSE - BEGIN - DISPLAY; GOTOXY (40, 1); - WRITE (ERS, 'Vertical edge positioning error.'); READ (GO) - END; - END; - FLIP - END; - IF GO = ' ' THEN DISPLAY; GOTOXY (35, 17); - WRITE ('Vertical edges finished in ', COUNT, ' moves.'); - IF GO = ' ' THEN READ (GO); - -END; -{ -\NP -} -PROCEDURE DOWN_CRN; - -{Position down corners.} - -VAR - - I, J, K, M, RIGHT : INTEGER; - DFR, DBL : BOOLEAN; - DTEST : STRING[12]; - -BEGIN - - RIGHT := 0; - {Twist and turn until two cubelets are found properly positioned.} - WHILE RIGHT < 2 DO - BEGIN - MOVES := 'D'; FLIP; - RIGHT := 0; - J := 0; - WHILE (RIGHT < 2) AND (J < 4) DO - BEGIN - J := J + 1; - MOVES := 'Z'; FLIP; - CORN := CONCAT (L.B[4], F.B[4], D.B[4]); - TEST := CONCAT (L.C[7], F.C[1], D.A[1]); - IF MATCH (CORN, TEST) THEN - RIGHT := RIGHT + 1 - END - END; - CORN := CONCAT (R.B[4], F.B[4], D.B[4]); - TEST := CONCAT (R.C[1], F.C[7], D.A[7]); - DFR := MATCH (CORN, TEST); - CORN := CONCAT (L.B[4], B.B[4], D.B[4]); - TEST := CONCAT (L.C[1], B.C[7], D.C[1]); - DBL := MATCH (CORN, TEST); - IF DFR AND (NOT DBL) THEN {Two incorrect cubelets at back.} - MOVES := 'zzrdRFDfrDRDD' - ELSE IF (NOT DFR) AND DBL THEN {Two incorrect cubelets at right.} - MOVES := 'zrdRFDfrDRDD' - ELSE IF (NOT DFR) AND (NOT DBL) THEN {Two incorrect cubelets diagonally.} - MOVES := 'zrdRFDDfrDRD'; - FLIP; - -{Orient down corners.} - - J := 0; - M := 0; - REPEAT - {Generate a string of everywhere a down - color on a down corner cubelet could be.} - DTEST := CONCAT (D.A[1], D.A[7], D.C[1], D.C[7], L.C[1], L.C[7], - F.C[1], F.C[7], R.C[1], R.C[7], B.C[1], B.C[7]); - FOR I := 1 TO 12 DO - IF DTEST[I] <> 'D' THEN DTEST[I] := ' '; - DOWNERS[8] := DTEST; - K := 0; - {Check it out against the "pictures" from the book.} - WHILE DTEST <> DOWNERS[K] DO - K := K + 1; - IF K = 0 THEN - {It is now correct.} - J := 0 - ELSE IF K = 8 THEN - {Not this orientation. Rotate cube and try again.} - BEGIN - MOVES := 'Z'; FLIP - END - ELSE - {Found it! Run the orientation sequence and iterate.} - BEGIN - J := 0; - M := M + 1; - MOVES := 'rdRdrddRdd'; FLIP - END; - J := J + 1; - UNTIL (K = 0) OR (J > 8) OR (M > 3); - IF (J > 8) OR (M > 3) THEN - BEGIN -GOTOXY (40, 2); WRITE ('K, J, M:', K:3, J:3, M:3); - DISPLAY; GOTOXY (40, 1); - WRITE (ERS, 'Down corner orientation errror.'); READ (GO); - END; - {Put front face in front, just for a little class.} - WHILE F.B[4] <> 'F' DO - BEGIN - MOVES := 'Z'; FLIP - END; - IF GO = ' ' THEN DISPLAY; GOTOXY (35, 18); - WRITE (ERS, 'Down corners finished in ', COUNT, ' moves.'); - IF GO = ' ' THEN READ (GO); - -END; -{ -\NP -} -PROCEDURE DOWN_EDG; - -LABEL 100, 110; - -VAR I, J : INTEGER; - -BEGIN - -100: - REPEAT - J := 0; - {Find number of properly positioned edges.} - FOR I := 1 TO 4 DO - BEGIN - EDGE := CONCAT (F.B[4], D.B[4]); - TEST := CONCAT (F.C[4], D.A[4]); - IF MATCH (EDGE, TEST) THEN - BEGIN - J := J + 1; - IF J < I THEN GOTO 110 {There's only one, and this is it.} - END; - MOVES := 'Z'; FLIP - END; -110: - IF J < 4 THEN - {If there is one, it's in front. If not, it doesn't matter which is front.} - BEGIN - MOVES := 'vDVDDvDV'; FLIP; - END; - UNTIL J = 4; - {All in position, now orient them.} - J := 0; - FOR I := 1 TO 4 DO - BEGIN - IF F.C[4] = F.B[4] THEN J := J + 1; - MOVES := 'Z'; FLIP - END; - IF J = 4 THEN - {Done! How lucky can you get?} - BEGIN END - ELSE IF J = 0 THEN - {Seldom happens, but worth considering.} - BEGIN - MOVES := 'vDDVDDvDVDDvDDVd'; FLIP {Done!} - END - ELSE - {OK, where are they?} - BEGIN - J := 0; - WHILE D.C[4] = 'D' DO - {Put a bad one at the back.} - BEGIN - MOVES := 'z'; FLIP; - J := J + 1; - IF J > 4 THEN - BEGIN - DISPLAY; GOTOXY (40, 1); - WRITE (ERS, 'Down edge error, try again.'); READ (GO); - GOTO 100 - END - END; - {Make sure there's a good one on the right.} - IF R.C[4] = 'D' THEN - BEGIN - MOVES := 'Z'; FLIP - END; - IF F.C[4] = 'D' THEN - {Bad ones front and back, whip out the longest sequence used.} - BEGIN - MOVES := 'vDVDvDVDvDDVDvDVDvDVDD'; FLIP {Done (whew).} - END - ELSE - {Bad ones back and left. Make some progress, rotate, and re-position.} - BEGIN - MOVES := 'vDVdvdVdvDDVzvDVDDvDV'; FLIP; - END - END; - GOTOXY (35, 19); - WRITE ('Down edges finished in ', COUNT, ' moves.'); - -END; -{ -\NP -} -BEGIN {CUBESOLV} - - HOME := CHR ($1E); {Top left corner.} - WRITE (HOME, CHR ($1B), 'Y'); {Go to home and clear screen.} - ERS := CONCAT (CHR ($1B), 'T'); {Erase to end of line.} - COUNT := 0; - DISPLAY; - GOTOXY (1, 21); - WRITELN ('Initial position. Press any key to continue.'); - WRITE ('(Press blank to pause after each step.)'); - READ (GO); - WRITE (HOME, CHR ($1B), 'Y'); - -{Test strings for orienting the down corners. One through seven - correspond to the numbered pictures in the book.} - DOWNERS[0] := 'DDDD '; {Correct} - - DOWNERS[1] := 'D D D D'; {One down color on down face; that one at} - DOWNERS[2] := 'D D D D '; {front left.} - - DOWNERS[3] := ' D D DD'; {No down colors on down face; down colors} - DOWNERS[7] := ' DD DD '; {on left and right at front.} - - DOWNERS[4] := ' D D D D'; {Two down colors on down face; down color} - DOWNERS[5] := ' DD DD '; {on front at left} - DOWNERS[6] := ' DD D D '; - - DOWNERS[8] := ' '; {This is a trick to make sure there is alway -s} - {one that matches. It gets filled in later.} - -{Put 'U' on up face and 'F' on front face, just to add a little class.} - IF F.B[4] = 'U' THEN MOVES := 'X' - ELSE IF D.B[4] = 'U' THEN MOVES := 'XX' - ELSE IF B.B[4] = 'U' THEN MOVES := 'x' - ELSE IF L.B[4] = 'U' THEN MOVES := 'Y' - ELSE IF R.B[4] = 'U' THEN MOVES := 'y' - ELSE MOVES := ''; FLIP; - WHILE F.B[4] <> 'F' DO - BEGIN - MOVES := 'Z'; FLIP - END; - - UP_EDG; {Do the up edges first.} - UP_CRN; {Then the up corners.} - VRT_EDG; {Then the vertical edges.} - DOWN_CRN; {Penultimately, the bottom corners.} - DOWN_EDG; {Last but not least, the bottom edges.} - -{Last class.} - WHILE F.B[4] <> 'F' DO - BEGIN - MOVES := 'Z'; FLIP - END; - - DISPLAY; - GOTOXY (1, 1); - -END. - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/CUBEUTIL.SRC b/software/CPM/CPM15_MTPUG_03/CUBEUTIL.SRC deleted file mode 100644 index 11304ec..0000000 Binary files a/software/CPM/CPM15_MTPUG_03/CUBEUTIL.SRC and /dev/null differ diff --git a/software/CPM/CPM15_MTPUG_03/DCMODEM.PAS b/software/CPM/CPM15_MTPUG_03/DCMODEM.PAS deleted file mode 100644 index 7e1de6c..0000000 --- a/software/CPM/CPM15_MTPUG_03/DCMODEM.PAS +++ /dev/null @@ -1,219 +0,0 @@ -Module DC_Hayes_Modem; - -{ Written by Warren A. Smith } -{ Intended for use in the Public Domain } -{ 01/30/82 } - -{ This set of routines will give you complete access to the functions } -{ of a D.C. Hayes Modem. } - -{ Port assignments for D.C. Hayes S-100 Modem board } -Const - Base_Register = $10; - Modem_Rcv_Reg = $10; { Base_register } - Modem_Xmit_Reg = $10; { Base_register } - Status_Reg_Modem= $11; { Base_register + 1 } - Reg1Modem = $11; { Base_register + 1 } - Reg2Modem = $12; { Base_register + 2 } - -{ These routines require that you declare a global variable in your } -{ main program that will hold the current status of the modem. It } -{ should be a BYTE type and will be passed into the various routines } -{ that set the modems modes. } - -Procedure Init_Modem; - - Const Char_Length = 3; { 8 data bits } - Stop_bits = 0; { 1 stop bits } - Parity_Inhibit = 1; { no parity } - Parity_Type = 1; { even parity } - - begin { Init_Modem } - { Initializes the serial port on the modem to the above values. } - { This is the only routine that outputs to Reg1Modem. } - Out [Reg1Modem] := SHL(Parity_Inhibit,4) ! SHL(Stop_bits,3) ! - SHL(Char_Length,1) ! Parity_Type - end; { Init_Modem } - -Procedure Set_Modem (Modebyte : byte); - - begin { Set_Modem } - { Used to set various modes of the modem, (this is the only } - { routine that outputs to Reg2Modem). } - Out [Reg2Modem] := Modebyte - end; { Set_Modem } - -Procedure Go_Onhook (Var Modem_Mode : byte); - - begin { Go_Onhook } - Clrbit (Modem_Mode, 7); - Set_Modem (Modem_Mode) - end; { Go_Onhook } - -Procedure Go_Offhook (Var Modem_Mode : byte); - - begin { Go_Offhook } - SetBit (Modem_Mode, 7); - Set_Modem (Modem_Mode) - end; { Go_Offhook } - -Procedure Set_Ans_Mode (Var Modem_Mode : byte); - - begin { Set_Ans_Mode } - Clrbit (Modem_Mode, 2); - Set_Modem (Modem_Mode) - end; { Set_Modem_Mode } - -Procedure Set_Org_Mode (Var Modem_Mode : byte); - - begin { Set_Org_Mode } - Setbit (Modem_Mode, 2); - Set_Modem (Modem_Mode) - end; { Set_Org_Mode } - -Procedure Set_Baud (Baud_Rate : integer; Var Modem_Mode : byte); - - begin { Set_Baud } - { The D.C. Hayes modem only allows 110 or 300 bps communication } - { so those are the only values allowed. Any other value results} - { in 300 baud. } - Case Baud_Rate of - 110 : Clrbit (Modem_Mode, 0); - 300 : Setbit (Modem_Mode, 0); - else Setbit (Modem_Mode, 0) - end; - Set_Modem (Modem_Mode) - end; { Set_Baud } - -Procedure Enable_Xmit (Var Modem_Mode : byte); - - begin { Enable_Xmit } - Setbit (Modem_Mode, 1); - Set_Modem (Modem_mode) - end; { Enable_Xmit } - -Procedure Disable_Xmit (Var Modem_Mode : byte); - - begin { Disable_Xmit } - Clrbit (Modem_Mode, 1); - Set_Modem (Modem_Mode) - end; { Disable_Xmit } - -Function Carrier_Present : boolean; - - begin { Carrier_Present } - Carrier_Present := Tstbit (Inp[Status_Reg_Modem], 6) - end; { Carrier_Present } - -Function Ringing : boolean; - - begin { Ringing } - Ringing := not Tstbit (Inp[Status_Reg_Modem], 7) - end; { Ringing } - -Function Modem_Char_Rdy : boolean; - - begin { Modem_Char_Rdy } - Modem_Char_Rdy := Tstbit (Inp[Status_Reg_Modem], 0) - end; { Modem_Char_Rdy } - -Function Modem_In : char; - - begin { Modem_In } - { Some systems require that bit 7 of incoming data be masked } - { off. That is because the sender may be forcing bit 7 high. } - { If the system you are talking to lets bit 7 be a real data } - { bit then you will not want to mask it off as it is here. This} - { setup will work for just about any time share service. } - Modem_In := chr(Inp[Modem_Rcv_Reg] & $7F) - end; { Modem_In } - -Function Modem_Out (OutChar : char) : boolean; - - { Modem_Out is a boolean function so that it can return the } - { status of the line. If carrier is lost you don't want to get } - { hung up in a status loop, and it would be nice to know when } - { carrier was actually lost. } - Function Modem_Busy : boolean; - - begin { Modem_Busy } - Modem_Busy := not Tstbit (Inp[Status_Reg_Modem], 1) - end; { Modem_Busy } - - begin { Modem_Out } - While Modem_Busy do; - If Carrier_Present then - begin - Out [Modem_Xmit_Reg] := ord(OutChar); - Modem_Out := TRUE - end - else - Modem_Out := FALSE - end; { Modem_Out } - -Procedure Delay; { delay's for 10 millisecond } - - Const - Count = 477; - Var - I : integer; - - begin { Delay } - { This loop was determined empirically. I put it in a tight } - { loop toggling an output port and attached a frequency counter } - { to that port. You may have to change the value of the } - { constant for your machine. I am using a 5 MHz 8085 on a } - { Godbout dual processor board and Pascal MT+ ver. 5.5 } - For I := 1 to Count do - end; { Delay } - -Procedure Dial_a_Number (Var Modem_Mode : byte; Number : string); - - Var - I, J, Pulse_Count : integer; - - Procedure Pulse_Line; - - Var - I : integer; - begin { Pulse_Line } - Go_Onhook (Modem_Mode); - For I := 1 to 5 do - Delay; { leave on for 50 ms } - Go_Offhook (Modem_Mode); - For I := 1 to 5 do - Delay { leave off for 50 ms } - end; { Pulse_Line } - - begin { Dial_a_Number } - { If this routine doesn't seem to be able to actually dial, the } - { problem is probably in the DELAY procedure. If it is not } - { delaying enough, the pulses will be too fast and the local } - { phone exchange may not respond to them. Try increasing the } - { constant in DELAY (doubling it will not hurt). } - Go_Offhook (Modem_Mode); - For I := 1 to 100 do - Delay; - For I := 1 to Length(Number) do - If (Number[I] < '0') OR (Number[I] > '9') then - begin - Write (Number[I]); - For J := 1 to 300 do { wait 3 seconds for non_digit } - Delay - end - else - begin - Pulse_Count := ord(Number[I]) - $30; - If Pulse_Count = 0 then - Pulse_Count := 10; - Write (Number[I]); - For J := 1 to Pulse_Count do - Pulse_Line; - For J := 1 to 60 do - Delay { 600 ms delay between digits } - end; - Writeln - end; { Dial_a_Number } - -Modend. - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/DIRFILE.ERL b/software/CPM/CPM15_MTPUG_03/DIRFILE.ERL deleted file mode 100644 index 1544fa7..0000000 Binary files a/software/CPM/CPM15_MTPUG_03/DIRFILE.ERL and /dev/null differ diff --git a/software/CPM/CPM15_MTPUG_03/DIRFILE.SRC b/software/CPM/CPM15_MTPUG_03/DIRFILE.SRC deleted file mode 100644 index 6826900..0000000 Binary files a/software/CPM/CPM15_MTPUG_03/DIRFILE.SRC and /dev/null differ diff --git a/software/CPM/CPM15_MTPUG_03/EPSON.DOC b/software/CPM/CPM15_MTPUG_03/EPSON.DOC deleted file mode 100644 index 358b38f..0000000 Binary files a/software/CPM/CPM15_MTPUG_03/EPSON.DOC and /dev/null differ diff --git a/software/CPM/CPM15_MTPUG_03/EPSON.ERL b/software/CPM/CPM15_MTPUG_03/EPSON.ERL deleted file mode 100644 index 1302c1a..0000000 Binary files a/software/CPM/CPM15_MTPUG_03/EPSON.ERL and /dev/null differ diff --git a/software/CPM/CPM15_MTPUG_03/EPSON.SRC b/software/CPM/CPM15_MTPUG_03/EPSON.SRC deleted file mode 100644 index 7cb62ac..0000000 --- a/software/CPM/CPM15_MTPUG_03/EPSON.SRC +++ /dev/null @@ -1,504 +0,0 @@ -{$K0} {$K2} {$K12} {$K13} {$K14} {$K15} -program epson; - -{ A print 'formatter' program to facilitate use of the epson } -{ Written by Harry Eckerson on 9/18/81 and last revised 12/7/81 } -{ This program requires erl files epson2, utilmod and paslib } -{ IT USES } -{ ******** NO cpm LST device IO ******* } -{ location of ioport's base = 80H } - -const - signon = ' Initializing EPSON (80H) - Procedure of H. Eckerson 12/7/81'; - maxthings = 10; - blank = ' '; - spec_c = '?'; {spec character in col 1 to detect spec action } - base = $80; - base7 = $87; - bell = 7; - c_ret = 13; { carriage return } - cr_lf = 10; { line feed } - -type - big_string = string[255]; -var - in_fil, - p_fil : text; - f_name, - str : string; - ok : char; - no_c, - code : boolean; - long_s : big_string; - count, i , - copies, last_copy, - ten_top, ten_bot, ten_page, - top, bottom, lines_per , spaces, - num, l_count, page_l, p_number : integer; - l_feed, d_strike, number, comp, emph : boolean; - -external function keypressed : boolean; -external procedure @HLT; -external procedure p_error (ok : char); -external procedure clr_line; -external procedure p_out(let_val : integer); -external procedure set_page(page_l : integer); -external procedure d_blanks( var d_line : string); -external function yes_1 - (var str : string; var zero_ch : boolean) : boolean; -external procedure init_io; -external function convert( var line : string; tenths : boolean): integer; -external procedure set_epson; - -procedure forms( prompt_n : integer); -const - width = 4; - mov_rt = 8; -begin -case prompt_n of -1 : writeln(chr(13),chr(13),chr(13),chr(13) , - ' The following format is selected:'); -2 : write(' Number of lines/inch (6,8 or 10): ', - lines_per div 10:width, blank:mov_rt); -3 : write(' Page length (inches): ', - ten_page div 10:2,'.',ten_page mod 10, blank:mov_rt); -4 : write(' Top margin (inches): ', - ten_top div 10:2,'.',ten_top mod 10, blank:mov_rt); -5 : write(' Bottom margin (inches): ', - ten_bot div 10:2,'.',ten_bot mod 10, blank:mov_rt); -6 : begin - write(' Characters/line (80 or 132): '); - if comp then write('132':width, blank:mov_rt) - else write( '80':width, blank:mov_rt) - end; -7 : write(' Spacing (1, 2 or 3): ' - ,spaces:width, blank:mov_rt); -8 : begin - write(' Letter quality print: '); - if emph then write('YES':width, blank:mov_rt) - else write('NO':width, blank:mov_rt) - end; -9 : write(' Strikes/letter (1 or 2): ', - ord(d_strike) mod 2 + 1:width, blank:mov_rt); -10 : begin - write(' Number pages: '); - if number then write( 'YES':width, blank:mov_rt) - else write( 'NO':width, blank:mov_rt) - end; -11 : write(' Starting page number: ', - p_number:width, blank:mov_rt); -12 : begin - writeln; - write(' Are these values correct? (Y/N) ') - end - end { cases } -end; { forms } - -function format_ok : boolean; -var i : integer; -begin - for i := 1 to 10 do - begin - forms(i); - writeln - end; - if number then forms(11); - writeln; - forms(12); - format_ok := yes_1(str, no_c) -end; {format_ok } - -procedure parameters; -var - str : string; - old_page, old_lines : integer; - done : boolean; -begin -old_lines := lines_per; -old_page := page_l; -repeat - page(output); - writeln - ('Enter file format parameters - selects the current value.'); - writeln; - - repeat - forms(2); - read(str); - num := convert(str,false) * 10; - if num in [60,80] then lines_per := num - else if num = 100 then lines_per := 103 - else if num <> 0 then clr_line - until num in [0,60,80,100]; - - forms(3); - read(str); - num := convert(str,true); - if num > 0 then ten_page := num; - - repeat - forms(4); - read(str); - if length(str) > 0 then num := convert(str,true) - else num := ten_top; - done := num < ten_page; - if done then begin - ten_top := num - end - else clr_line - until done; - - repeat - forms(5); - read(str); - if length(str) > 0 then num := convert(str,true) - else num := ten_bot; - done := num < ten_page -ten_top; - if done then begin - ten_bot := num - end - else clr_line - until done; - - - repeat - forms(6); - read(str); - if comp then num := 132 - else num := 80; - if length(str) > 0 then num := convert(str,false); - if not (num in [132,80]) then clr_line - until num in [80,132]; - comp := num = 132; - - repeat - forms(7); - read(str); - if length(str) > 0 then num := convert(str,false) - else num := spaces; - done := num in [1..3]; - if done - then begin - spaces := num - end - else clr_line - until done; - - if comp - then begin - emph := false; - forms(8); - writeln('Compressed ON'); - end - else begin - forms(8); - done := yes_1(str, no_c); - if not no_c then emph := done - end; - - repeat - forms(9); - read(str); - num := ord(d_strike) mod 2 + 1; - num := convert(str,false); - done := num in [0,1,2]; - if done then begin - if num > 0 then d_strike := num = 2 - end - else clr_line - until done; - - forms(10); - done := yes_1(str, no_c); - if not no_c then number := done; - - if number - then begin - forms(11); - read(str); - if length(str) >0 then p_number := convert(str,false) - end; - - page(output); - done := format_ok - - until done; { end of overall repeat loop } - - l_count := (l_count * lines_per) div old_lines; - page_l := ten_page * lines_per div 100; - top := ten_top * lines_per div 100; - bottom := ten_bot * lines_per div 100; - - { actually sends codes to epson } - if page_l <> old_page - then begin - init_io; {note 1st time old_page=-66} - set_page(page_l) - end; - set_epson -end; { parameters } - - -procedure end_page; -var - on : boolean; - m, divid, mov_d, i : integer; -begin - mov_d := 0; - for i := l_count downto 1 - do begin - p_out(cr_lf); - l_count := l_count - 1 - end; - if number and (p_number > 1) then begin - mov_d := (bottom - 1 ) div 2; - for i := 1 to mov_d do p_out(cr_lf); {move to line to be numbered } - if comp then m := 64 { number of char to center of page } - else m := 38; - for i := 1 to m do p_out(ord(blank)); - p_out(ord('-')); - divid := 1000; - i := p_number; - m := i; - on := false; - repeat - i := i div divid; - m := m mod divid; - if ( i > 0) or on - then begin - p_out(i + 48); - on := true - end; - i := m; - divid := divid div 10; - until divid = 0; - p_out(ord('-')); - mov_d := mov_d + 1; { for line feed here } - p_out(cr_lf) - end; { when a page to be numbered } - for i := bottom - mov_d downto 1 do p_out(cr_lf); - if number then p_number := p_number + 1 -end; { end_page } - -procedure print_f; -var - copy_active, - i : integer; - let : char; - -procedure spec_act; -var - i : integer; -begin -while long_s[1] = spec_c - do begin - long_s[1] := blank; - case long_s[2] of - '#' : - begin - num := convert(long_s,false) * 10; - if num = 100 then num := 103; - if num in [60,80,103] then begin - bottom := (bottom * num ) div lines_per; - l_count := (l_count * num) div lines_per; - top := (top * num) div lines_per; - page_l :=(ten_page * num) div 100; - page_l := page_l - top - bottom; - lines_per := num - end { if when in 6,8,10 } - end; - - 'C','c' : - begin - comp := (pos('Y',long_s) =3) or (pos('y',long_s) =3); - if comp then emph := false - end; - - 'D','d' : - d_strike := (pos('Y',long_s) =3) or (pos('y',long_s) =3); - - - 'L','l' : - emph := (pos('Y',long_s) =3) or (pos('y',long_s) =3) - and not comp; - - 'N','n' : - begin - str := copy(long_s,3,length(long_s) - 2); - d_blanks(str); - writeln('Closing ',f_name,' & opening ',str); - f_name := str; - close(p_fil,count); - open(p_fil,f_name,count); - if count = 255 - then begin - writeln('IOERR on ',f_name,' ABORTING.'); - @HLT - end - end; - - 'O','o' : l_feed := false; - - 'P','p' : - begin - if length(long_s) > 3 - then begin - number := true; - p_number := convert(long_s,false) - end - else number := false - end; - - 'S','s' : - begin - num := convert(long_s,false); - if num in [1..3] then spaces := num - { this way if S7 given its ignored } - end; - - 'T','t' : begin - end_page; - for i := 1 to top do p_out(cr_lf); - l_count := page_l-top-bottom - end - end; { case } - num := pos(spec_c, long_s); - if num > 0 then delete(long_s,1, num - 1) - else if eof(p_fil) - then begin - l_feed := false; - long_s :='' - end - else readln(p_fil,long_s) - end; { while } - set_epson -end; - -begin { body of print_f } - l_feed := true; - page(output); - writeln; writeln; writeln; writeln; - write('How many copies? '); - read(str); - copies := convert(str,false); - if copies < 1 then copies := 1; - copy_active := 1; - - writeln('Press to start printing.'); - read(str); - if l_count < 1 - then begin - l_count := page_l - top - bottom; - for i := 1 to top do p_out(cr_lf) - end; - while not eof(p_fil) - do begin - readln(p_fil, long_s); - if long_s[1] = spec_c then spec_act; - for i := 1 to length(long_s) do p_out(ord(long_s[i]) ); - i := 0; - if l_feed - then repeat - p_out(cr_lf); - i := i + 1; - l_count := l_count - 1 - until (i = spaces) or (l_count = 0) - else begin - l_feed := true; - p_out(c_ret) - end; - if keypressed - then begin - read(let); - if let = chr(19) - then read(let) - else begin - writeln(' ABORT? (Y/N) '); - if yes_1(str, no_c) then exit - end - end; { when keypressed } - if l_count <= 0 then end_page; - if eof(p_fil) and (copies > 1) - then begin - copies := copies -1; - reset(p_fil); - if l_count > 0 then end_page; - p_number := 1 - end; { if eof & copies > 0 } - - if l_count <= 0 - then begin - for i := 1 to top do p_out(cr_lf); - l_count := page_l -top - bottom - end - end; { while } -{ put things back to default if changed } -last_copy := 0 -end; { print_f } - -begin -page(output); -writeln; -writeln; -writeln; -writeln(signon); - -{ set default format } - top := 3; bottom := 3; lines_per := 60; page_l := -66; p_number := 1; - number := false; comp := false; emph := false; d_strike := false; - spaces := 1; ten_page := 110; ten_top := 5; ten_bot := 5; - l_count := 0; last_copy := 0; - -if not format_ok then parameters - else begin - page_l := 66; - init_io; - set_page(page_l); - set_epson - end; -writeln; -write('Do you want to print a file now? (Y/N) '); -code := yes_1(str, no_c); -while code - do begin - write('File name? '); - read(f_name); - open(p_fil,f_name,count); - if (count = 255) or (eof(p_fil) and code) - then begin - writeln('IOERR or File ',f_name,' is not on line.'); - writeln; - write(' Exit? (Y/N) '); - code := not yes_1(str, no_c) - end - else begin - if code then begin - print_f; - close(p_fil, count); - p_out(bell); - writeln; - write('Printing done -'); - if number then end_page - else begin - write(' Move to top of next form? (Y/N) '); - if yes_1(str, no_c) then begin - for i := 1 to l_count + bottom - do p_out(cr_lf); - l_count := 0 - end {then when moved to TOF } - end; { when not numbered } - end; { when code true } - writeln; - write(' Print another? (Y/N) '); - code := yes_1(str, no_c); - page(output); - if code - then if not format_ok then parameters - end { when no ioerr } - end { while when code = Y } -end. - -(* -?T ?N epson2.src -*) - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/EPSON2.ERL b/software/CPM/CPM15_MTPUG_03/EPSON2.ERL deleted file mode 100644 index 51fd030..0000000 Binary files a/software/CPM/CPM15_MTPUG_03/EPSON2.ERL and /dev/null differ diff --git a/software/CPM/CPM15_MTPUG_03/EPSON2.SRC b/software/CPM/CPM15_MTPUG_03/EPSON2.SRC deleted file mode 100644 index 64ecdc4..0000000 --- a/software/CPM/CPM15_MTPUG_03/EPSON2.SRC +++ /dev/null @@ -1,182 +0,0 @@ - -{$K0} {$K2} {$K12} {$K13} {$K14} {$K15} -module epson2; - -{ second portion of EPSON } -{ A print 'formatter' program to facilitate use of the epson } -{ Written by Harry Eckerson on 9/18/81 and last revised 9/25/81 } -{ This program requires erl files utilmod and paslib and epson2 } -{ ******** NO cpm LST device IO is used ******* } -{ Location base of output ports = 80H ; control port = 87H } -const - blank = ' '; - spec_c = '?'; {spec character in col 1 to detect spec action } - base = 128; - base1 = 129; - base7 = 135; - bell = 7; - c_ret = 13; - cr_lf = 10; - -var - p_fil : external text; - f_name, - str : external string; - ok : external char; - no_c, - code : external boolean; - long_s : external string[255]; - count, i, - ten_top, ten_bot, ten_page, - top, bottom, lines_per , spaces, - num, l_count, page_l, p_number : external integer; - l_feed, d_strike, number, comp, emph : external boolean; - -external function keypressed : boolean; -external procedure @HLT; -external function @BDOS( func, parm : integer): integer; - -procedure init_io; -var - i : integer; - ok_init : boolean; -begin - write('Turn printer on, align paper and then press .'); - ok_init := yes_1(str,no_c); - -(* end; put the end here for disks with functional LST: dev *) - out[base7] := 0; { select daisy port } - out[base1] := 192; { set bits 6&7 high of base1;6=strobe high;7=auto_L_off } - - out[base1] := 128; {leave 7 high take 6 low } - { this should initialize printer line #31 } - for i := 1 to 10 do ; - { delay cycle } - out[base1] := 192 { this goes back to 6 & 7 high } -end; {init } - -procedure p_error (ok : char); -{ This procedure is not needed if LST: is used } -var - lets : string; - i : integer; -begin - i := ord(ok); - if i = 0 - then begin { delay to see if really off } - for i := 1 to maxint do ; - ok := inp[base]; - i := ord(ok) - end; - if i = 0 then write('TURN ON PRINTER') - else if i in [3,67] then write('PRINTER NOT ON LINE') - else if i = 65 then write ('OUT OF PAPER') - else begin - write('Printer error # ',i,' = '); - for i := 7 downto 0 do write(ord(tstbit(ok,i))) - end; - write(' or ^C ? '); - readln(lets); - if ord(ok) = 0 then init_io -end; { p_error } - -procedure clr_line; -{ CLR_LINE should move back to the last printed line and delete it. } -begin - write(chr(19),chr(19),chr(22)) -end; - -procedure p_out(let_val : integer); -var ok : char; - i : integer; -begin -(* i := @BDOS(5,let_val) { output char to printer } - bdos call for disks with modified bios where LST: works - if @BDOS is used the rest of this procedure can be deleted. *) - - out[base7] := 0; { select daisy port } - i := -32000; - repeat { input busy line; test it to see when it clears } - ok := inp[base]; - if (ord(ok) = 0) or tstbit(ok,0) then p_error(ok); - until tstbit(ok, 7); - out[base] := wrd(let_val); { set data to be sent on the line } - out[base7] := 32; - out[base7] := 48; {enable printer output & strobe daisy port low } - for i := 1 to 1 do; { delay a moment } - out[base7] := 32; { strobe printer high and leave printer on } -end; { p_out } - -procedure d_blanks( var d_line : string); -begin - while pos( blank,d_line) = 1 do delete(d_line,1,1) -end; { d_blanks } - -procedure set_page(page_l : integer); -begin - p_out(27); { 'C' } - p_out(67); - p_out(page_l) -end; - -function yes_1( var str : string;var zero_ch : boolean) : boolean; -var - let : char; - i : integer; -begin - readln(str); - zero_ch := length(str) = 0; - d_blanks(str); - yes_1 := (pos('Y',str) = 1) or (pos('y',str) = 1) -end; { yes_1 } - - -function convert( var line : string; tenths : boolean): integer; -var - val : integer; -begin - while (length(line) > 0 ) and not (line[1] in ['0'..'9','.']) - do delete(line, 1, 1); { eliminate non numbers } - val := 0; - while (length(line) > 0) and (line[1] in ['0'..'9']) - do begin - val := val * 10 + ord(line[1]) - 48; - delete(line,1,1) - end; { conversion } - if tenths - then begin - if pos('.',line) = 1 then delete(line,1,1); - if (length(line) > 0) and ( line[1] in ['0'..'9']) - then begin - val := val * 10 + ord(line[1]) -48 ; - delete(line, 1, 1) - end - else val := val * 10 { when trailing '.' } - end; - convert := val -end; { convert } - -procedure set_epson; -begin - { set up printer } - p_out(27); { 1st line spacing } - case lines_per of - 60 : p_out(ord('2')); - 80 : p_out(ord('0')); - 103: p_out(ord('1')) - end; { case } - - if comp then p_out(15) - else p_out(146); - - p_out(27); - if emph then p_out(69) {'E'} - else p_out(70); { 'F' } - - p_out(27); - if d_strike then p_out(71) {'G'} - else p_out(72) {'H'} -end; { set_epson } - -modend. - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/FNC9511.SRC b/software/CPM/CPM15_MTPUG_03/FNC9511.SRC deleted file mode 100644 index 6585e5d..0000000 --- a/software/CPM/CPM15_MTPUG_03/FNC9511.SRC +++ /dev/null @@ -1,140 +0,0 @@ -MODULE FNC9511; -{$M SIN} -{$M COS} -{$M EXP} -{$M LN} -{$M ARCTAN} -{$M TAN} -{$M ASIN} -{$M ACOS} -{$M LOG10} -{$M PI} -{$M *} - -EXTERNAL PROCEDURE @ERR(AN_ERROR:BOOLEAN; ERRNUM:INTEGER); - -EXTERNAL PROCEDURE @AMD(FUNC:INTEGER;VAR ARG:REAL;VAR STATUS:INTEGER); - -{THE PROCEDURE @AMD,INTERFACES TO THE AMD9511 ARITHMETIC PROCESSING UNIT (APU). -THE FIRST ARGUMENT IS THE FUNCTION CODE (AND IS STRAIGHT FROM THE AM9511 -LITERATURE). THE SECOND IS THE ADDRESS OF ARG, A REAL VARIABLE, THE FUNTION -ARGUMENT IS IN ARG, AND THE RESULT IS RETURNED IN ARG. THE THIRD ARGUMENT IS -THE ADDRESS WHERE THE APU STATUS IS RETURNED.} - -{TAN, ASIN, ACOS, LOG10, AND PI FUNCTIONS ADDED BY FICOMP, INC. 9/13/81} - -FUNCTION SIN(ARG:REAL):REAL; {SINE FUNCTION} -VAR STATUS:INTEGER; -BEGIN - @AMD($02,ARG,STATUS); - SIN:=ARG; -END; - -FUNCTION COS(ARG:REAL):REAL; {COSINE FUNCTION} -VAR STATUS:INTEGER; -BEGIN - @AMD($03,ARG,STATUS); - COS:=ARG; -END; - -FUNCTION EXP(ARG:REAL):REAL; {E TO THE X FUNCTION} -VAR STATUS:INTEGER; -BEGIN - @AMD($0A,ARG,STATUS); - IF (STATUS & $1E) = $18 THEN - BEGIN - WRITE('EXP outside range'); - @ERR(TRUE,4); { -32< ARGUMENT >+32 } - EXP := 0.0; - END - ELSE - EXP := ARG; -END; - -FUNCTION LN(ARG:REAL): REAL; {NATURAL LOGARITHM FUNCTION} -VAR STATUS: INTEGER; -BEGIN - @AMD($09,ARG,STATUS); - IF (STATUS & $1E) = $8 THEN - BEGIN - WRITE('LN negative argument'); - @ERR(TRUE,4); { NEGATIVE ARGUMENT } - LN := 0.0; - END - ELSE - LN := ARG; -END; - -FUNCTION ARCTAN(ARG:REAL): REAL; {INVERSE TANGENT FUNCTION} -VAR STATUS: INTEGER; -BEGIN - @AMD($07,ARG,STATUS); - ARCTAN := ARG; -END; - -FUNCTION TAN(ARG:REAL):REAL; {TANGENT FUNCTION} -VAR STATUS:INTEGER; -BEGIN - @AMD($04,ARG,STATUS); - TAN := ARG; -END; - -FUNCTION ASIN(ARG:REAL):REAL; {ARCSINE FUNCTION} -VAR STATUS:INTEGER; -BEGIN - @AMD($05,ARG,STATUS); - IF (STATUS & $1E) = $18 THEN - BEGIN - WRITE('ASIN outside range'); - @ERR(TRUE,4); { -1< ARGUMENT >+1 } - ASIN := 0.0; - END - ELSE - ASIN := ARG; -END; - -FUNCTION ACOS(ARG:REAL):REAL; {ARCCOSINE FUNCTION} -VAR STATUS:INTEGER; -BEGIN - @AMD($06,ARG,STATUS); - IF (STATUS & $1E) = $18 THEN - BEGIN - WRITE('ACOS outside range'); - @ERR(TRUE,4); { -1< ARGUMENT >+1 } - ACOS := 0.0; - END - ELSE - ACOS := ARG; -END; - -FUNCTION LOG10(ARG:REAL):REAL; {COMMON LOG FUNCTION} -VAR STATUS:INTEGER; -BEGIN - @AMD($08,ARG,STATUS); - IF (STATUS & $1E) = $8 THEN - BEGIN - WRITE('LOG10 negative argument'); - @ERR(TRUE,4); { NEGATIVE ARGUMENT } - LOG10 := 0.0; - END - ELSE - LOG10 := ARG; -END; - -FUNCTION PI(ARG:REAL):REAL; {RETURNS PI*ARG; PI(1)=3.14159} -VAR STATUS:INTEGER; - MULT:REAL; -BEGIN - MULT := ARG; - @AMD($1A,ARG,STATUS); - PI := ARG*MULT; -END; - -MODEND. -.14159} -VAR STATUS:INTEGER; - MULT:REAL; -BEGIN - MULT := ARG; - @AMD($1A,ARG,STATUS); - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/MATHLIBS.DOC b/software/CPM/CPM15_MTPUG_03/MATHLIBS.DOC deleted file mode 100644 index 886e2b6..0000000 --- a/software/CPM/CPM15_MTPUG_03/MATHLIBS.DOC +++ /dev/null @@ -1,29 +0,0 @@ -The earlier MATHLIB math function library has been split into POWRLIB and -TRIGLIB. The functions now include range checking, and a new trig function, -ATAN2 has been added. This is the arctangent function with quadrant -recognition. It works like the FORTRAN function of the same name. - -The new CMPXLIB library uses the pointer variable technique, now so that -functions instead of procedures may be used. - -The STATLIB library uses the conformant array schema for passing arrays of -different upper and lower bounds. The procedures find the minimum, maximum, -mean (average), and standard deviation (sigma) of the conformant arrays passed. - -The FNC9511 library is the MT+ TRAN9511 library with additional range checking. -The 9511 chip functions, TAN, ASIN, ACOS, LOG10, AND PI functions have been -added. - -Ron Finger -Ficomp, Inc. -3017 Talking Rock Drive -Fairfax, Virginia 22031 -(703) 280-1394 - PI functions have been -added. - -Ron Finger -Ficomp, Inc. -3017 Talking Rock Drive -Fairfax, Virginia 22031 -(703 \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/MTPUG.003 b/software/CPM/CPM15_MTPUG_03/MTPUG.003 deleted file mode 100644 index 2d1c85b..0000000 --- a/software/CPM/CPM15_MTPUG_03/MTPUG.003 +++ /dev/null @@ -1,90 +0,0 @@ -VOLUME #3 JANUARY 1982 - -CALCAL/SRC Convert dates from the MMDDYY year format to - an integer which increases by one for each - day. Corrects for leap year and includes - an example. By Ed. Reed. - -VARIO/SRC A self modifying program which can be used - to read/write multiple random files with - differing record sizes. By Ed. Reed. - -DIRFILE/SRC/ERL This program reads the disk directory and - writes it to a file. Useful for backup - purposes and with modification within - a program. By Ed. Reed. - -EPSON/DOC This program allows the formatting characters -EPSON/SRC/ERL used by the EPSON printer to be passed to it -EPSON2/SRC/ERL without requiring the user to commit the codes - to memory. The program interacts with the user - to print a formatted text file using different - spacing, fonts, etc. By Harry Eckerson. - -CMPXLIB/DOC/SRC Complex math library for Pascal. This library - uses pointer variables so that functions rather - than functions may be used. By Ron Finger. - -MATHLIB/DOC The Mathlib function library has been split -POWRLIB/SRC and now includes range checking, a new trig -TRIGLIB/SRC function ATAN2 has been added. This is the -STATLIB/SRC arctangent function with quadrant recognition -FNC9511/SRC (like Fortran). The Statlib uses the - conformant array schema for passing arrays of - differing upper and lower bounds. The procedures - find the MIN, MAX, MEAN(average) and standard - deviation(Sigma) of the array passed. - The FNC9511 library is the MT+ TRAN9511 library - with additional range checking. The functions - TAN, ASIN, ACOS, ALOG10, AND PI have been - added. - By Ron Finger, Ficomp, Inc. - -NSB/DOC/SRC Modified for use with Zenith Z-19/Heath H-19 - terminals. SB_GETCH has been modified to - intercept the Escape sequence commands so that - the 18 keypad & special function keys can be - used. By Ron Finger. - -NSBCUR19/DOC/SRC Modified for use with Zenith Z-19/Heath H-19 - terminals. Both the function and cursor keys - on the terminal are used. This version works - with 4 MHz systems and instructions are - included for converting the code on a 2 MHz - system. By Jerry Jankura. - -ACOUSTIC/PAS A set of routines designed to emulate a - D.C.Hayes modem with an acoustic coupler) - (Can be used by TERMINAL instead of DCMODEM - By Warren Smith - -CIRQUE/PAS A set of routines to mainuplate a circular que - By Warren Smith - -CRT/PAS A set of routines for manipulating a cursor - addressable CRT (Used by TERMINAL and RINGING) - - By Warren Smith - -DCMODEM/PAS A set of routines to access the features of a - D.C.Hayes S-100 modem (Used by TERMINAL and - RINGING) By Warren Smith - -RINGING/PAS/CMD A program to let your computer tell you that - your phone is ringing. By Warren Smith - -TERMINAL/PAS/CMD A program to act as a dumb terminal, can also - display control characters coming in on the line. - By Warren Smith - -UTILITY/PAS Only has one routine, a lower to upper case - translating. By Warren Smith - -CUBE/SRC/ERL/COM A program to play with Rubic's Cubes on your - terminal rather than in hand. List SRC for - instructions. Written by Ed Reed - -CUBESOLV/SRC/ERL/COM When all fails, use to recover from your last - attempts. List .src for instructions. - Written by Ed. Reed - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/MTPUG.BAK b/software/CPM/CPM15_MTPUG_03/MTPUG.BAK deleted file mode 100644 index 7a8a08f..0000000 --- a/software/CPM/CPM15_MTPUG_03/MTPUG.BAK +++ /dev/null @@ -1,82 +0,0 @@ -VOLUME #3 JANUARY 1982 - -CALCAL/SRC Convert dates from the MMDDYY year format to - an integer which increases by one for each - day. Corrects for leap year and includes - an example. By Ed. Reed. - -VARIO/SRC A self modifying program which can be used - to read/write multiple random files with - differing record sizes. By Ed. Reed. - -DIRFILE/SRC/ERL This program reads the disk directory and - writes it to a file. Useful for backup - purposes and with modification within - a program. By Ed. Reed. - -EPSON/DOC This program allows the formatting characters -EPSON/SRC/ERL used by the EPSON printer to be passed to it -EPSON2/SRC/ERL without requiring the user to commit the codes - to memory. The program interacts with the user - to print a formatted text file using different - spacing, fonts, etc. By Harry Eckerson. - -CMPXLIB/DOC/SRC Complex math library for Pascal. This library - uses pointer variables so that functions rather - than functions may be used. By Ron Finger. - -MATHLIB/DOC The Mathlib function library has been split -POWRLIB/SRC and now includes range checking, a new trig -TRIGLIB/SRC function ATAN2 has been added. This is the -STATLIB/SRC arctangent function with quadrant recognition -FNC9511/SRC (like Fortran). The Statlib uses the - conformant array schema for passing arrays of - differing upper and lower bounds. The procedures - find the MIN, MAX, MEAN(average) and standard - deviation(Sigma) of the array passed. - The FNC9511 library is the MT+ TRAN9511 library - with additional range checking. The functions - TAN, ASIN, ACOS, ALOG10, AND PI have been - added. - By Ron Finger, Ficomp, Inc. - -NSB/DOC/SRC Modified for use with Zenith Z-19/Heath H-19 - terminals. SB_GETCH has been modified to - intercept the Escape sequence commands so that - the 18 keypad & special function keys can be - used. By Ron Finger. - -NSBCUR19/DOC/SRC Modified for use with Zenith Z-19/Heath H-19 - terminals. Both the function and cursor keys - on the terminal are used. This version works - with 4 MHz systems and instructions are - included for converting the code on a 2 MHz - system. By Jerry Jankura. - -ACOUSTIC/PAS A set of routines designed to emulate a - D.C.Hayes modem with an acoustic coupler) - (Can be used by TERMINAL instead of DCMODEM - By Warren Smith - -CIRQUE/PAS A set of routines to mainuplate a circular que - By Warren Smith - -CRT/PAS A set of routines for manipulating a cursor - addressable CRT (Used by TERMINAL and RINGING) - - By Warren Smith - -DCMODEM/PAS A set of routines to access the features of a - D.C.Hayes S-100 modem (Used by TERMINAL and - RINGING) By Warren Smith - -RINGING/PAS/CMD A program to let your computer tell you that - your phone is ringing. By Warren Smith - -TERMINAL/PAS/CMD A program to act as a dumb terminal, can also - display control characters coming in on the line. - By Warren Smith - -UTILITY/PAS Only has one routine, a lower to upper case - translating. By Warren Smith - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/NSB.DOC b/software/CPM/CPM15_MTPUG_03/NSB.DOC deleted file mode 100644 index 088fcf2..0000000 --- a/software/CPM/CPM15_MTPUG_03/NSB.DOC +++ /dev/null @@ -1,13 +0,0 @@ -This version of NSB is for use with the Zenith Z-19/Heath H-19 terminals. -The SB_GETCH function has been modified to intercept the Escape sequence -commands so that the 18 keypad & special function keys can be used. All -original commands still function as before, except that the ERASE key is -now the escape (ESC) key. The ESC key still functions but must be pushed -twice in succession to obtain an escape. - - Ron Finger - Ficomp, Inc. - 3017 Talking Rock Dr. - Fairfax, VA 22031 - (703)280-1394 - in succe \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/NSB.SRC b/software/CPM/CPM15_MTPUG_03/NSB.SRC deleted file mode 100644 index 2bbd16a..0000000 --- a/software/CPM/CPM15_MTPUG_03/NSB.SRC +++ /dev/null @@ -1,387 +0,0 @@ -{This version of NSB is for use with the Zenith Z-19/Heath H-19 terminals. -The SB_GETCH function has been modified to intercept the Escape sequence -commands so that the 18 keypad & special function keys can be used. All -original commands still function as before, except that the ERASE key is -now the escape (ESC) key. The ESC key still functions but must be pushed -twice in succession to obtain an escape. - - Ron Finger - Ficomp, Inc. - 3017 Talking Rock Dr. - Fairfax, VA 22031 - (703)280-1394 } - -{ VERSION 0058 } -{$K0} -{$K1} -{$K2} -{$K5} -{$K6} -{$K7} -{$K8} -{$K12} -{$K13} -{$K14} -{$K15} -PROGRAM PASCAL_SPP; - -{$I EDTYPES} -{$I EDGLBLS} - -TYPE -CPMOPERATION = (COLDBOOT,WARMBOOT,CONSTAT,CONIN,CONOUT,LIST, - PUNOUT,RDRIN,HOME,SELDSK,SETTRK,SETSEC,SETDMA, - DSKREAD,DSKWRITE); - -FNAME = ARRAY [1..8] OF CHAR; { CP/M FILE NAME } - -EXTENSION = ARRAY [1..3] OF CHAR; { EXTENSION TO NAME } - -FCB = RECORD - DSK : BYTE; - FN : FNAME; - EXT : EXTENSION; - OTHER: ARRAY [12..36] OF BYTE - END; - -DIRENT = RECORD - ET : BYTE; - FN : FNAME; - EXT : EXTENSION; - OTHR : ARRAY [12..31] OF BYTE - END; - -{$I SBIFDEF.LIB} - - - -VAR - - DIRFILE: FCB; { FOR DISPLAYING DIRECTORIES } - DIRBUF: ARRAY [0..3] OF DIRENT; - - FSTRING: STRING; - MEMORY: ABSOLUTE [$0000] ARRAY[0..0] OF BYTE; - CMDCH: CHAR; - @SFP: EXTERNAL INTEGER; - BUFSTAT: STATREC; - INTRFACE: SB_INTERFACE; { USED TO COMMUNICATE BETWEEN PROGRAMS } - SB_LAST_X, - SB_LAST_Y: INTEGER; { FOR SOFTWARE CLR TO EOL/ CLR TO EOS ROUTINES } - - -EXTERNAL FUNCTION @BDOS(PARM,FUNC:INTEGER):INTEGER; - -EXTERNAL [1] PROCEDURE LOGWRITER; { LOG WRITER OVERLAY } -EXTERNAL [2] PROCEDURE SPEED; { EDITOR OVERLAY } -EXTERNAL [3] PROCEDURE SYNCHECK; { SYNTAX CHECKER OVERLAY } -EXTERNAL [4] PROCEDURE VARCHECK; { UNDEF VAR CHECKER OVERLAY } -EXTERNAL [6] PROCEDURE MTRUN; { RUN PROGRAM OVERLAY } -EXTERNAL [7] PROCEDURE DISP_DIR; { DIRECTORY DISPLAY OVERLAY } -EXTERNAL [8] FUNCTION GETFILE:BOOLEAN; { GET EDITOR FILE NAME, ETC. } -EXTERNAL [8] PROCEDURE INIT; { EDITOR INIT } -EXTERNAL [9] PROCEDURE EDITWRITE; { EDITOR WRITE BUFFER OVERLAY } -EXTERNAL[10] PROCEDURE PRETTY; { PROGRAM REFORMATER } - - -{--------------------------------------------------------------} -{ H-19/Z-19 terminal area BEGINS here: } -{--------------------------------------------------------------} - - -FUNCTION LINESZ : INTEGER; { SO USER CAN SET SIZE OF A LINE } -BEGIN - LINESZ := 79 { 80 - 1 } -END; - -FUNCTION SCREENSZ : INTEGER; -BEGIN - SCREENSZ := 22 { NUMBER OF LINES ON PHYSICAL SCREEN - 2 } -END; - -FUNCTION STATUSROW : INTEGER; -BEGIN - STATUSROW := SCREENSZ + 1 -END; - -PROCEDURE SB_OUT_CH(CH:CHAR); -BEGIN - SB_BIOS_CALL(CONOUT,ORD(CH)) -END; - -FUNCTION SB_GETCH:CHAR; -{CONVERT H/Z-19 ESC SEQUENCE COMMANDS TO SPP EQUIV. -Control character commands will function as before; -For Escape - hit ESC twice in succession} -VAR - CH : CHAR; - CHO : INTEGER; -BEGIN - SB_BIOS_CALL(CONIN,0); - INLINE("STA / CH); - IF ORD(CH)=$1B THEN {if ESC then get next char in sequence} - BEGIN - SB_BIOS_CALL(CONIN,0); - INLINE("STA / CH); - CASE CH OF {19 KEY CONTROL CHAR} - 'V' : CHO := $03; { f4 ^C } - 'P' : CHO := $06; { blue ^F } - 'N' : CHO := $07; { DC ^G } - 'D' : CHO := $08; { arrow left ^H } - 'B' : CHO := $0A; { arrow down ^J } - 'A' : CHO := $0B; { arrow up ^K } - 'C' : CHO := $0C; { arrow right ^L } - 'L' : CHO := $0E; { IL ^N } - 'R' : CHO := $11; { white ^Q } - 'W' : CHO := $12; { f5 ^R } - 'T' : CHO := $13; { f2 ^S } - 'H' : CHO := $14; { HOME ^T } - 'U' : CHO := $15; { f3 ^U } - 'Q' : CHO := $16; { red ^V } - 'S' : CHO := $17; { f1 ^W } - 'M' : CHO := $19; { DL ^Y } - '@' : CHO := $1A; { IC ^Z } - 'J' : CHO := $1B; { ERASE ESC } - ELSE - CHO := ORD(CH) - END; {CASE} - SB_GETCH :=CHR(CHO) - END - ELSE - SB_GETCH := CH -END; - -PROCEDURE XYGOTO(X,Y:INTEGER); -BEGIN - SB_OUT_CH(CHR(ESC)); - SB_OUT_CH('Y'); - SB_OUT_CH(CHR(Y+32)); - SB_OUT_CH(CHR(X+32)); - SB_LAST_X := X; - SB_LAST_Y := Y; { THESE ARE USED ONLY BY USER SOFTWARE } - { ROUTINES WHICH PERFORM CLR TO EOS AND } - { CLR TO EOL } -END; - -PROCEDURE SB_CLR_SCRN; -BEGIN - SB_OUT_CH(CHR(ESC)); - SB_OUT_CH('E') -END; - -PROCEDURE SB_CLR_EOS; -BEGIN - SB_OUT_CH(CHR(ESC)); - SB_OUT_CH('J'); - SB_OUT_CH(CHR(0)); { GIVE IT TIME TO WORK } - SB_OUT_CH(CHR(0)); { GIVE IT TIME TO WORK } - SB_OUT_CH(CHR(0)); { GIVE IT TIME TO WORK } - SB_OUT_CH(CHR(0)); { GIVE IT TIME TO WORK } -END; - - -PROCEDURE SB_CLR_LINE; -BEGIN - SB_OUT_CH(CHR(ESC)); - SB_OUT_CH('K'); -END; - - -{--------------------------------------------------------------} -{ User modification area ENDS WITH SB_CLR_LINE } -{--------------------------------------------------------------} - - -PROCEDURE SB_FLUSH_BUF; -VAR - CH : CHAR; -BEGIN - IF NOT BUFSTAT.OCCUPIED THEN - EXIT; - - REPEAT - PRNT_AT(20,1,'Buffer occupied'); - PRNT_AT(21,1,'F)lush, U)pdate, W)rite & Flush, L)eave:'); - CH := SB_UP_CASE(SB_GETCH); - SB_OUT_CH(CH); - IF CH = 'L' THEN - EXIT; - - IF CH = 'F' THEN - BEGIN - IF NEWFILE THEN - PURGE(F); - BUFSTAT.OCCUPIED := FALSE; - EXIT - END; - - IF CH = 'W' THEN - BEGIN - EDITWRITE; - LOGWRITER; - BUFSTAT.OCCUPIED := FALSE - END; - - IF CH = 'U' THEN - BEGIN - EDITWRITE; { BUT LEAVE IT OCCUPIED } - LOGWRITER - END - UNTIL (CH='U') or (CH='F') OR (CH='W'); - NEWFILE:=FALSE; -END; - - -PROCEDURE SB_BIOS_CALL(FUNC:CPMOPERATION; PARM:INTEGER); -VAR - DISPATCH_LOC : INTEGER; -BEGIN - DISPATCH_LOC := (MEMORY[1] + SWAP(MEMORY[2])) + (ORD(FUNC)*3) - 3; - INLINE("LHLD / PARM / - "MOV C,L / - "MOV B,H / - "LHLD / DISPATCH_LOC / - "PCHL); -END; - -PROCEDURE PRNT_AT(ROW,COL:INTEGER; S:STRING); -BEGIN - XYGOTO(COL,ROW); - WRITE([ADDR(SB_OUT_CH)],S) -END; - -PROCEDURE MENU; -BEGIN - SB_CLR_SCRN; - PRNT_AT(1,1,'SpeedProgramming Package V5.2'); - PRNT_AT(3,1,'Options: E)dit'); - prnt_at(4,20, 'R)eformat'); - prnt_at(5,20, 'S)yntax check'); - prnt_at(6,20, 'V)ar check'); - prnt_at(7,20, 'X)eq'); - prnt_at(8,20, 'D)ir'); - prnt_at( 9,20, 'L)ink'); - prnt_at(10,20, 'F)ast compile'); - prnt_at(11,20, 'Q)uit'); - prnt_at(22,1,'Command? ') -END; - -FUNCTION SB_UP_CASE(CH:CHAR):CHAR; -BEGIN - IF (CH >= 'a') AND (CH <= 'z') THEN - SB_UP_CASE := CHR(CH & $DF) - ELSE - SB_UP_CASE := CH -END; - - -{$E-} -FUNCTION GET_FILE_INTO_BUF:BOOLEAN; -BEGIN - IF NOT BUFSTAT.OCCUPIED THEN - IF GETFILE THEN { GET FILE INTO BUFFER } - INIT; - GET_FILE_INTO_BUF := BUFSTAT.OCCUPIED -END; -{$E+} - -BEGIN - SB_OUT_CH(CHR(ESC)); {set up block cursor} - SB_OUT_CH('x'); - SB_OUT_CH('4'); - - BUFSZ := (@SFP - ADDR(BUF))-$100; { SET UP EDITOR BUFFER SIZE } - BUFSTAT.OCCUPIED := FALSE; - NEWFILE := FALSE; - REPEAT - MENU; - INTRFACE.NEXT_CMD := ' '; { DEFAULT NO NEXT PROGRAM } - INTRFACE.END_STAT := OK; - CMDCH := SB_UP_CASE(SB_GETCH); - SB_OUT_CH(CMDCH); { ECHO IT } - REPEAT - FSTRING := ''; { DEFAULT IS NO PROGRAM } - CASE CMDCH OF - 'D' : DISP_DIR; - 'E' : BEGIN - IF (BUFSTAT.OCCUPIED) AND ((INTRFACE.PREV_CMD = 'S') - OR (INTRFACE.PREV_CMD = 'R'))THEN - { DO NOTHING } - ELSE - SB_FLUSH_BUF; { MAKE SURE USER WANTS TO DO THIS } - - IF NOT BUFSTAT.OCCUPIED THEN { BUFFER IS EMPTY } - BEGIN - IF GETFILE THEN { SEE IF HE WANTS A FILE } - BEGIN - INIT; { CALL EDITOR } - IF BUFSTAT.OCCUPIED THEN - SPEED - END - END - ELSE - SPEED; { BUFFER OCCUPIED, EDIT OLD } - INTRFACE.PREV_CMD := ' '; - IF INTRFACE.NEXT_CMD = 'E' THEN - INTRFACE.NEXT_CMD := ' '; - END; - 'S' : BEGIN - IF GET_FILE_INTO_BUF THEN - BEGIN - INTRFACE.PREV_CMD := ' '; - SYNCHECK; - IF INTRFACE.END_STAT = SYNERR THEN - INTRFACE.NEXT_CMD := 'E' - END - END; - 'V' : IF GET_FILE_INTO_BUF THEN - VARCHECK; - 'R' : BEGIN - IF GET_FILE_INTO_BUF THEN - BEGIN - INTRFACE.PREV_CMD := 'R'; - PRETTY; - INTRFACE.NEXT_CMD := 'E'; - SB_CLR_SCRN - END - END; - 'X' : BEGIN - SB_FLUSH_BUF; - FSTRING := ''; - MTRUN - END; - 'Q' : BEGIN - INTRFACE.PREV_CMD := ' '; - SB_FLUSH_BUF; - IF BUFSTAT.OCCUPIED THEN - CMDCH := '@' - ELSE - BEGIN - SB_CLR_SCRN; - EXIT - END - END; - 'L' : BEGIN - SB_FLUSH_BUF; - FSTRING := 'L'; {new linker is just 'L' } - MTRUN - END; - 'F' : BEGIN - IF GET_FILE_INTO_BUF THEN - BEGIN - SB_FLUSH_BUF; - FSTRING := 'FASTCOMP'; - MOVE(ENDFILE,MEMORY[ADDR(BUF)-2],2);{ SET UP INTEGER } - MOVE(NAME,MEMORY[ADDR(BUF)-83],81); - MTRUN - END - END - END; - CMDCH := INTRFACE.NEXT_CMD; - UNTIL (CMDCH = ' ') OR (CMDCH = INTRFACE.PREV_CMD); - UNTIL FALSE -END. - - END; - CMDCH := INTRFACE.NEXT_CMD; - UNTIL (CMDCH = ' ') \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/NSBCUR19.DOC b/software/CPM/CPM15_MTPUG_03/NSBCUR19.DOC deleted file mode 100644 index e6830ee..0000000 --- a/software/CPM/CPM15_MTPUG_03/NSBCUR19.DOC +++ /dev/null @@ -1,262 +0,0 @@ - - - - - Unlikå  thå versioî oæ NSBH19.SRà whicè ió iî vol- - umå  ± oæ thå MTPUÇ library¬  thió  versioî  implementó - botè  thå  "FUNCTION¢  anä "CURSOR¢ keyó oî  thå  Heatè - terminal® Thå keypaä anä "FUNCTION¢ keyó acô similarlù - tï Compuvie÷ Product'ó "VEDIT¢ program®  Thå  softwarå - listing¬ NSBCUR19.SRà giveó thå actuaì assignments. - - NSBCUR19.SRà runó properlù oî á ´ MHú Z-8° systeí - (ie® iô ió uð anä running© anä shoulä ruî properlù witè - á  µ MHú 808µ systeí sucè aó Godbout'ó  duaì  processoò - boarä (ie®  thió processoò waó noô yeô tried¬ buô sincå - alì  thå codå generateä bù NS ió 808° code¬  thå µ MHú - 808µ shoulä executå fasteò thaî thå ´ MHú Z-80). - - Iæ  thió softwarå ió ruî oî á ² MHú  808°  system¬ - somå interestinç thingó begiî tï happeî (ie® iô doesn'ô - worë  welì aô all)®  Thå FUNCTIOÎ keyó seeí tï generatå - alphanumeriã characteró whicè arå inserteä iî thå text® - Theù  dï noô perforí accordinç tï thå  CASÅ  statement» - however¬ thå standarä controì keyó defineä bù MÔ Micro- - systemó worë correctly. - - Tï understanä whù thió is¬ wå musô looë aô ho÷ thå - FUNCTIOΠ keyó (includinç outpuô oæ thå shifteä numeriã - keypad© arå implementeä oî thå H-19® Thå standarä keyó - transmiô  onå ascié characteò tï thå computeò foò  eacè - keù stroke® Thå FUNCTIOÎ anä CURSOÒ keys¬ oî thå otheò - hand¬  transmiô  twï ascié characteró iî rapiä  succes- - sion®  Thå  firsô oæ theså characteró ió  aî  - 63B LHLD 1 - 63E INX H - 63F INX H - 640 INX H - 641 LXI D,1C46 THIS IS THE RETURN ADDR OF THE BIOS CALL - 644 PUSH D PUSH IT ONTO THE STACK - 645 PCHL - 646 STA 8D31 DON'T KNOW WHY, BUT HIS ROUTINE DOES - 649 MOV L,A - 64A MVI H,0 - 64C . - - That'ó  thå  patch®  Thå twï  instructionó  whicè - follo÷ arå XTHÌ anä PCHL® Fortunately¬ iô takeó SPÐ aó - manù  byteó tï seô uð itó calì tï CP/Í anä transfeò thå - informatioî aó iô takeó uó tï tï thå BIOÓ calì  direct- - ly®  Iæ  SPР tooë lesó spacå tï makå itó  call¬  thió - techniquå woulä noô worë toï well. - - Now¬  typå ^à tï exiô DDÔ oò SID®  Theî typå SAVÅ - 10¸ SPP.002®  Iæ you'vå donå everythinç correctly¬ yoõ - caî invokå SPP¬ brinç uð thå editor¬ anä uså thå cursoò - keyó  tï youò heart'ó content®  Iæ everythinç  doesn'ô - worë out¬  it'ó nicå tï kno÷ thaô thió ió noô thå  onlù - disë  witè SPÐ oî iô thaô yoõ have®  Thå probleí  mosô - likelù  waó  aî erroò iî determininç thå  addresseó  aô - whicè yoõ shoulä enteò thå information¬ oò thå valuå tï - loaä  intï  registeò  DÅ anä pusè oî thå stacë  aó  thå - returî address. - - Mù thankó tï Mikå Lehmaî whï tolä må whicè  symboì - tï  looë  foò anä whï outlineä thå generaì approacè  tï - solvå  thå  problem®  Yoõ mighô wondeò whù  MÔ  Micro- - systemó didn'ô jusô implemenô á direcô calì tï thå BIOÓ - sucè aó É havå described®  Thå answeò ió simpleº theù - wanteä theiò softwarå tï worë witè anù versioî oæ  CP/Í - whicè mighô comå dowî thå pike® Theù haä nï choicå buô - tï  worë througè CP/Í operatinç systeí calló tï  assurå - compatability. - - Therå  arå otheò wayó tï implemenô thå CURSOÒ  anä - FUNCTIOΠ keys®  Onå waù ió tï makå thå consolå  inpuô - BIOÓ  routinå  interrupô driveî sï thaô alì  characteró - transmitteä  bù  thå terminaì woulä bå  loadeä  intï  á Š - - 3 - - - - - - - - - buffer®  Consolå statuó woulä returî truå iæ anù char- - acteró  werå iî thå buffeò anä falså iæ thå buffeò werå - empty® Thió modå oæ operatioî woulä requirå nï modifi- - catioî oæ thå SPÐ software®  However¬ manù oæ thå CP/Í - implementationó todaù havå nï interrupô capability. - - Onå otheò thing¬  bå surå tï modifù thå  initiali- - zatioî  switcheó oî youò H-1¹ tï automaticallù senä thå - shifteä characteò set®  Otherwise¬  you'lì havå tï de- - presó  thå  shifô  keù anù timå yoõ wisè  tï  movå  thå - cursor. - - - Jerry Jankura - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 4 - - - - - - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/NSBCUR19.SRC b/software/CPM/CPM15_MTPUG_03/NSBCUR19.SRC deleted file mode 100644 index bae6821..0000000 --- a/software/CPM/CPM15_MTPUG_03/NSBCUR19.SRC +++ /dev/null @@ -1,427 +0,0 @@ -(* VERSION 0060 *) - -(****************************************************************) -(* *) -(* This version of NSB.SRC contains a driver for the Heath H-19 *) -(* or Zenith Z-19 terminal. The driver makes use of the cursor *) -(* positioning and special function keys which are implemented *) -(* by sequences. The auxiliary keypad has been defined*) -(* to function the same as Compuview Products "VEDIT" video *) -(* editor. *) -(* *) -(* Functions provided: *) -(* *) -(* F1 Enter Insert Character Mode (^F) *) -(* F2 Accept Previous Command (^V) *) -(* F3 Search for string (^S) *) -(* F4 Insert Line (^N) *) -(* F5 Search & Replace (^X) *) -(* ERASE Enter Delete Line Mode (^Y) *) -(* BLUE Delete Word Right (^O) *) -(* RED (ESC) *) -(* GREY Super Command (^Q) *) -(* IC Cursor Backward Page (^R) *) -(* IL Cursor Forward Page (^C) *) -(* DC Delete Character Right (^G) *) -(* DL Erase To End Of Line (^P) *) -(* *) -(* These function keys are additional ways of calling some of *) -(* the services offered by SpeedProgramming. MT Microsystems *) -(* original control keystroke definitions are still spplicable *) -(* *) -(* Note that it was necessary to compress the code generated by *) -(* NSB.SRC to allow these definitions to work. This was done *) -(* by shortening the signon message and removing characters *) -(* in some of the messages written by the software. *) -(* *) -(* This code functions properly for a Z-80 processor running at *) -(* 4 Mhz. The method employed by MT Microsystems to check for *) -(* the availability of a character from the console precludes *) -(* proper operation with a 2 Mhz clock. Overlay SPP.002 must *) -(* be modified to perform a direct bios call to check for the *) -(* console input status. Please see the documentation file *) -(* which accompanies this software for a description of the *) -(* patch which must be made, and the method to find where in *) -(* SPP.002 this patch should be located. *) -(* *) -(* Last Modified: 25 November 1981 *) -(* Modified by: J. F. Jankura *) -(* *) -(****************************************************************) - -(*$K0*) -(*$K1*) -(*$K2*) -(*$K5*) -(*$K6*) -(*$K7*) -(*$K8*) -(*$K12*) -(*$K13*) -(*$K14*) -(*$K15*) - -PROGRAM PASCAL_SPP; - -(*$I EDTYPES*) -(*$I EDGLBLS*) - -TYPE - CPMOPERATION = (COLDBOOT,WARMBOOT,CONSTAT,CONIN,CONOUT,LIST, - PUNOUT,RDRIN,HOME,SELDSK,SETTRK,SETSEC,SETDMA, - DSKREAD,DSKWRITE); - - FNAME = ARRAY [1..8] OF CHAR; (* CP/M FILE NAME *) - - EXTENSION = ARRAY [1..3] OF CHAR; (* EXTENSION TO NAME *) - - FCB = RECORD - DSK : BYTE; - FN : FNAME; - EXT : EXTENSION; - OTHER: ARRAY [12..36] OF BYTE - END; - - DIRENT = RECORD - ET : BYTE; - FN : FNAME; - EXT : EXTENSION; - OTHR : ARRAY [12..31] OF BYTE - END; - - (*$I SBIFDEF.LIB*) - - - -VAR - - DIRFILE: FCB; (* FOR DISPLAYING DIRECTORIES *) - DIRBUF: ARRAY [0..3] OF DIRENT; - - FSTRING: STRING; - MEMORY: ABSOLUTE [$0000] ARRAY[0..0] OF BYTE; - CMDCH: CHAR; - @SFP: EXTERNAL INTEGER; - BUFSTAT: STATREC; - INTRFACE: SB_INTERFACE; - (* USED TO COMMUNICATE BETWEEN PROGRAMS *) - SB_LAST_X, - SB_LAST_Y: INTEGER; - (* FOR SOFTWARE CLR TO EOL/ CLR TO EOS ROUTINES *) - - - EXTERNAL FUNCTION @BDOS(PARM,FUNC:INTEGER): INTEGER; - - EXTERNAL [1] PROCEDURE LOGWRITER; (* LOG WRITER OVERLAY *) - - EXTERNAL [2] PROCEDURE SPEED; (* EDITOR OVERLAY *) - - EXTERNAL [3] PROCEDURE SYNCHECK; (* SYNTAX CHECKER OVERLAY *) - - EXTERNAL [4] PROCEDURE VARCHECK; (* UNDEF VAR CHECKER OVERLAY *) - - EXTERNAL [6] PROCEDURE MTRUN; (* RUN PROGRAM OVERLAY *) - - EXTERNAL [7] PROCEDURE DISP_DIR; (* DIRECTORY DISPLAY OVERLAY *) - - EXTERNAL [8] FUNCTION GETFILE: BOOLEAN; - (* GET EDITOR FILE NAME, ETC. *) - - EXTERNAL [8] PROCEDURE INIT; (* EDITOR INIT *) - - EXTERNAL [9] PROCEDURE EDITWRITE; (* EDITOR WRITE BUFFER OVERLAY *) - - EXTERNAL [10] PROCEDURE PRETTY; (* PROGRAM REFORMATER *) - - - (*--------------------------------------------------------------*) - (* User modification area BEGINS here: *) - (*--------------------------------------------------------------*) - - - FUNCTION LINESZ : INTEGER; (* SO USER CAN SET SIZE OF A LINE *) -BEGIN - LINESZ := 79 (* 80 - 1 *) -END; - -FUNCTION SCREENSZ : INTEGER; -BEGIN - SCREENSZ := 22 (* NUMBER OF LINES ON PHYSICAL SCREEN - 2 *) -END; - -FUNCTION STATUSROW : INTEGER; -BEGIN - STATUSROW := SCREENSZ + 1 -END; - -PROCEDURE SB_OUT_CH(CH:CHAR); -BEGIN - SB_BIOS_CALL(CONOUT,ORD(CH)) -END; - -FUNCTION SB_GETCH: CHAR; -VAR - CH : BYTE; -BEGIN - SB_BIOS_CALL(CONIN,0); - INLINE("STA / CH); - IF CH = $1B THEN (* TEST FOR ESCAPE SEQUENCE *) - BEGIN - SB_BIOS_CALL (CONIN,0); - INLINE ("STA / CH); - CASE CH OF - $1B : CH := $1B; (* ESCAPE - ESCAPE = ESCAPE *) - '@' : CH := $12; (* PAGE BACK *) - 'A' : CH := $B; (* CURSOR UP *) - 'B' : CH := $A; (* CURSOR DOWN *) - 'C' : CH := $C; (* SURSOR RIGHT *) - 'D' : CH := $8; (* CURSOR LEFT *) - 'H' : CH := $2; (* TOGGLE BEGINNING/END *) - 'J' : CH := $19; (* ERASE= ENTER DELETE LINE MODE *) - 'L' : CH := $3; (* PAGE UP *) - 'M' : CH := $10; (* DELETE TO END OF LINE *) - 'N' : CH := $7; (* DELETE CHAR *) - 'P' : CH := $F; (* BLUE = DELETE WORD RIGHT *) - 'Q' : CH := $1B; (* RED = ESCAPE KEY *) - 'R' : CH := $11; (* GREY = SUPER COMMAND *) - 'S' : CH := $6; (* F1 = ENTER INSERT CHAR MODE *) - 'T' : CH := $16; (* F2 = ACCEPT LAST CHANGE *) - 'U' : CH := $13; (* F3 = SEARCH MODE *) - 'V' : CH := $E; (* F4 = INSERT LINE *) - 'W' : CH := $18; (* F5 = FIND AND REPLACE *) - END (* CASE STATEMENT *) - END; (* IF STATEMENT *) - SB_GETCH := CH -END; - -PROCEDURE XYGOTO(X,Y:INTEGER); -BEGIN - SB_OUT_CH(CHR(ESC)); - SB_OUT_CH('Y'); - SB_OUT_CH(CHR(Y+32)); - SB_OUT_CH(CHR(X+32)); - SB_LAST_X := X; - SB_LAST_Y := Y; (* THESE ARE USED ONLY BY USER SOFTWARE *) - (* ROUTINES WHICH PERFORM CLR TO EOS AND *) - (* CLR TO EOL *) -END; - -PROCEDURE SB_CLR_SCRN; -BEGIN - SB_OUT_CH(CHR(ESC)); - SB_OUT_CH('E') -END; - -PROCEDURE SB_CLR_EOS; -BEGIN - SB_OUT_CH(CHR(ESC)); - SB_OUT_CH('J'); -END; - - -PROCEDURE SB_CLR_LINE; -BEGIN - SB_OUT_CH(CHR(ESC)); - SB_OUT_CH('K'); -END; - - -(*--------------------------------------------------------------*) -(* User modification area ENDS WITH SB_CLR_LINE *) -(*--------------------------------------------------------------*) - - -PROCEDURE SB_FLUSH_BUF; -VAR - CH : CHAR; -BEGIN - IF NOT BUFSTAT.OCCUPIED THEN - EXIT; - - REPEAT - PRNT_AT(20,1,'Buffer occupied'); - PRNT_AT(21,1,'Flush, Update, Write & Flush, Leave:'); - CH := SB_UP_CASE(SB_GETCH); - SB_OUT_CH(CH); - IF CH = 'L' THEN - EXIT; - - IF CH = 'F' THEN - BEGIN - IF NEWFILE THEN - PURGE(F); - BUFSTAT.OCCUPIED := FALSE; - EXIT - END; - - IF CH = 'W' THEN - BEGIN - EDITWRITE; - LOGWRITER; - BUFSTAT.OCCUPIED := FALSE - END; - - IF CH = 'U' THEN - BEGIN - EDITWRITE; (* BUT LEAVE IT OCCUPIED *) - LOGWRITER - END - UNTIL (CH='U') or (CH='F') OR (CH='W'); - NEWFILE := FALSE; -END; - - -PROCEDURE SB_BIOS_CALL(FUNC:CPMOPERATION; PARM:INTEGER); -VAR - DISPATCH_LOC : INTEGER; -BEGIN - DISPATCH_LOC := (MEMORY[1] + SWAP(MEMORY[2])) + (ORD(FUNC)*3) - 3; - INLINE("LHLD / PARM / - "MOV C,L / - "MOV B,H / - "LHLD / DISPATCH_LOC / - "PCHL); -END; - -PROCEDURE PRNT_AT(ROW,COL:INTEGER; S:STRING); -BEGIN - XYGOTO(COL,ROW); - WRITE([ADDR(SB_OUT_CH)],S) -END; - -PROCEDURE MENU; -BEGIN - SB_CLR_SCRN; - PRNT_AT(1,1,'H-19 SpeedEdit V5.5'); - PRNT_AT(3,1,'Options: Edit'); - prnt_at(4,20, 'Reformat'); - prnt_at(5,20, 'Syntax check'); - prnt_at(6,20, 'Variable check'); - prnt_at(7,20, 'Xeq'); - prnt_at(8,20, 'Dir'); - prnt_at(9,20, 'Fast compile'); - prnt_at(10,20, 'Quit'); - prnt_at(22,1,'Select ') -END; - -FUNCTION SB_UP_CASE(CH:CHAR): CHAR; -BEGIN - IF (CH >= 'a') AND (CH <= 'z') THEN - SB_UP_CASE := CHR(CH & $DF) - ELSE - SB_UP_CASE := CH -END; - - -(*$E-*) - -FUNCTION GET_FILE_INTO_BUF: BOOLEAN; -BEGIN - IF NOT BUFSTAT.OCCUPIED THEN - IF GETFILE THEN (* GET FILE INTO BUFFER *) - INIT; - GET_FILE_INTO_BUF := BUFSTAT.OCCUPIED -END; -(*$E+*) - - - -BEGIN - BUFSZ := (@SFP - ADDR(BUF))-$100; (* SET UP EDITOR BUFFER SIZE *) - BUFSTAT.OCCUPIED := FALSE; - NEWFILE := FALSE; - REPEAT - MENU; - INTRFACE.NEXT_CMD := ' '; (* DEFAULT NO NEXT PROGRAM *) - INTRFACE.END_STAT := OK; - CMDCH := SB_UP_CASE(SB_GETCH); - SB_OUT_CH(CMDCH); (* ECHO IT *) - REPEAT - FSTRING := ''; (* DEFAULT IS NO PROGRAM *) - CASE CMDCH OF - 'D' : DISP_DIR; - 'E' : BEGIN - IF (BUFSTAT.OCCUPIED) AND ((INTRFACE.PREV_CMD = 'S') - OR (INTERFACE.PREV_CMD = 'R')) THEN - (* DO NOTHING *) - ELSE SB_FLUSH_BUF; - - (* MAKE SURE USER WANTS TO DO THIS *) - - IF NOT BUFSTAT.OCCUPIED THEN (* BUFFER IS EMPTY *) - BEGIN - IF GETFILE THEN - (* SEE IF HE WANTS A FILE *) - BEGIN - INIT; (* CALL EDITOR *) - IF BUFSTAT.OCCUPIED THEN - SPEED - END - END - ELSE - SPEED; - (* BUFFER OCCUPIED, EDIT OLD *) - INTRFACE.PREV_CMD := ' '; - IF INTRFACE.NEXT_CMD = 'E' THEN - INTRFACE.NEXT_CMD := ' '; - END; - 'S' : BEGIN - IF GET_FILE_INTO_BUF THEN - BEGIN - INTRFACE.PREV_CMD := ' '; - SYNCHECK; - IF INTRFACE.END_STAT = SYNERR THEN - INTRFACE.NEXT_CMD := 'E' - END - END; - 'V' : IF GET_FILE_INTO_BUF THEN - VARCHECK; - 'R' : BEGIN - IF GET_FILE_INTO_BUF THEN - BEGIN - INTRFACE.PREV_CMD := 'R'; - PRETTY; - INTRFACE.NEXT_CMD := 'E'; - SB_CLR_SCRN - END - END; - 'X' : BEGIN - SB_FLUSH_BUF; - FSTRING := ''; - MTRUN - END; - 'Q' : BEGIN - INTRFACE.PREV_CMD := ' '; - SB_FLUSH_BUF; - IF BUFSTAT.OCCUPIED THEN - CMDCH := '@' - ELSE - BEGIN - SB_CLR_SCRN; - EXIT - END - END; - 'L' : BEGIN - SB_FLUSH_BUF; - FSTRING := 'LINKMT'; - MTRUN - END; - 'F' : BEGIN - IF GET_FILE_INTO_BUF THEN - BEGIN - SB_FLUSH_BUF; - FSTRING := 'FASTCOMP'; - MOVE(ENDFILE,MEMORY[ADDR(BUF)-2],2); - (* SET UP INTEGER *) - MOVE(NAME,MEMORY[ADDR(BUF)-83],81); - MTRUN - END - END - END; - CMDCH := INTRFACE.NEXT_CMD; - UNTIL (CMDCH = ' ') OR (CMDCH = INTRFACE. - PREV_CMD); - UNTIL FALSE -END. - - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/POWRLIB.SRC b/software/CPM/CPM15_MTPUG_03/POWRLIB.SRC deleted file mode 100644 index 1174cb8..0000000 Binary files a/software/CPM/CPM15_MTPUG_03/POWRLIB.SRC and /dev/null differ diff --git a/software/CPM/CPM15_MTPUG_03/RINGING.CMD b/software/CPM/CPM15_MTPUG_03/RINGING.CMD deleted file mode 100644 index 6c3269c..0000000 --- a/software/CPM/CPM15_MTPUG_03/RINGING.CMD +++ /dev/null @@ -1,2 +0,0 @@ -ringing,dcmodem,crt,paslib/s - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/RINGING.PAS b/software/CPM/CPM15_MTPUG_03/RINGING.PAS deleted file mode 100644 index d0e5823..0000000 --- a/software/CPM/CPM15_MTPUG_03/RINGING.PAS +++ /dev/null @@ -1,56 +0,0 @@ -Program Ring_Test; - -{ Written by Warren A. Smith } -{ Intended for use in the Public Domain } -{ 01/30/82 } - -{ This program utilizes the D.C. Hayes (or PMMI) modem to tell } -{ you if your phone is ringing. I only have one phone line in } -{ my house and if my computer is on it I normally can't tell if } -{ someone is calling. This program will make your terminal tell} -{ you. } - -Var - In_Char : char; - I : integer; - Just_Rang : boolean; - -{ ************ Found in CRT.ERL ************ } -External Procedure ScreenClr; - -External Procedure LineClr; - -External Procedure GotoXY (X, Y : integer); - -External Function KeyPressed (In_Char : char) : boolean; - -{ ************ Found in DCMODEM.ERL (or PMMI.ERL) *********** } -External Function Ringing : boolean; - -begin { Main } -Just_Rang := TRUE; -ScreenClr; -Repeat - If Ringing then - begin - If not Just_Rang then - begin - GotoXY (1,1); - LineClr; - GotoXY (25, 11); - Write('PHONE RINGING', chr(7)); - Just_Rang := TRUE - end - end - else - If Just_Rang then - begin - GotoXY (1,1); - Write('Waiting for phone to ring'); - GotoXY (25, 11); - LineClr; - Just_Rang := FALSE - end -Until KeyPressed (In_Char) -end. { Main } - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/SEND.COM b/software/CPM/CPM15_MTPUG_03/SEND.COM deleted file mode 100644 index 0b53008..0000000 Binary files a/software/CPM/CPM15_MTPUG_03/SEND.COM and /dev/null differ diff --git a/software/CPM/CPM15_MTPUG_03/STATLIB.SRC b/software/CPM/CPM15_MTPUG_03/STATLIB.SRC deleted file mode 100644 index 56177c1..0000000 --- a/software/CPM/CPM15_MTPUG_03/STATLIB.SRC +++ /dev/null @@ -1,114 +0,0 @@ -{Statistical function library for Pascal} - -MODULE STATLIB; -{$M MINMAXI} -{$M MEANI} -{$M SIGMAI} -{$M MINMAXR} -{$M MEANR} -{$M SIGMAR} -{$M *} - -TYPE - NATURAL = 0..MAXINT; - -PROCEDURE MINMAX_I - (VAR X:ARRAY[LOW..HIGH:NATURAL]OF INTEGER;N:INTEGER;VAR MIN,MAX:INTEGER); -VAR - I:NATURAL; -BEGIN - I:=LOW; {starting point of array} - MIN:=32767; - MAX:=-32767; {limit values} - REPEAT - IF X[I] < MIN THEN - MIN:=X[I] - ELSE - IF X[I] > MAX THEN - MAX:=X[I]; - I:=I+1 - UNTIL I > N -END; - -PROCEDURE MEAN_I - (VAR X:ARRAY[LOW..HIGH:NATURAL]OF INTEGER;N:INTEGER;VAR MEAN:REAL); -VAR - J:NATURAL; - SUM:REAL; -BEGIN - J:=LOW; - SUM:=0.0; - REPEAT - SUM:=SUM+X[J]; - J:=J+1 - UNTIL J > N; - MEAN:=SUM/N -END; - -PROCEDURE SIGMA_I - (VAR X:ARRAY[LOW..HIGH:NATURAL]OF INTEGER;N:INTEGER;VAR SIGMA:REAL); -VAR - K:NATURAL; - SUM,AVE:REAL; -BEGIN - MEAN_I(X,N,AVE); - K:=LOW; - SUM:=0.0; - REPEAT - SUM:=SUM+SQR(X[K]-AVE); - K:=K+1 - UNTIL K > N; - SIGMA:=SQRT(SUM/N) -END; - -PROCEDURE MINMAX_R - (VAR X:ARRAY[LOW..HIGH:NATURAL]OF REAL;N:INTEGER;VAR MIN,MAX:REAL); -VAR - L:NATURAL; -BEGIN - L:=LOW; {starting point of array} - MIN:=10.0E+17; - MAX:=10.0E-17; {limit values} - REPEAT - IF X[L] < MIN THEN - MIN:=X[L] - ELSE - IF X[L] > MAX THEN - MAX:=X[L]; - L:=L+1 - UNTIL L > N -END; - -PROCEDURE MEAN_R - (VAR X:ARRAY[LOW..HIGH:NATURAL]OF REAL;N:INTEGER;VAR MEAN:REAL); -VAR - M:NATURAL; - SUM:REAL; -BEGIN - M:=LOW; - SUM:=0.0; - REPEAT - SUM:=SUM+X[M]; - M:=M+1 - UNTIL M > N; - MEAN:=SUM/N -END; - -PROCEDURE SIGMA_R - (VAR X:ARRAY[LOW..HIGH:NATURAL]OF REAL;N:INTEGER;VAR SIGMA:REAL); -VAR - Q:NATURAL; - SUM,AVE:REAL; -BEGIN - MEAN_R(X,N,AVE); - Q:=LOW; - SUM:=0.0; - REPEAT - SUM:=SUM+SQR(X[Q]-AVE); - Q:=Q+1 - UNTIL Q > N; - SIGMA:=SQRT(SUM/N) -END; - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/TERMINAL.CMD b/software/CPM/CPM15_MTPUG_03/TERMINAL.CMD deleted file mode 100644 index a539a8c..0000000 --- a/software/CPM/CPM15_MTPUG_03/TERMINAL.CMD +++ /dev/null @@ -1,2 +0,0 @@ -terminal,utility,dcmodem,crt,paslib/s - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/TERMINAL.PAS b/software/CPM/CPM15_MTPUG_03/TERMINAL.PAS deleted file mode 100644 index adccd82..0000000 --- a/software/CPM/CPM15_MTPUG_03/TERMINAL.PAS +++ /dev/null @@ -1,261 +0,0 @@ -Program Terminal; - -{ Written by Warren A. Smith } -{ Intended for use in the Public Domain } -{ 01/30/82 } - -{ This program is intended to give you the capability to use your } -{ computer as a dumb terminal connected to another computer. It can } -{ operate in full or half duplex and can be in a test mode where it } -{ will display all the characters coming in in hex form (unless they } -{ are printable. This latter is handy if you are trying to talk to an } -{ unknown device and you want to find out what it is sending to cause } -{ your screen to behave so funny. } -{ The program can also convert carriage returns to CNTL-S (or DC3) } -{ which is useful in a TWX network or when talking to some IBM systems } -{ which only accept teletypes that are configured for TWX (my case, and } -{ the reason the feature is in here. } - -Var - Modem_Mode : byte; { must be used to hold modem's mode } - I : integer; - Number : string; - Quit, - Half_Duplex, - Test_Line, - Xoff : boolean; - ESC_Chr, - Control_Code, - In_Char, - Answer : char; - -{ *********** Found in CRT.ERL ************ } -External Procedure ScreenClr; - -External Procedure GotoXY (X, Y : integer); - -External Procedure ConOut (OutChar : char); - -External Function KeyPressed (Var In_Char : char) : boolean; - -External Function Get_Console : char; - -{ ************ Found in UTILITY.ERL ************ } -External Function Upper (In_Char : char) : char; - -{ ************ Found in DCMODEM.ERL ************ } -External Procedure Init_Modem; - -External Procedure Set_Modem (Modebyte : byte); - -External Procedure Go_Onhook (Var Modem_Mode : byte); - -External Procedure Go_Offhook (Var Modem_Mode : byte); - -External Procedure Set_Ans_Mode (Var Modem_Mode : byte); - -External Procedure Set_Org_Mode (Var Modem_Mode : byte); - -External Procedure Set_Baud (Baud : integer; Var Modem_Mode : byte); - -External Procedure Enable_Xmit (Var Modem_Mode : byte); - -External Procedure Disable_Xmit (Var Modem_Mode : byte); - -External Function Carrier_Present : boolean; - -External Function Ringing : boolean; - -External Function Modem_Char_Rdy : boolean; - -External Function Modem_In : char; - -External Function Modem_Out (OutChar : char) : boolean; - -External Procedure Delay; { delay's for 10 millisecond } - -External Procedure Dial_a_Number (Var Modem_Mode : byte; Number : string); - - - -Function Perform_Function (Control_Char : char) : boolean; - - Var - Dummy_Boolean : boolean; - - begin { Perform_Function } - Case Control_Char of - '@' : begin - Half_Duplex := not Half_Duplex; - If Half_Duplex then - Writeln ('Half_Duplex') - else - Writeln ('Full Duplex'); - Perform_Function := TRUE - end; - 'A' : Perform_Function := FALSE; - 'B' : begin - Test_Line := not Test_Line; - Perform_Function := TRUE - end; - else - end - end; { Perform_Function } - -Procedure Dumb; - - Var - Terminator, In_Char, In_Mod, - Control_Char, Dummy_Char : char; - Quit : boolean; - - begin { Dumb } - In_Char := chr(0); - Terminator := chr(26); { CNTL-Z } - Quit := FALSE; - - While (In_Char <> Terminator) AND not Quit do - begin - If KeyPressed (In_Char) then - begin - If In_Char = chr(13) then { carriage return } - In_Char := chr(19); { control-S } - If In_Char = ESC_Chr then - begin - Control_Char := Get_Console; - Dummy_Char := Get_Console; { should be a carriage return } - Quit := not Perform_Function (Control_Char) - end - else - If Modem_Out (In_Char) then - begin - If Half_Duplex then - ConOut (In_Char) - end - else - begin - Writeln ('Carrier Lost'); - Quit := TRUE - end - end; - - If Modem_Char_Rdy then - begin - In_Mod := Modem_In; - If Test_Line then - If (In_Mod >= ' ') AND (In_Mod <= '~') then - ConOut (In_Mod) - else - begin - WriteHex (Output, In_Mod, 1); - Writeln - end - else - ConOut (In_Mod) - end; - - If not Carrier_Present then - begin - Writeln ('Carrier Lost'); - Quit := TRUE - end - end - end; { Dumb } - -Procedure Title_Page; - - begin { Title_Page } - Writeln; - Writeln(' *****************************************'); - Writeln(' * *'); - Writeln(' * Written by Warren A. Smith *'); - Writeln(' * *'); - Writeln(' * For the Public Domain *'); - Writeln(' * *'); - Writeln(' *****************************************'); - Writeln; - Writeln('The function keys of the Televideo 920 are used as follows:'); - Writeln(' F1 - Toggle between Half and Full Duplex'); - Writeln(' F2 - Terminate connection and hang up'); - Writeln(' F3 - Toggle test mode'); - Writeln; - Writeln(' If you do not have a Televideo 912/920 you may duplicate the'); - Writeln(' function keys by hitting a CNTL-A followed by'); - Writeln(' @ (for F1)'); - Writeln(' A (for F2)'); - Writeln(' B (for F3)'); - Writeln(' followed by a carriage return.'); - Writeln; - Write ('Hit any key to continue. '); - While not KeyPressed (In_Char) do; - ScreenClr; - end; { Title_Page } - -begin { Main } - -ESC_Chr := chr(01); - -Half_Duplex := TRUE; -Test_Line := FALSE; - -ScreenClr; - -Title_Page; - -Writeln('Answer N to the following question if you don''t understand it.'); -Writeln('It is giving you the option to convert carriage returns to CNTL-S.'); -Writeln('This is useful for TWX networks and some IBM systems. Use N if'); -Writeln('you are unsure.'); -Write('Will you be using X-Off (carriage return = cntl-S) (Y or N)? '); -Read (Answer); -Writeln; -Xoff := Upper(Answer)='Y'; - -Modem_Mode := 0; - -Init_Modem; - -Write ('Number Please - '); -Readln (Number); - -Writeln ('Dialing'); - -Dial_a_Number (Modem_Mode, Number); - -Set_Baud (300, Modem_Mode); - -Set_Org_Mode (Modem_Mode); - -Enable_Xmit (Modem_Mode); - -I := 0; { Set up for 20 second timeout } -While (I < 2000) AND (not Carrier_Present) do - begin - If KeyPressed (In_Char) then - If In_Char = ESC_Chr then - begin - Control_Code := Get_Console; - In_Char := Get_Console; { supposed to be CR } - Quit := not Perform_Function (Control_Code) - end; - Delay; - I := I + 1 - end; - -If Carrier_Present then - begin - Writeln ('Connection made'); - If not Quit then - Dumb - end -else - Writeln ('No carrier found, check number - ', Number); - -Go_Onhook (Modem_Mode); - -Writeln ('Hanging Up'); - -Writeln ('Program terminated') - -end. - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/TRIGLIB.SRC b/software/CPM/CPM15_MTPUG_03/TRIGLIB.SRC deleted file mode 100644 index d1c1d7d..0000000 --- a/software/CPM/CPM15_MTPUG_03/TRIGLIB.SRC +++ /dev/null @@ -1,136 +0,0 @@ -{TRIG Function library for Pascal; (c) 1981 by Ficomp, Inc. Fairfax, Va.} - -MODULE TRIGLIB; -{$M RAD} -{$M DEG} -{$M PI} -{$M TAN} -{$M COTAN} -{$M ASIN} -{$M ACOS} -{$M ATAN2} -{$M *} - -CONST - DRCON = 0.0174532925; - HALF_PI = 1.570796327; - FULL_PI = 3.141592654; - MAXREAL = 10.0E+17; -VAR - A:REAL; -EXTERNAL PROCEDURE @ERR(AN_ERROR:BOOLEAN; ERRNUM:INTEGER); - -FUNCTION RAD(X:REAL): REAL; -{CONVERTS DEGREES TO RADIANS} -BEGIN - RAD := X*DRCON -END; - -FUNCTION DEG(X:REAL): REAL; -{CONVERTS RADIANS TO DEGREES} -BEGIN - DEG := X/DRCON -END; - -FUNCTION PI(X:REAL): REAL; -{Returns PI*X} -BEGIN - PI := FULL_PI*X -END; - -FUNCTION TAN(X:REAL): REAL; -{TANGENT FUNCTION} -BEGIN - A := COS(X); - IF A=0.0 THEN - TAN := MAXREAL - ELSE - TAN := SIN(X)/A -END; - -FUNCTION COTAN(X:REAL): REAL; -{COTANGENT FUNCTION} -BEGIN - A := SIN(X); - IF A = 0.0 THEN - COTAN := MAXREAL - ELSE - COTAN := COS(X)/A -END; - -FUNCTION ASIN(X:REAL): REAL; -{ARCSIN FUNCTION} -BEGIN - IF X=0.0 THEN - ASIN:=0.0 - ELSE - IF X=1.0 THEN - ASIN:=HALF_PI - ELSE - IF X=-1.0 THEN - ASIN:=-HALF_PI - ELSE - IF (X<-1.0) OR (X>1.0) THEN - BEGIN - @ERR(TRUE,4); - WRITELN('ASIN(',X,') '); - ASIN :=0.0 - END - ELSE - ASIN := ARCTAN(X/SQRT(-X*X+1.0)) -END; - -FUNCTION ACOS(X:REAL): REAL; -{ARCOSINE FUNCTION} -BEGIN - IF X=0.0 THEN - ACOS:=HALF_PI - ELSE - IF X=1.0 THEN - ACOS:=0.0 - ELSE - IF X=-1.0 THEN - ACOS:=FULL_PI - ELSE - IF (X<-1.0) OR (X>1.0) THEN - BEGIN - @ERR(TRUE,4); - WRITELN('ACOS(',X,') '); - ACOS :=0.0 - END - ELSE - ACOS := -ARCTAN(X/SQRT(-X*X+1.0))+HALF_PI -END; - -FUNCTION ATAN2(X,Y:REAL):REAL; -{arctangent function with quadrant recognition} -BEGIN - IF X=0.0 THEN - IF Y=0.0 THEN - ATAN2:=0.0 - ELSE - IF Y>0.0 THEN - ATAN2:=HALF_PI - ELSE - ATAN2:=3*HALF_PI - ELSE - IF Y=0.0 THEN - IF X>0.0 THEN - ATAN2:=0.0 - ELSE - ATAN2:=FULL_PI - ELSE - BEGIN - A:=ARCTAN(Y/X); - IF X>0.0 THEN - ATAN2:=A - ELSE - ATAN2:=A+FULL_PI - END -END; - -MODEND. -SE - BEGIN - A:=ARCTAN(Y/X); - IF X>0.0 THEN \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/UTILITY.PAS b/software/CPM/CPM15_MTPUG_03/UTILITY.PAS deleted file mode 100644 index ea121fe..0000000 --- a/software/CPM/CPM15_MTPUG_03/UTILITY.PAS +++ /dev/null @@ -1,22 +0,0 @@ -Module Utility ; - -{ Written by Warren A. Smith } -{ Intended for use in the Public Domain } -{ 01/30/82 } - -{ This only has one routine so far but what the heck. } - -Function Upper (In_Char : char) : char ; - -{ I don't like having to redo this in all my interactive programs, } -{ I thought you may not like to either. } - - Begin { Upper } - If (In_Char >= 'a') and (In_Char <= 'z') then - Upper := chr( ord(In_Char) - 32) - else - Upper := In_Char - end ; { Upper } - -ModEnd. - \ No newline at end of file diff --git a/software/CPM/CPM15_MTPUG_03/VARIO.SRC b/software/CPM/CPM15_MTPUG_03/VARIO.SRC deleted file mode 100644 index e5f2eb1..0000000 Binary files a/software/CPM/CPM15_MTPUG_03/VARIO.SRC and /dev/null differ diff --git a/software/CPM/CPM16_MTPUG_04/-MTPUG.004 b/software/CPM/CPM16_MTPUG_04/-MTPUG.004 deleted file mode 100644 index e69de29..0000000 diff --git a/software/CPM/CPM16_MTPUG_04/-MTPUG.DOC b/software/CPM/CPM16_MTPUG_04/-MTPUG.DOC deleted file mode 100644 index a6411a0..0000000 --- a/software/CPM/CPM16_MTPUG_04/-MTPUG.DOC +++ /dev/null @@ -1,47 +0,0 @@ -**** MTPUG.004 **** August 15, 1982 - -COMPARE/SRà Thå UCSÄ 1.´ Versioî modifieä bù  - /ERL H. Lucas for MT+. Compares two TEXT files - /COM line by line with line lengths up to 132. - Compiled with MT+ 5.5 with Z option. - -DIRFILE/SRC The program which appeared in Newsletter #5 - /SU whicè createó á filå oæ up to 200 directorù -CPMNAME/SRà entrieó oî á disk® Writteî bù Steve Clamage. - -INDEXER/SRC Many uses. Perhaps the best is to create a file - /SUB of procedure names for preparing external - /DOC declarations in a multi-module implementation. - Updated by Steve Clamage. - -XREF/SRC Updated version which recognizes "@", underscore, - /SUB Braces and corrects many errors. Updated by - /DOC Steve Clamage. The .COM file was complied by - /COM H. Lucas and linked using the corrected @RNB. - -SWEEP/COM Written by Robert Fisher. An unusually versatile - program for multifile copy or list, delete or - rename of files. Type "sweep" to view the commands. - -SD/COM An alphabetic sort of files on a disk are listed at - the terminal including the space for each. A must - for good control of space. - -PLOTLIB/DOC A collection of programs for creating plots of data - /SUB with a MicroAngelo dislpay board. Updated by - /*** Ray Hopkins for MT+. ** Save a lot of typing ** - -HEXDMP/SRC A Pascal/MT+ program to read any file and dump - /DOC to a disk file = "HEXDMP.DAT" for later viewing. - /ERL at the terminal or when printed. Written by - /COM H. Lucas. Particularily useful when viewing files - created by another system or language. - -LONGLINE/PAS A collection of Pascal programs written for Pascal/Z -NADY /PAS and appearing on their program disks. Included with -PTABLE /PAS permission of Charlie Foster, Editor of Pascal/Z -QQSORT /PAS Newsletter. All need conversion to MT+ and all -QSORT /PAS include some interesting examples of unique program -SHELL /PAS design. -ZCOMPR /PAS - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/COMPARE.COM b/software/CPM/CPM16_MTPUG_04/COMPARE.COM deleted file mode 100644 index 27d0a5c..0000000 Binary files a/software/CPM/CPM16_MTPUG_04/COMPARE.COM and /dev/null differ diff --git a/software/CPM/CPM16_MTPUG_04/COMPARE.ERL b/software/CPM/CPM16_MTPUG_04/COMPARE.ERL deleted file mode 100644 index 3475c29..0000000 Binary files a/software/CPM/CPM16_MTPUG_04/COMPARE.ERL and /dev/null differ diff --git a/software/CPM/CPM16_MTPUG_04/COMPARE.SRC b/software/CPM/CPM16_MTPUG_04/COMPARE.SRC deleted file mode 100644 index 377e15f..0000000 --- a/software/CPM/CPM16_MTPUG_04/COMPARE.SRC +++ /dev/null @@ -1,346 +0,0 @@ - PROGRAM SRCCOM; (* SOURCE COMPARE *) -{ I GOT THIS PROGRAM FROM THE PASCAL/Z USERS PROGRAM DISKS } -{ THEY GOT IT FROM THE UCSD PASCAL USERS GROUP } -{ Revised 5/3/82 by Henry Lucas } - -{Program to compare two sourcecode files and output the differences, - if any. Useful to compare two similar textfiles to find out whether and - where they have been changed. Part of original UCSD I.4 release--author - is unknown.} - -CONST - VERSION = 'v203 5-3-82'; - MINLINESFORMATCH = 6; - MAXTRY = 150; (*<<<10/27/77 GLH. LIMIT ON SEARCH AHEAD FOR MATCH*) - LINELENGTH = 132; - - TYPE - - LINEPOINTER = ^LINE; - LINE = - RECORD (*<<<10/26/77 GLH*) - NEXTLINE : LINEPOINTER; - IMAGE : STRING[LINELENGTH] - END; - - STREAM = - RECORD - CURSOR, HEAD, TAIL : LINEPOINTER; - CURSORLINENO, HEADLINENO, TAILLINENO : INTEGER; - ENDFILE : BOOLEAN - END; - - VAR - - TITLEA, TITLEB: STRING; (*<<<10/27/77 GLH*) - FILEA, FILEB : TEXT; - A, B : STREAM; - MATCH : BOOLEAN; - ENDFILE : BOOLEAN; - TEMPLINE : STRING[LINELENGTH]; (*<<<10/26/77 GLH*) - FREELINES : LINEPOINTER; - SAME : BOOLEAN; - STR : STRING; - MAXPTR : WORD; - - @sfp : external word; - EXTERNAL PROCEDURE @HLT; - - PROCEDURE COMPARE; - - FUNCTION ENDSTREAM(VAR X : STREAM) : BOOLEAN; - BEGIN (* ENDSTREAM *) - ENDSTREAM := (X.CURSOR = NIL) AND X.ENDFILE - END; (* ENDSTREAM *) - - PROCEDURE MARK(VAR X : STREAM); - - (* CAUSES BEGINNING OF STREAM TO BE POSITIONED BEFORE *) - (* CURRENT STREAM CURSOR. BUFFERS GET RECLAIMED, LINE *) - (* COUNTERS RESET, ETC. *) - - PROCEDURE COLLECT(FWA, LWAPLUS1 : LINEPOINTER); - VAR P : LINEPOINTER; - BEGIN (* COLLECT *) - WHILE FWA <> LWAPLUS1 DO - BEGIN P := FWA^.NEXTLINE; - FWA^.NEXTLINE := FREELINES; FREELINES := FWA; - FWA := P - END - END; (* COLLECT *) - - BEGIN (* MARK *) - IF X.HEAD <> NIL THEN - BEGIN - COLLECT(X.HEAD, X.CURSOR); - X.HEAD := X.CURSOR; X.HEADLINENO := X.CURSORLINENO; - IF X.CURSOR = NIL THEN - BEGIN X.TAIL := NIL; X.TAILLINENO := X.CURSORLINENO END - END - END; (* MARK *) - - PROCEDURE MOVECURSOR(VAR X : STREAM; VAR FILEX : TEXT); - - (* FILEX IS THE INPUT FILE ASSOCIATED WITH STREAM X. THE *) - (* CURSOR FOR X IS MOVED FORWARD ONE LINE, READING FROM X *) - (* IF NECESSARY, AND INCREMENTING THE LINE COUNT. ENDFILE *) - (* IS SET IF EOF ENCOUNTERED ON EITHER STREAM. *) - - PROCEDURE READLINE; - VAR - NEWLINE : LINEPOINTER; - BEGIN (* READLINE *) - IF NOT X.ENDFILE THEN - BEGIN - (*<<<10/26/77 GLH. CHANGED WAY CHARS GET INTO TEMPLINE*) - READLN(FILEX, TEMPLINE); - NEWLINE := FREELINES; - IF NEWLINE <> NIL THEN FREELINES := FREELINES^.NEXTLINE - ELSE BEGIN - NEW(NEWLINE); - MAXPTR:=WRD(NEWLINE) + WRD(SIZEOF(LINE)); - IF MAXPTR > @SFP THEN - BEGIN - WRITELN(' NOT ENOUGH SPACE: STOPPING'); - @HLT - END - END; - - NEWLINE^.IMAGE := TEMPLINE; (*<<<10/26/77 GLH*) - NEWLINE^.NEXTLINE := NIL; - IF X.TAIL = NIL THEN - BEGIN X.HEAD := NEWLINE; - X.TAILLINENO := 1; X.HEADLINENO := 1 - END - ELSE - BEGIN X.TAIL^.NEXTLINE := NEWLINE; - X.TAILLINENO := X.TAILLINENO + 1 - END; - X.TAIL := NEWLINE; - X.ENDFILE := EOF(FILEX); - END - END; (* READLINE *) - - BEGIN (* MOVECURSOR *) - IF X.CURSOR <> NIL THEN - BEGIN - IF X.CURSOR = X.TAIL THEN READLINE; - X.CURSOR := X.CURSOR^.NEXTLINE; - IF X.CURSOR = NIL THEN ENDFILE := TRUE; - X.CURSORLINENO := X.CURSORLINENO + 1 - END - ELSE - IF NOT X.ENDFILE THEN (* BEGINNING OF STREAM *) - BEGIN - READLINE; X.CURSOR := X.HEAD; - X.CURSORLINENO := X.HEADLINENO - END - ELSE (* END OF STREAM *) - ENDFILE := TRUE; - END; (* MOVECURSOR *) - - PROCEDURE BACKTRACK(VAR X : STREAM; VAR XLINES : INTEGER); - - (* CAUSES THE CURRENT POSITION OF STREAM THE NEW CURRENT *) - (* THE LINE COUNTER IS RETURNED IN XLINES. IT IS THE NUMBER *) - (* OF THE CURRENT LINE (BEFORE BACKTRACK) RELATIVE TO BEGINNING *) - (* OF STREAM. *) - - BEGIN (* BACKTRACK *) - XLINES := X.CURSORLINENO + 1 - X.HEADLINENO; - X.CURSOR := X.HEAD; X.CURSORLINENO := X.HEADLINENO; - ENDFILE := ENDSTREAM(A) OR ENDSTREAM(B) - END; (* BACKTRACK *) - - PROCEDURE COMPARELINES(VAR MATCH : BOOLEAN); - (* COMPARE THE CURRENT LINES OF STREAMS A AND B, RETURNING *) - (* MATCH TO SIGNAL THEIR (NON-) EQUIVALENCE. EOF ON BOTH STREAMS *) - (* IS CONSIDERED A MATCH, BUT EOF ON ONLY ONE STREAM IS A MISMATCH *) - - BEGIN (* COMPARELINES *) - IF (A.CURSOR = NIL) OR (B.CURSOR = NIL) THEN - MATCH := ENDSTREAM(A) AND ENDSTREAM(B) - ELSE - MATCH := (A.CURSOR^.IMAGE = B.CURSOR^.IMAGE) - END; (* COMPARELINES *) - - PROCEDURE FINDMISMATCH; - - BEGIN (* FINDMISMATCH *) - (* NOT ENDFILE AND MATCH *) - REPEAT (* COMPARENEXTLINES *) - MOVECURSOR(A, FILEA); MOVECURSOR(B,FILEB); - MARK(A); MARK(B); - COMPARELINES(MATCH) - UNTIL ENDFILE OR NOT MATCH; - END; (* FINDMISMATCH *) - - PROCEDURE FINDMATCH; - - VAR - TRYCOUNT : INTEGER; - - PROCEDURE SEARCH(VAR X : STREAM; (* STREAM TO SEARCH *) - VAR FILEX : TEXT; - VAR Y : STREAM; (* STREAM TO LOOKAHEAD *) - VAR FILEY : TEXT); - - (* LOOK AHEAD ONE LINE ON STREAM Y, AND SEARCH FOR THAT LINE *) - (* BACKTRACKING ON STREAM X. *) - - VAR - COUNT : INTEGER; (* NUMBER OF LINES BACKTRACKED ON X *) - - PROCEDURE CHECKFULLMATCH; - (* FROM THE CURRENT POSITIONS IN X AND Y, WHICH MATCH, *) - (* MAKE SURE THAT THE NEXT MINLINESFORMATCH-1 LINES ALSO *) - (* MATCH, OR ELSE SET MATCH := FALSE. *) - VAR - N : INTEGER; - SAVEXCUR, SAVEYCUR : LINEPOINTER; - SAVEXLINE, SAVEYLINE : INTEGER; - BEGIN (* CHECKFULLMATCH *) - SAVEXCUR := X.CURSOR; SAVEYCUR := Y.CURSOR; - SAVEXLINE := X.CURSORLINENO; SAVEYLINE := Y.CURSORLINENO; - COMPARELINES(MATCH); - N := MINLINESFORMATCH - 1; - WHILE MATCH AND (N <> 0) DO - BEGIN MOVECURSOR(X, FILEX); MOVECURSOR(Y, FILEY); - COMPARELINES(MATCH); N := N - 1 - END; - X.CURSOR := SAVEXCUR; X.CURSORLINENO := SAVEXLINE; - Y.CURSOR := SAVEYCUR; Y.CURSORLINENO := SAVEYLINE; - END; (* CHECKFULLMATCH *) - - BEGIN (* SEARCH *) - MOVECURSOR(Y, FILEY); BACKTRACK(X, COUNT); - CHECKFULLMATCH; COUNT := COUNT - 1; - WHILE (COUNT <> 0) AND NOT MATCH DO - BEGIN - MOVECURSOR(X, FILEX); COUNT := COUNT - 1; - CHECKFULLMATCH - END - END; (* SEARCH *) - - PROCEDURE PRINTMISMATCH; - VAR - EMPTYA, EMPTYB : BOOLEAN; - - PROCEDURE WRITETEXT(P, Q : LINEPOINTER); - BEGIN (* WRITETEXT *) - WRITELN; - WHILE (P <> NIL) AND (P <> Q) DO - BEGIN WRITE(' * '); - WRITELN (P^.IMAGE); - P := P^.NEXTLINE - END; - IF P = NIL THEN WRITELN(' *** EOF ***'); - WRITELN - END; (* WRITETEXT *) - - PROCEDURE WRITELINENO(VAR X : STREAM); - VAR - F, L : INTEGER; - BEGIN (* WRITELINENO *) - F := X.HEADLINENO; L := X.CURSORLINENO - 1; - WRITE('LINE'); - IF F = L THEN WRITE(' ', F) - ELSE WRITE('S ', F, ' TO ', L); - IF X.CURSOR = NIL THEN WRITE(' (BEFORE EOF)'); - END; (* WRITELINENO *) - - PROCEDURE PRINTEXTRATEXT(VAR X : STREAM; XNAME : STRING; - VAR Y : STREAM; YNAME : STRING); - BEGIN (* PRINTEXTRATEXT *) - WRITE(' EXTRA TEXT ON ', XNAME, ', '); - WRITELINENO(X); WRITELN; - IF Y.HEAD = NIL THEN - WRITELN(' BEFORE EOF ON ', YNAME) - ELSE - WRITELN(' BETWEEN LINES ', Y.HEADLINENO-1, ' AND ', - Y.HEADLINENO, ' OF ', YNAME); - WRITETEXT(X.HEAD, X.CURSOR) - END; (* PRINTEXTRATEXT *) - - BEGIN (* PRINTMISMATCH *) - WRITELN(' ***********************************'); - EMPTYA := (A.HEAD = A.CURSOR); - EMPTYB := (B.HEAD = B.CURSOR); - IF EMPTYA OR EMPTYB THEN - IF EMPTYA THEN PRINTEXTRATEXT(B, TITLEB, A, TITLEA) - ELSE PRINTEXTRATEXT(A, TITLEA, B, TITLEB) - ELSE - BEGIN - WRITELN(' MISMATCH:'); WRITELN; - WRITE(' ', TITLEA, ', '); WRITELINENO(A); WRITELN(':'); - WRITETEXT(A.HEAD, A.CURSOR); - WRITE(' ', TITLEB, ', '); WRITELINENO(B); WRITELN(':'); - WRITETEXT(B.HEAD, B.CURSOR) - END - END; (* PRINTMISMATCH *) - - BEGIN (* FINDMATCH *) - TRYCOUNT := 0; - WHILE (NOT MATCH) AND (TRYCOUNT <= MAXTRY) DO - BEGIN - SEARCH(A, FILEA, B, FILEB); - TRYCOUNT := TRYCOUNT+1; - END; - IF NOT MATCH THEN - BEGIN - TRYCOUNT:=0; - WHILE (NOT MATCH) AND (TRYCOUNT<=MAXTRY) DO - BEGIN - SEARCH(B, FILEB, A, FILEA); - TRYCOUNT:=TRYCOUNT+1; - END; - END; - PRINTMISMATCH; - IF (NOT MATCH) AND (TRYCOUNT>MAXTRY) THEN - BEGIN MARK(A); MARK(B) END; - END; (* FINDMATCH *) - - - - BEGIN (* COMPARE *) - ENDFILE := FALSE; MATCH := TRUE; (* I.E., BOI MATCHES BOI *) - REPEAT - IF MATCH THEN FINDMISMATCH ELSE BEGIN SAME := FALSE; FINDMATCH END - UNTIL ENDFILE AND MATCH; - MARK(A); MARK(B); (* MARK END OF FILES, THEREBY DISPOSING BUFFERS *) - END; (* COMPARE *) - - PROCEDURE INITSTREAM(VAR X : STREAM; VAR FILEX : TEXT); - BEGIN (* INITSTREAM *) - X.CURSOR := NIL; X.HEAD := NIL; X.TAIL := NIL; - X.CURSORLINENO := 0; X.HEADLINENO := 0; X.TAILLINENO := 0; - X.ENDFILE := EOF(FILEX); - END; (* INITSTREAM *) - - -BEGIN (* SRCCOM *) - WRITELN('INPUT FILE NAME:'); READLN(TITLEA); - ASSIGN(FILEA, TITLEA); - WRITELN('SECOND INPUT FILE NAME:'); READLN(TITLEB); - ASSIGN(FILEB, TITLEB); - RESET(FILEA); RESET(FILEB); - INITSTREAM(A, FILEA); INITSTREAM(B, FILEB); - FREELINES := NIL; - WRITELN('Source Compare [', VERSION, ']' ); - WRITELN; - IF EOF(FILEA) THEN - BEGIN WRITELN(TITLEA, ' IS EMPTY.'); - IF EOF(FILEB) THEN WRITELN(TITLEB, ' IS EMPTY.') - END - ELSE - IF EOF(FILEB) THEN WRITELN(TITLEB, ' IS EMPTY.') - ELSE - BEGIN SAME := TRUE; - COMPARE; - IF SAME THEN WRITELN('No differences encountered.'); - END; - WRITELN(' MAXIMUM POINTER = ',ord(maxptr)); -END. (* SRCCOM *) - - - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/CPMNAME.SRC b/software/CPM/CPM16_MTPUG_04/CPMNAME.SRC deleted file mode 100644 index 3079336..0000000 --- a/software/CPM/CPM16_MTPUG_04/CPMNAME.SRC +++ /dev/null @@ -1,80 +0,0 @@ -module tstcpmname; - {Test input string for valid CP/M file name or device} - {by Steve Clamage} - - - function cpmname(fname: string): boolean; - - const - numdevs = 6; {number of defined devices} - - type - devs = 1..numdevs; - devnames = array [devs] of string[4]; - - var - gotdot: boolean; - cname, cext, i, len: integer; - badset: set of char; - devtptr: ^devnames; - - - procedure devname; {table of device names} - - begin {[f-]} - inline( 4/ 'CON:'/ - 4/ 'KBD:'/ - 4/ 'TRM:'/ - 4/ 'LST:'/ - 4/ 'RDR:'/ - 4/ 'PUN:' - ); {[f+]} - end; - - begin {cpmname} - devtptr := addr(devname); - for i := 1 to numdevs do {check for device name} - if fname = devtptr^[i] then - begin - cpmname := true; - exit; {got one, so it's ok} - end; - cpmname := false; {assume the worst} - badset := [' ', '<', '>', ',', ':', '=', '*', '?', '[', ']']; - len := length(fname); - if len = 0 then {zero-length name} - exit; - i := 1; {start with 1st character} - if len > 1 then - if fname[2] = ':' then {if 2nd is colon...} - i := 3; {...start test with 3rd} - gotdot := false; - cname := 0; {# chars in name portion} - while (i <= len) and (not gotdot) do {scan name portion} - begin - if fname[i] = '.' then {period terminates name scan} - gotdot := true - else - begin - cname := cname + 1; - if fname[i] in badset then - exit; {illegal character} - end; - i := i + 1 - end; - cext := 0; {# chars in extent portion} - badset := badset + ['.']; - while (i <= len) do {scan extent portion} - begin - cext := cext + 1; - if fname[i] in badset then - exit; {illegal character} - i := i + 1; - end; - if (cname < 1) or (cname > 8) or (cext > 3) then - exit; {improper length} - cpmname := true; {it's ok!} - end; - -modend . - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/DIRFILE.SRC b/software/CPM/CPM16_MTPUG_04/DIRFILE.SRC deleted file mode 100644 index 5dae97f..0000000 --- a/software/CPM/CPM16_MTPUG_04/DIRFILE.SRC +++ /dev/null @@ -1,153 +0,0 @@ -PROGRAM dirfile(input,output); - -{by Steve Clamage} - -{reads disk directory, optionally sorts it, writes it to FILES.SUB} - -CONST - MAXNAMES = 200; {max file names in directory} - SRCHF = 17; {CP/M search for first} - SRCHN = 18; {CP/M search for next} - SETDMA = 26; {CP/M set dma address} - -TYPE - NAMEREC = - record - name : string[12]; - ext : string[3]; - end; - - SORTTYPE = (NOSORT, BYFILE, BYEXTN); - -VAR - i, loc, nfiles : INTEGER; - leader, trailer : STRING; - fname : STRING; - extn : STRING[3]; - store : array [0 .. MAXNAMES] of NAMEREC; - sentinel : NAMEREC; - fcb : array [0 .. 35] of CHAR; - buf : array [0 .. 127] of CHAR; - fileout : TEXT; - optn : CHAR; - howsort : SORTTYPE; - -{call BDOS} - EXTERNAL FUNCTION @bdos(func, parm : INTEGER) : INTEGER; -{validate file name} - EXTERNAL FUNCTION cpmname(filename : STRING) : BOOLEAN; - -PROCEDURE getfname; {get file name into fname, extn} - VAR - j : INTEGER; - BEGIN - fname[0] := chr(0); - extn[0] := chr(0); - for j := 1 to 8 do - if buf[loc+j] <> ' ' then - begin - fname[j] := buf[loc+j]; - fname[0] := chr(j); - end; - for j := 9 to 11 do - if buf[loc+j] <> ' ' then - begin - extn[j-8] := buf[loc+j]; - extn[0] := chr(j-8); - end; - END; - -PROCEDURE putfname; {insert file name into output buffer} - VAR {insertion sort algorithm} - pos, i : INTEGER; - BEGIN - if (howsort = NOSORT) or (nfiles = 0) then {don't sort} - pos := nfiles - else if howsort = BYFILE then {insert by file name} - begin - pos := 0; - while fname > store[pos].name do {start of this name} - pos := pos + 1; - while (fname = store[pos].name) - and (extn > store[pos].ext) do {ext within file name} - pos := pos + 1; - end - else if howsort = BYEXTN then {insert by extension} - begin - pos := 0; - while extn > store[pos].ext do {start of this extention} - pos := pos + 1; - while (extn = store[pos].ext) - and (fname > store[pos].name) do {file name within ext} - pos := pos + 1; - end; - for i := nfiles downto pos do {make space for new entry} - store[i+1] := store[i]; - store[pos].name := fname; - store[pos].ext := extn; - nfiles := nfiles + 1; - END; - -{main entry point} - -BEGIN - fcb[0] := chr(0); {initialize file control block} - for i := 1 to 11 do - fcb[i] := '?'; - for i := 12 to 35 do - fcb[i] := chr(0); - - sentinel.name := '~~~~~~~~'; {sentinel to terminate search} - sentinel.ext := '~~~'; - store[0] := sentinel; - - repeat {ask for sorting method} - writeln; - write ('SORT: No sort, by Extension, by Filename (N, E, F)? '); - readln(optn); - if optn > 'a' then {convert to uppercase} - optn := chr(ord(optn) - ord(' ')); - until optn in ['N', 'E', 'F']; - case optn of - 'N' : howsort := NOSORT; - 'E' : howsort := BYEXTN; - 'F' : howsort := BYFILE; - end; - - nfiles := 0; {number of file names} - i := @bdos(SETDMA, addr(buf)); {set dma address} - loc := 32 * @bdos(SRCHF, addr(fcb)); {get first file name} - while loc <= 32*3 do {sort all names into store[]} - begin - getfname; - putfname; - loc := 32 * @bdos(SRCHN, addr(fcb)); {get next file name} - end; - - writeln; - write ('Leader? '); {example: B:=A: } - readln(leader); - write ('Trailer? '); {example: [V] } - readln(trailer); - -{write out results} - - repeat - write ('Output file name? '); - readln(fname); - until cpmname(fname); - assign (fileout, fname); - rewrite(fileout); - for i := 0 to nfiles-1 do - begin - if length(store[i].ext) > 0 then - fname := concat(store[i].name, '.', store[i].ext) - else - fname := store[i].name; - writeln(fileout, leader, fname, trailer) - end; - close(fileout, i); - writeln(nfiles, ' file names written'); - -END. - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/DIRFILE.SUB b/software/CPM/CPM16_MTPUG_04/DIRFILE.SUB deleted file mode 100644 index a4dbf2c..0000000 --- a/software/CPM/CPM16_MTPUG_04/DIRFILE.SUB +++ /dev/null @@ -1,4 +0,0 @@ -MTPLUS B:DIFRILE $$TB RB -MTPLUS B:CPMNAME $$TB RB -LINKMT B:DIFRILE,B:CPMNAME,PASLIB/S - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/HEXDMP.COM b/software/CPM/CPM16_MTPUG_04/HEXDMP.COM deleted file mode 100644 index 58163c1..0000000 Binary files a/software/CPM/CPM16_MTPUG_04/HEXDMP.COM and /dev/null differ diff --git a/software/CPM/CPM16_MTPUG_04/HEXDMP.DOC b/software/CPM/CPM16_MTPUG_04/HEXDMP.DOC deleted file mode 100644 index 0b90cdc..0000000 --- a/software/CPM/CPM16_MTPUG_04/HEXDMP.DOC +++ /dev/null @@ -1,5 +0,0 @@ -HEXDMP requests the name of the file to be dumped. It may -be on any drive. This program dumps every sector in -hex to a file HEXDMP.DAT. Type or print to discover -the problem with your files data. - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/HEXDMP.ERL b/software/CPM/CPM16_MTPUG_04/HEXDMP.ERL deleted file mode 100644 index 2ecab79..0000000 Binary files a/software/CPM/CPM16_MTPUG_04/HEXDMP.ERL and /dev/null differ diff --git a/software/CPM/CPM16_MTPUG_04/HEXDMP.SRC b/software/CPM/CPM16_MTPUG_04/HEXDMP.SRC deleted file mode 100644 index 69b82e5..0000000 --- a/software/CPM/CPM16_MTPUG_04/HEXDMP.SRC +++ /dev/null @@ -1,48 +0,0 @@ -program hexdmp; - -type - buffer = array[1..128] of char; - -var - name : string; - i,j,k,result : integer; - infil : file of buffer; - inbuf : buffer; - outfil : text; - -begin - writeln('enter name of file'); - readln(name); - - assign(infil,name); - reset(infil); - assign(outfil,'HEXDMP.DAT'); - rewrite(outfil); - - result := 0; - j:=0; - while result <> 1 do - begin - seekread(infil,j); - result := ioresult; - if result = 0 then begin - inbuf := infil^; - for i:=1 to 32 do - writehex(outfil,inbuf[i],1); - writeln(outfil); - for i:=33 to 64 do - writehex(outfil,inbuf[i],1); - writeln(outfil); - for i:=65 to 96 do - writehex(outfil,inbuf[i],1); - writeln(outfil); - for i:=97 to 128 do - writehex(outfil,inbuf[i],1); - writeln(outfil); - j:=j+1; - end; - end; - close(outfil,i); -writeln('all done') -end. - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/HL.CMD b/software/CPM/CPM16_MTPUG_04/HL.CMD deleted file mode 100644 index 129e2cd..0000000 --- a/software/CPM/CPM16_MTPUG_04/HL.CMD +++ /dev/null @@ -1,3 +0,0 @@ -hl,hl1,hl2,a:fpreals/s,a:paslib/s/d:9000 - -P \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/HL.SRC b/software/CPM/CPM16_MTPUG_04/HL.SRC deleted file mode 100644 index 5fdaba7..0000000 --- a/software/CPM/CPM16_MTPUG_04/HL.SRC +++ /dev/null @@ -1,131 +0,0 @@ -(* VERSION 0009 *) - - -(*.......................................................................*) -(* HIDELINE *) -(* Hideline is a three-dimensional graphics program. The program *) -(* was written by Franklin C Crow and published as 'Three-Dimensional *) -(* Computer Graphics', BYTE, March/April 1981. The program was adapted *) -(* to run with a MicroAngelo graphics terminal by Ray Hopkins, 8 *) -(* Chestnut Hill CT., Cinnaminson N.J. (609) 829-4686. *) -(* Hl3.src builds the data files used by hl.src,the main display routine *) -(* Hl1.src and Hl2 are support modules. Note that Hl1.src must have *) -(* recursion turned on. Hl.cmd is the linker command file *) -(*.......................................................................*) - -(*Z*) -{$K1} -{$K2} -{$K3} -{$K5} -{$K6} -{$K7} -{$K12} -{$K13} -{$K14} -{$K15} - -PROGRAM HIDELINE; - -CONST Dotsacross = 511; - Dotsdown = 479; - Maxpts = 200; - Maxpols = 200; - Maxvtx = 800; - Maxsides =14; - -TYPE Counter = 0..Maxvtx; - Point = RECORD - X,Y,Z : REAL - END; - Vertex = 0..Maxpts; - Polygon = RECORD - Numvtx : Vertex; - START : Counter; - END; - Onepoly = ARRAY [1..Maxsides] OF Point; - Matrix = ARRAY [1..4,1..4] OF REAL; - -VAR Polygons : ARRAY [1..Maxpols] OF Polygon; - Vertices : ARRAY [1..Maxvtx] OF Vertex; - Points : ARRAY [1..Maxpts] OF Point; - Outpolys : ARRAY [1..Maxpols] OF Polygon; - Outvtces : ARRAY [1..Maxvtx] OF Point; - Eyespace : Matrix; - Window : Onepoly; - Eyept , Cntrint : Point; - Screenscale, Screenctr : Point; - ScreenX, SCREENY : REAL; - Numpols, Numvtces, Windowsize, I : Counter; - Numpts : Counter; - NUMDISPLAY, NumvtxOUT : Counter; - CMDCHAR : CHAR; - Filename : STRING; - DONE : BOOLEAN; - -external procedure @I95; - -EXTERNAL PROCEDURE OUTP(B:BYTE); - -EXTERNAL PROCEDURE MICRO2(COMMAND:BYTE;X,Y:INTEGER); - -EXTERNAL PROCEDURE GETPLANES(VAR Poly:Onepoly; Numpts:Counter); - -EXTERNAL PROCEDURE GETScreenscale; - -EXTERNAL PROCEDURE INITIALIZE; - -EXTERNAL PROCEDURE START; - -EXTERNAL PROCEDURE READOBJECT(Filename:STRING); - -EXTERNAL PROCEDURE MAKEPICTURE; - -BEGIN {MAIN} -{ @I95;} - INITIALIZE; - WHILE NOT DONE DO - BEGIN - WRITE('R)ead obj, E)yepoint, C)enter, S)tart, W)indow, Q)uit ? '); - READLN(CMDCHAR); - CASE CMDCHAR OF - 'R','r': BEGIN - WRITE('Enter name of object file ?'); - READLN(Filename); - READOBJECT(Filename); - END; - 'E','e': BEGIN - WRITE('Enter eyepoint, X,Y,Z ?'); - WITH Eyept DO - READLN(X,Y,Z); - END; - 'C','c': BEGIN - WRITE('Enter center of interest X,Y,Z ?'); - WITH Cntrint DO - READLN(X,Y,Z); - END; - 'S','s': BEGIN - Numpols := 0; - Numpts := 0; - END; - 'W','w': BEGIN - WRITE('Set display window : How many sides ?'); - READLN(Windowsize); - FOR I:=1 TO Windowsize DO - BEGIN - WRITE('Side number ',I,' X,Y,Z ?'); - WITH Window[I] DO - READLN(X,Y,Z); - END; - GETScreenscale; - GETPLANES(Window,Windowsize); - END; - 'P','p': MAKEPICTURE; - 'Q','q': DONE := TRUE; - END; - END; -outp($B8); -outp($28); -END. {MAIN} - - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/HL1.SRC b/software/CPM/CPM16_MTPUG_04/HL1.SRC deleted file mode 100644 index cf45b7a..0000000 --- a/software/CPM/CPM16_MTPUG_04/HL1.SRC +++ /dev/null @@ -1,464 +0,0 @@ -(* VERSION 0028 *) - - -(*.......................................................................*) -(* HIDELINE *) -(* Hideline is a three-dimensional graphics program. The program *) -(* was written by Franklin C Crow and published as 'Three-Dimensional *) -(* Computer Graphics', BYTE, March/April 1981. The program was adapted *) -(* to run with a MicroAngelo graphics terminal by Ray Hopkins, 8 *) -(* Chestnut Hill CT., Cinnaminson N.J. (609) 829-4686. *) -(* Hl3.src builds the data files used by hl.src,the main display routine *) -(* Hl1.src and Hl2 are support modules. Note that Hl1.src must have *) -(* recursion turned on. Hl.cmd is the linker command file *) -(*.......................................................................*) - -(*Z*) -(*$S+*) -{$K1} -{$K2} -{$K6} -{$K7} -{$K12} -{$K13} -{$K14} -{$K15} -MODULE HIDELINE1; - -CONST Dotsacross = 511; - Dotsdown = 479; - Maxpts = 200; - Maxpols = 200; - Maxvtx = 800; - Maxsides =14; - Move = $84; - Plot = $91; - Split = $B8; - Clear = $88; - -TYPE Counter = 0..Maxvtx; - Point = RECORD - X,Y,Z : REAL - END; - Vertex = 0..Maxpts; - Polygon = RECORD - Numvtx : Vertex; - START : Counter; - END; - Onepoly = ARRAY [1..Maxsides] OF Point; - Matrix = ARRAY [1..4,1..4] OF REAL; - -VAR Polygons : EXTERNAL ARRAY [1..Maxpols] OF Polygon; - Vertices : EXTERNAL ARRAY [1..Maxvtx] OF Vertex; - Points : EXTERNAL ARRAY [1..Maxpts] OF Point; - Outpolys : EXTERNAL ARRAY [1..Maxpols] OF Polygon; - Outvtces : EXTERNAL ARRAY [1..Maxvtx] OF Point; - Eyespace : EXTERNAL Matrix; - Window : EXTERNAL Onepoly; - Eyept , Cntrint : EXTERNAL Point; - Screenscale, Screenctr : EXTERNAL Point; - ScreenX, SCREENY : EXTERNAL REAL; - Numpols, Numvtces, Windowsize, I : EXTERNAL Counter; - Numpts : EXTERNAL Counter; - NUMDISPLAY, NumvtxOUT : EXTERNAL Counter; - CMDCHAR : EXTERNAL CHAR; - Filename : EXTERNAL STRING; - DONE : EXTERNAL BOOLEAN; - - - EXTERNAL PROCEDURE GETPLANES(VAR Poly:Onepoly; Numpts:Counter); - - EXTERNAL PROCEDURE micro2(mode:byte;x,y:real); - - EXTERNAL PROCEDURE START; - -PROCEDURE MAKEPICTURE; - -VAR I,J,NUMCLP: Counter; - Tmpoly : Onepoly; - - FUNCTION DOTPROD(PT1,PT2:Point): REAL; - -BEGIN {dotprod} - DOTPROD := PT1.X*PT2.X+PT1.Y*PT2.Y+PT1.Z*PT2.Z; -END; {dotprod} - -PROCEDURE IDENT(VAR MTX:Matrix); - -VAR I,J: Counter; - -BEGIN {ident} - FOR I:=1 TO 4 DO - BEGIN - FOR J:=1 TO 4 DO - BEGIN - IF I=J THEN - MTX[I,J] := 1 - ELSE - MTX[I,J] := 0; - END; - END; -END; {ident} - -PROCEDURE MatrixMULT(MT1,MT2:Matrix; VAR RESULT: Matrix); - -VAR I,J,K: Counter; - -BEGIN {matrixmult} - FOR I:=1 TO 4 DO - BEGIN - FOR J:=1 TO 4 DO - BEGIN - RESULT[I,J] := 0; - FOR K:=1 TO 4 DO - BEGIN - RESULT[I,J] := RESULT[I,J]+MT1[K,J]*MT2[I,K]; - END; - END; - END; -END; {matrxmult} - -PROCEDURE TRANSFORM(PT:Point; MTX:Matrix; VAR NEWPT:Point); - -BEGIN - NEWPT.X := PT.X*MTX[1,1]+PT.Y*MTX[1,2]+PT.Z*MTX[1,3]+MTX[1,4]; - NEWPT.Y := PT.X*MTX[2,1]+PT.Y*MTX[2,2]+PT.Z*MTX[2,3]+MTX[2,4]; - NEWPT.Z := PT.X*MTX[3,1]+PT.Y*MTX[3,2]+PT.Z*MTX[3,3]+MTX[3,4]; -END; - -PROCEDURE GETEyespace(Eyept,Cntrint:Point); - -VAR MTX: Matrix; - C1,C2: Point; - HYPOTENUSE,COSA,SINA: REAL; - -BEGIN - IDENT(Eyespace); - WITH Eyept DO - BEGIN - Eyespace[1,4] := -X; - Eyespace[2,4] := -Y; - Eyespace[3,4] := -Z; - END; - TRANSFORM(Cntrint,Eyespace,C1); - IDENT(MTX); - WITH C1 DO - HYPOTENUSE := SQRT(X*X+Y*Y); - IF HYPOTENUSE > 0 THEN - BEGIN - COSA := C1.Y/HYPOTENUSE; - SINA := C1.X/HYPOTENUSE; - MTX[1,1] := COSA; - MTX[2,1] := SINA; - MTX[1,2] := -SINA; - MTX[2,2] := COSA; - MatrixMULT(Eyespace,MTX,Eyespace); - END; - TRANSFORM(Cntrint,Eyespace,C2); - IDENT(MTX); - WITH C2 DO - HYPOTENUSE := SQRT(Y*Y+Z*Z); - IF HYPOTENUSE > 0 THEN - BEGIN - COSA := C2.Y/HYPOTENUSE; - SINA := -C2.Z/HYPOTENUSE; - MTX[2,2] := COSA; - MTX[3,2] := SINA; - MTX[2,3] := -SINA; - MTX[3,3] := COSA; - MatrixMULT(Eyespace,MTX,Eyespace); - END; - IDENT(MTX); - MTX[2,2] := 0; - MTX[3,3] := 0; - MTX[2,3] := 1; - MTX[3,2] := 1; - MatrixMULT(Eyespace,MTX,Eyespace); -END; - -PROCEDURE MAKEDISPLAYABLE(VAR PT:Point); -BEGIN - PT.X := Screenscale.X*PT.X/PT.Z+Screenctr.X; - PT.Y := Screenscale.Y*PT.Y/PT.Z+Screenctr.Y; -END; - -FUNCTION FACESEYE(Poly:Onepoly): BOOLEAN; - -VAR TMPPT: Point; - Tmpoly: Onepoly; - -BEGIN - WITH Poly[2] DO - BEGIN - TMPPT.X := X; - TMPPT.Y := Y; - TMPPT.Z := Z; - END; - Tmpoly[1].X := Poly[1].X-Poly[2].X; - Tmpoly[1].Y := Poly[1].Y-Poly[2].Y; - Tmpoly[1].Z := Poly[1].Z-Poly[2].Z; - Tmpoly[2].X := Poly[3].X-Poly[2].X; - Tmpoly[2].Y := Poly[3].Y-Poly[2].Y; - Tmpoly[2].Z := Poly[3].Z-Poly[2].Z; - GETPLANES(Tmpoly,2); - IF DOTPROD(TMPPT,Tmpoly[1]) <=0 - THEN - FACESEYE := FALSE - ELSE - FACESEYE := TRUE; -END; - -PROCEDURE CLIPIN(VAR Poly:Onepoly; VAR Numpts:Counter); - -VAR I,J,LstJ,TMPPTS: Counter; - D1,D2,A: REAL; - Tmpoly: Onepoly; - -BEGIN - FOR I:=1 TO Windowsize DO - IF Numpts >0 THEN - BEGIN - D1 := DOTPROD(Poly[Numpts],Window[I]); - LstJ := Numpts; - TMPPTS := 0; - FOR J:=1 TO Numpts DO - BEGIN - IF D1 >0 THEN - BEGIN - TMPPTS := TMPPTS+1; - WITH Tmpoly[TMPPTS] DO - BEGIN - X := Poly[LstJ].X; - Y := Poly[LstJ].Y; - Z := Poly[LstJ].Z; - END; - END; - D2 := DOTPROD(Poly[J],Window[I]); - IF D1*D2<0 THEN - BEGIN - A := D1/(D1-D2); - TMPPTS := TMPPTS+1; - WITH Tmpoly[TMPPTS] DO - BEGIN - X := A*Poly[J].X+(1-A)*Poly[LstJ].X; - Y := A*Poly[J].Y+(1-A)*Poly[LstJ].Y; - Z := A*Poly[J].Z+(1-A)*Poly[LstJ].Z; - END; - END; - LstJ := J; - D1 := D2; - END; - FOR J:=1 TO TMPPTS DO - BEGIN - WITH Tmpoly[J] DO - BEGIN - Poly[J].X := X; - Poly[J].Y := Y; - Poly[J].Z := Z; - END; - END; - Numpts := TMPPTS; - END; -END; - -PROCEDURE INSERTSORT(Poly:Onepoly;Numpts:Counter); - -VAR I,J,K: Counter; - AVDEPTH,Nptsr : REAL; -BEGIN - AVDEPTH := 0; - Nptsr := 0; - FOR I:=1 TO Numpts DO - BEGIN - WITH Poly[I] DO - BEGIN - Outvtces[NumvtxOUT+I+1].X := X; - Outvtces[NumvtxOUT+I+1].Y := Y; - Outvtces[NumvtxOUT+I+1].Z := Z; - AVDEPTH := AVDEPTH+ Z; - Nptsr := Nptsr +1; - END; - END; - AVDEPTH := AVDEPTH /Nptsr; - Outvtces[NumvtxOUT+1].Z := AVDEPTH; - J := 0; - I := (NUMDISPLAY+1) DIV 2; - K := NUMDISPLAY; - WHILE (J<>I) DO - IF AVDEPTH0 THEN - INSERTSORT(Tmpoly,NUMCLP); - END; - END; - START; - FOR I:=1 TO NUMDISPLAY DO - WITH Outpolys[I] DO - BEGIN - FOR J:=1 TO Numvtx DO - WITH Outvtces[START+J] DO - BEGIN - Tmpoly[J].X := X; - Tmpoly[J].Y := Y; - Tmpoly[J].Z := Z; - END; - CLIPOUT(Tmpoly,Numvtx,I); - IF Numvtx>0 THEN - BEGIN - GETPLANES(Tmpoly,Numvtx); - FOR J:=1 TO Numvtx DO - WITH Outvtces[START+J] DO - BEGIN - X := Tmpoly[J].X; - Y := Tmpoly[J].Y; - Z := Tmpoly[J].Z; - END; - END; - END; -END; {MAKEPICTURE} -MODEND. -; \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/HL2.SRC b/software/CPM/CPM16_MTPUG_04/HL2.SRC deleted file mode 100644 index b65d65a..0000000 --- a/software/CPM/CPM16_MTPUG_04/HL2.SRC +++ /dev/null @@ -1,270 +0,0 @@ -(* VERSION 0024 *) - -(*.......................................................................*) -(* HIDELINE *) -(* Hideline is a three-dimensional graphics program. The program *) -(* was written by Franklin C Crow and published as 'Three-Dimensional *) -(* Computer Graphics', BYTE, March/April 1981. The program was adapted *) -(* to run with a MicroAngelo graphics terminal by Ray Hopkins, 8 *) -(* Chestnut Hill CT., Cinnaminson N.J. (609) 829-4686. *) -(* Hl3.src builds the data files used by hl.src,the main display routine *) -(* Hl1.src and Hl2 are support modules. Note that Hl1.src must have *) -(* recursion turned on. Hl.cmd is the linker command file *) -(*.......................................................................*) - -(*Z*) -{$K1} -{$K2} -{$K3} -{$K6} -{$K7} -{$K12} -{$K13} -{$K14} -{$K15} - -MODULE HIDELINE2; - -CONST Dotsacross = 511; - Dotsdown = 479; - Maxpts = 200; - Maxpols = 200; - Maxvtx = 800; - Maxsides =14; - Move = $84; - Plot = $91; - Split = $B8; - Clear = $88; - -TYPE Counter = 0..Maxvtx; - Point = RECORD - X,Y,Z : REAL - END; - Vertex = 0..Maxpts; - Polygon = RECORD - Numvtx : Vertex; - START : Counter; - END; - Onepoly = ARRAY [1..Maxsides] OF Point; - Matrix = ARRAY [1..4,1..4] OF REAL; - -VAR Polygons : EXTERNAL ARRAY [1..Maxpols] OF Polygon; - Vertices : EXTERNAL ARRAY [1..Maxvtx] OF Vertex; - Points : EXTERNAL ARRAY [1..Maxpts] OF Point; - Outpolys : EXTERNAL ARRAY [1..Maxpols] OF Polygon; - Outvtces : EXTERNAL ARRAY [1..Maxvtx] OF Point; - Eyespace : EXTERNAL Matrix; - Window : EXTERNAL Onepoly; - Eyept , Cntrint : EXTERNAL Point; - Screenscale, Screenctr : EXTERNAL Point; - ScreenX, SCREENY : EXTERNAL REAL; - Numpols, Numvtces, Windowsize, I : EXTERNAL Counter; - Numpts : EXTERNAL Counter; - Nptsr : EXTERNAL REAL; - NUMDISPLAY, NumvtxOUT : EXTERNAL Counter; - CMDCHAR : EXTERNAL CHAR; - Filename : EXTERNAL STRING; - DONE : EXTERNAL BOOLEAN; - - -procedure outp(B:byte); - -begin - inline("IN/$E1/ - "ANI/1/ - "JNZ/*-4); - out[$E0]:=B; -end; - -procedure micro2(mode:byte;X,Y:real); - -var MX,MY:integer; - -begin -MX:=trunc(X); -MY:=trunc(Y); -outp(mode); -outp(HI(MX)); -outp(LO(MX)); -outp(HI(MY)); -outp(LO(MY)); -end; - -PROCEDURE GETPLANES(VAR Poly:Onepoly; Numpts:Counter); - -VAR I,LstI : Counter; - Tmpoly : Onepoly; - -BEGIN - LstI := Numpts; - FOR I:=1 TO Numpts DO - BEGIN - WITH Poly[I] DO - BEGIN - Tmpoly[I].X := Y*Poly[LstI].Z-Z*Poly[LstI].Y; - Tmpoly[I].Y := Z*Poly[LstI].X-X*Poly[LstI].Z; - Tmpoly[I].Z := X*Poly[LstI].Y-Y*Poly[LstI].X; - END; - LstI := I; - END; - FOR I:=1 TO Numpts DO - BEGIN - WITH Tmpoly[I] DO - BEGIN - Poly[I].X := X; - Poly[I].Y := Y; - Poly[I].Z := Z; - END; - END; -END; - -PROCEDURE GETScreenscale; - -VAR I : Counter; - MAXX,MAXY,MINX,MINY : REAL; - -BEGIN - MAXX := 0.0; - MAXY := 0.0; - MINX := 0.0; - MINY := 0.0; - FOR I:=1 TO Windowsize DO - BEGIN - WITH Window[I] DO - BEGIN - IF X/Z > MAXX THEN - MAXX := X/Z; - IF X/Z < MINX THEN - MINX := X/Z; - IF Y/Z > MAXY THEN - MAXY := Y/Z; - IF Y/Z < MINY THEN - MINY := Y/Z; - END; - END; - MAXX := MAXX-MINX; - MAXY := MAXY-MINY; - IF MAXY > (0.75*MAXX) - THEN - Screenscale.Z := MAXY*(4/3) - ELSE - Screenscale.Z := MAXX; - Screenscale.X := Dotsacross/Screenscale.Z; - Screenscale.Y := (Dotsdown*4/3)/Screenscale.Z -END; - -PROCEDURE INITIALIZE; - -BEGIN - DONE := FALSE; - Numpols := 0; - NUMDISPLAY := 0; - Numvtces := 0; - Numpts := 0; - WITH Eyept DO - BEGIN - X := -5; - Y := -5; - Z := 3; - END; - WITH Cntrint DO - BEGIN - X := 0; - Y := 0; --Ðp`ppv~:= 0; - END; - Windowsize := 4; - WITH Window[1] DO - BEGIN - X := -4; - Y := -3; - Z := 16; - END; - WITH Window[2] DO - BEGIN - X := -4; - Y := 3; - Z := 16; - END; - WITH Window[3] DO - BEGIN - X := 4; - Y := 3; - Z := 16; - END; - WITH Window[4] DO - BEGIN - X := 4; - Y := -3; - Z := 16; - END; - GETScreenscale; - GETPLANES(Window,Windowsize); - WITH SCREENCTR DO - BEGIN - X := Dotsacross/2; - Y := Dotsdown/2; - END; - OUTP(Clear); - OUTP(Split); - OUTP($01); -END; - -PROCEDURE START; - -VAR I,J : Counter; - -BEGIN - OUTP(Clear); -END; - - -PROCEDURE READOBJECT(Filename:STRING); - -VAR PTSOBJ,POLSOBJ,PTSPOL,I,J: Counter; - XPOS,YPOS,ZPOS: REAL; - OBJFILE: TEXT; - -BEGIN - WRITE('POSITION FOR ',Filename,' X,Y,Z: '); - READLN(XPOS,YPOS,ZPOS); - ASSIGN(OBJFILE,Filename); - RESET(OBJFILE); - IF IORESULT = 255 THEN - BEGIN - WRITELN(Filename,' not found'); - EXIT; - END; - READLN(OBJFILE,PTSOBJ,POLSOBJ); - FOR I:=1 TO PTSOBJ DO - BEGIN - WITH Points[I+Numpts] DO - BEGIN - READLN(OBJFILE,J,X,Y,Z); - X := X+XPOS; - Y := Y+YPOS; - Z := Z+ZPOS; - END; - END; - FOR I:=1 TO POLSOBJ DO - BEGIN - READ(OBJFILE,PTSPOL); - FOR J:=1 TO PTSPOL DO - BEGIN - READ(OBJFILE,Vertices[J+Numvtces]); - Vertices[J+Numvtces] := Vertices[J+Numvtces]+Numpts; - END; - WITH Polygons[I+Numpols] DO - BEGIN - START := Numvtces; - Numvtx := PTSPOL; - END; - Numvtces := Numvtces+PTSPOL; - END; - Numpts := Numpts+PTSOBJ; - Numpols := Numpols+POLSOBJ; -END; - -MODEND. - -D \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/HL3.SRC b/software/CPM/CPM16_MTPUG_04/HL3.SRC deleted file mode 100644 index c5e48d0..0000000 --- a/software/CPM/CPM16_MTPUG_04/HL3.SRC +++ /dev/null @@ -1,259 +0,0 @@ -(* VERSION 0016 *) - -(*.......................................................................*) -(* HIDELINE *) -(* Hideline is a three-dimensional graphics program. The program *) -(* was written by Franklin C Crow and published as 'Three-Dimensional *) -(* Computer Graphics', BYTE, March/April 1981. The program was adapted *) -(* to run with a MicroAngelo graphics terminal by Ray Hopkins, 8 *) -(* Chestnut Hill CT., Cinnaminson N.J. (609) 829-4686. *) -(* Hl3.src builds the data files used by hl.src,the main display routine *) -(* Hl1.src and Hl2 are support modules. Note that Hl1.src must have *) -(* recursion turned on. Hl.cmd is the linker command file *) -(*.......................................................................*) - -(*Z*) -{$K1} -{$K2} -{$K6} -{$K7} -{$K12} -{$K13} -{$K14} -{$K15} - -PROGRAM HIDELINE; - -CONST Dotsacross = 511; - Dotsdown = 479; - Maxpts = 200; - Maxpols = 200; - Maxvtx = 800; - Maxsides = 8; - -TYPE Counter = 0..Maxvtx; - Point = RECORD - X,Y,Z : REAL - END; - Vertex = 0..Maxpts; - Polygon = RECORD - Numvtx : Vertex; - START : Counter; - END; - Onepoly = ARRAY [1..Maxsides] OF Point; - Matrix = ARRAY [1..4,1..4] OF REAL; - CHFILE = FILE OF CHAR; - -VAR Polygons : ARRAY [1..Maxpols] OF Polygon; - Vertices : ARRAY [1..Maxvtx] OF Vertex; - Points : ARRAY [1..Maxpts] OF Point; - Outpolys : ARRAY [1..Maxpols] OF Polygon; - Outvtces : ARRAY [1..Maxvtx] OF Point; - Eyespace : Matrix; - Window : Onepoly; - Eyept , Cntrint : Point; - Screenscale, Screenctr : Point; - ScreenX, SCREENY : REAL; - Numpols, Numvtces, Windowsize, I : Counter; - Numpts : Counter; - Nptsr : REAL; - NUMDISPLAY, NumvtxOUT : Counter; - CMDCHAR : CHAR; - Filename : STRING; - DONE : BOOLEAN; - - - -PROCEDURE INITIALIZE; - -BEGIN - DONE := FALSE; - Numpols := 0; - Numvtces := 0; - Numpts := 0; -END; - -PROCEDURE MODIFY; - -VAR PTSOBJ,POLSOBJ,PTSPOL,I,J: Counter; - -BEGIN - {procedure modify to be built on this space} -END; -PROCEDURE DISPOBJ; - -VAR PTSOBJ,POLSOBJ,PTSPOL,I,J: Counter; - OBJFILE: TEXT; - -BEGIN - PTSOBJ:=Numpts; - POLSOBJ:=Numpols; - WRITELN('Points in object =',PTSOBJ,' Polygons in object =',POLSOBJ); - FOR I:=1 TO PTSOBJ DO - WITH Points[I] DO - BEGIN - WRITELN('Point ',I,X,Y,Z); - END; - FOR I:=1 TO POLSOBJ DO - BEGIN - PTSPOL:=Polygons[I].Numvtx; - WRITE('Points in polygon ',I,' ',PTSPOL,' Points '); - FOR J:=1 TO PTSPOL DO - BEGIN - WRITE(Vertices[J+Polygons[I].Start],' '); - END; - WRITELN; - END; -END; - -PROCEDURE WRTOBJECT(Filename:STRING); - -VAR PTSOBJ,POLSOBJ,PTSPOL,I,J: Counter; - Result : INTEGER; - OBJFILE: TEXT; - -BEGIN - PTSOBJ:=Numpts; - POLSOBJ:=Numpols; - ASSIGN(OBJFILE,Filename); - REWRITE(OBJFILE); - IF IORESULT = 255 THEN - BEGIN - WRITELN('Error in opening ',Filename); - EXIT; - END; - WRITELN(OBJFILE,PTSOBJ,POLSOBJ:5); - FOR I:=1 TO PTSOBJ DO - BEGIN - WITH Points[I] DO - BEGIN - WRITELN(OBJFILE,I,' ',X,' ',Y,' ',Z); - END; - END; - FOR I:=1 TO POLSOBJ DO - BEGIN - PTSPOL:=Polygons[I].Numvtx; - WRITE(OBJFILE,PTSPOL:5,' '); - FOR J:=1 TO PTSPOL DO - BEGIN - WRITE(OBJFILE,Vertices[J+Polygons[I].Start]:5); - END; - END; - CLOSE(OBJFILE,Result); - IF Result = 255 THEN - WRITELN('Error closing ',Filename) - ELSE - BEGIN - WRITELN(Filename,' closed successfully'); - END; -END; -PROCEDURE ENTER; - -VAR PTSOBJ,POLSOBJ,PTSPOL,I,J: Counter; - -BEGIN - WRITELN('Enter object '); - WRITE('Enter points in object ?'); - READLN(PTSOBJ); - WRITE('Enter polygons in object ?'); - READLN(POLSOBJ); -FOR I:=1 TO PTSOBJ DO - BEGIN - WITH Points[I] DO - BEGIN - WRITE('Enter X,Y,Z for point ',I,' '); - READLN(X,Y,Z); - END; - END; - FOR I:=1 TO POLSOBJ DO - BEGIN - WRITE('Enter points in polygon ',I,' '); - READ(PTSPOL); - FOR J:=1 TO PTSPOL DO - BEGIN - WRITE('Enter point ',J,' for polygon ',I,' '); - READ(Vertices[J+Numvtces]); - Vertices[J+Numvtces] := Vertices[J+Numvtces]+Numpts; - END; - WITH Polygons[I+Numpols] DO - BEGIN - START := Numvtces; - Numvtx := PTSPOL; - END; - Numvtces := Numvtces+PTSPOL; - END; - Numpts := Numpts+PTSOBJ; - Numpols := Numpols+POLSOBJ; -END; - -PROCEDURE READOBJECT(Filename:STRING); - -VAR PTSOBJ,POLSOBJ,PTSPOL,I,J: Counter; - XPOS,YPOS,ZPOS: REAL; - OBJFILE: TEXT; - -BEGIN - WRITE('POSITION FOR ',Filename,' X,Y,Z: '); - READLN(XPOS,YPOS,ZPOS); - ASSIGN(OBJFILE,Filename); - RESET(OBJFILE); - READLN(OBJFILE,PTSOBJ,POLSOBJ); - FOR I:=1 TO PTSOBJ DO - BEGIN - WITH Points[I+Numpts] DO - BEGIN - READLN(OBJFILE,J,X,Y,Z); - X := X+XPOS; - Y := Y+YPOS; - Z := Z+ZPOS; - END; - END; - FOR I:=1 TO POLSOBJ DO - BEGIN - READ(OBJFILE,PTSPOL); - FOR J:=1 TO PTSPOL DO - BEGIN - READ(OBJFILE,Vertices[J+Numvtces]); - Vertices[J+Numvtces] := Vertices[J+Numvtces]+Numpts; - END; - WITH Polygons[I+Numpols] DO - BEGIN - START := Numvtces; - Numvtx := PTSPOL; - END; - Numvtces := Numvtces+PTSPOL; - END; - Numpts := Numpts+PTSOBJ; - Numpols := Numpols+POLSOBJ; -END; - -BEGIN - INITIALIZE; - WHILE NOT DONE DO - BEGIN - WRITE('R)ead, D)isp, M)odify, E)nter, S)ave, Q)uit ? '); - READLN(CMDCHAR); - CASE CMDCHAR OF - 'R','r': BEGIN - WRITE('FILE NAME ?'); - READLN(Filename); - READOBJECT(Filename); - END; - 'M','m': BEGIN - Modify; - END; - 'E','e': BEGIN - ENTER; - END; - 'D','d':DISPOBJ; - 'S','s': BEGIN - WRITE('FILE NAME ?'); - READLN(Filename); - WRTOBJECT(Filename); - END; - 'Q','q': DONE := TRUE; - END; - END; -END. - -c \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/INDEXER.DOC b/software/CPM/CPM16_MTPUG_04/INDEXER.DOC deleted file mode 100644 index feebd54..0000000 --- a/software/CPM/CPM16_MTPUG_04/INDEXER.DOC +++ /dev/null @@ -1,15 +0,0 @@ -Indexer inputs a Pascal source file and outputs one of -two forms of index file. - -The first is the short form: Only the procedure and -function declarations are extracted from the source. - -The second is the long form: All global declarations, and -everything between the keyword 'procedure' or 'function' -and the keyword 'begin' is extracted. - -Invoke indexer with the following command line: - -INDEXER [SHORT | LONG] - -Short form is assumed unless LONG is specified. \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/INDEXER.SRC b/software/CPM/CPM16_MTPUG_04/INDEXER.SRC deleted file mode 100644 index a6e4aa1..0000000 --- a/software/CPM/CPM16_MTPUG_04/INDEXER.SRC +++ /dev/null @@ -1,300 +0,0 @@ -PROGRAM INDEXIT; -{-------------------------------------------------------} -{Purpose : Find procedure and function declarations and} -{ output them in alphabetical order to a file } -{Inputs : File to be indexed. } -{Outputs : File of procedures and functions } -{CREATED : Jan 31, 1981 NJL } -{MODIFIED : Jul 26, 1982 Steve Clamage } -{ Recognizes lower case, and outputs declar- } -{ ations extending over more than one line. } -{NOTE : Keywords must be all upper or all lower case} -{-------------------------------------------------------} - -TYPE - LSTRINGP = ^LSTRING; - FILENAME = STRING; - RWFILE = (RESETT,REWRITTE); - SUM_TYPE = (SHORT,LONG); - LSTRING = STRING[132]; - SSTRING = STRING[10]; - -VAR - FIN : TEXT; - FOUT : TEXT; - NAME : FILENAME; - STR : LSTRING; - STRP : LSTRINGP; - I : INTEGER; - LINES : INTEGER; - PROGFLG : BOOLEAN; - SUMMARY : SUM_TYPE; - LOC : INTEGER; - -EXTERNAL FUNCTION @BDOS(FUNC, PARM: INTEGER): INTEGER; -EXTERNAL FUNCTION @CMD: LSTRINGP; -EXTERNAL PROCEDURE @HLT; - - -FUNCTION KEYPRESSED: BOOLEAN; -BEGIN - KEYPRESSED := (@BDOS(11,0) <> 0) -END; - - -PROCEDURE ABORT; -BEGIN - WRITELN; - WRITELN('Pascal/MT+ Program Index utility aborted from console'); - @HLT -END; - - -FUNCTION DOFILE(VAR F: TEXT; RW: RWFILE; NAME: FILENAME): BOOLEAN; -{---------------------------------------------------------------} -{ Purpose: Attempt to reset or rewrite the given file. Check } -{ IORESULT. } -{ Inputs: File, whether to reset or rewrite, and name of file. } -{ Outputs: File open for reading or writing. True if successful,} -{ false if not successful. } -{ Last Mod: } -{---------------------------------------------------------------} -BEGIN - ASSIGN(F,NAME); - IF RW = RESETT THEN - RESET(F) - ELSE - REWRITE(F); - IF IORESULT = 255 THEN - DOFILE := FALSE - ELSE - DOFILE := TRUE; -END; - -PROCEDURE GETNAME(VAR OUTSTR : FILENAME); -{---------------------------------------------------------------} -{ Purpose: Read a name from the keyboard, return in STR. } -{ Inputs: CPMCMDBUF. } -{ Outputs: STR contains name of file if it was given to start. } -{ Last Mod: 11/23/80 } -{---------------------------------------------------------------} -BEGIN - WHILE (LENGTH(STR) <> 0) AND (STR[1] = ' ') DO - DELETE(STR,1,1); (* DELETE LEADING BLANKS *) - OUTSTR := ''; - WHILE (LENGTH(STR) <> 0) AND (STR[1] <> ' ') DO - BEGIN - OUTSTR := CONCAT(OUTSTR,STR[1]); - DELETE(STR,1,1) - END; -END; - - -FUNCTION STRIPBLNKS(S: LSTRING):INTEGER; -VAR - I : INTEGER; -BEGIN - STRIPBLNKS := 0; - I := 1; - WHILE (S[I] = ' ') AND (I <= LENGTH(S)) DO - I := I + 1; - IF I <= LENGTH(S) THEN - STRIPBLNKS := I; -END; - -FUNCTION PRESENT(KEYWORD: SSTRING; STR: LSTRING): BOOLEAN; -{---------------------------------------------------------------} -{ Purpose: Return true if the string KEYWORD } -{ the first string on the input line STR. If it is } -{ not first or is not present return false. } -{ Inputs: KEYWORD,STR. } -{ Outputs: Function return value of true or false. } -{ Last Mod: 26 July 82, accept lowercase } -{---------------------------------------------------------------} - PROCEDURE LOWER(VAR STR: SSTRING); - VAR - I: INTEGER; - BEGIN {convert uppercase alphabetic string to lowercase} - FOR I:=1 TO LENGTH(STR) DO - STR[I] := CHR( ORD(STR[I]) + (ORD('a') - ORD('A')) ) - END; - -BEGIN - PRESENT := FALSE; - LOC := STRIPBLNKS(STR); (* LOCATION OF KEYWORD *) - IF LOC <> 0 THEN - IF POS(KEYWORD,STR) = LOC THEN - PRESENT := TRUE - ELSE - BEGIN - LOWER(KEYWORD); (* NOTE: ALL UPPER OR ALL LOWERCASE ONLY! *) - IF POS(KEYWORD,STR) = LOC THEN - PRESENT := TRUE; - END -END; - - -PROCEDURE PROGRESS; -{ Mark progress every 16 lines on the screen } -BEGIN - LINES := LINES + 1; - IF (LINES & $0F) = 0 THEN WRITE('.') -END; - - -PROCEDURE BALPAR(STR: LSTRING); -{Copy procedure header through any balanced parens, } -{ including succeeding lines as necessary. } -VAR - I : INTEGER; - LEVEL: BYTE; - CH: CHAR; - - FUNCTION NEXTCHAR: CHAR; - {Return next char from string, get new line if needed} - BEGIN - I := I + 1; - IF I > LENGTH(STR) THEN - BEGIN - READLN(FIN,STR); - WRITELN(FOUT,STR); - PROGRESS; - I := 1 - END; - NEXTCHAR := STR[I] - END; - -BEGIN {BALPAR} - I := LOC; (* START AT KEYWORD *) - REPEAT - CH := NEXTCHAR; - UNTIL (CH = '(') OR (CH = ';'); - IF CH = '(' THEN (* NEED TO BALANCE OUT PARENS *) - BEGIN - LEVEL := 1; (* NESTING DEPTH *) - REPEAT - CH := NEXTCHAR; - CASE CH OF - '(' : LEVEL := LEVEL + 1; - ')' : LEVEL := LEVEL - 1; - END - UNTIL ((LEVEL = 0) AND (CH = ';')) OR EOF(FIN) - END -END; - - -PROCEDURE TRANSFER(VAR STR : LSTRING); -{---------------------------------------------------------------} -{ Purpose: Transfer lines from FIN to FOUT until the next proc/ } -{ func or begin is encountered. } -{ Inputs: STR contains the line with the PROC, FUNC or PROG def} -{ FIN provides the text. } -{ Outputs: STR contains the line containing a PROC, FUNC def or } -{ a begin. FOUT contains new text. } -{ Last Mod: 26 July 1982 -{---------------------------------------------------------------} -VAR - DONE : BOOLEAN; - TSTRING : LSTRING; - -BEGIN - DONE := FALSE; - WRITELN(FOUT,STR); - IF SUMMARY = LONG THEN - REPEAT - READLN(FIN,TSTRING); - PROGRESS; - IF KEYPRESSED THEN - ABORT; - IF (PRESENT('BEGIN',TSTRING)) THEN - DONE := TRUE - ELSE - BEGIN - IF PRESENT('FUNCTION',TSTRING) - OR PRESENT('PROCEDURE',TSTRING) THEN - BEGIN - WRITELN(FOUT); - WRITELN(FOUT); - END; - WRITELN(FOUT,TSTRING) - END - UNTIL EOF(FIN) OR DONE; - - IF SUMMARY = SHORT THEN - BEGIN - BALPAR(STR); (* COPY THRU BALANCED PARENS, IF ANY *) - READLN(FIN,TSTRING); - PROGRESS; - END; - -(*IF KEYPRESSED THEN - ABORT; *) - STR := TSTRING; - IF SUMMARY = LONG THEN - WRITELN(FOUT); - WRITELN(FOUT); -END; - - -PROCEDURE DOINDEX; -VAR - I : INTEGER; - STR : STRING; -BEGIN - WHILE NOT EOF(FIN) DO - BEGIN - IF PRESENT('PROCEDURE',STR) - OR PRESENT('FUNCTION',STR) THEN - TRANSFER(STR); - READLN(FIN,STR); - PROGRESS; - IF KEYPRESSED THEN - ABORT; - END; -END; - - - - -BEGIN - STRP := @CMD; (* COPY COMMAND TAIL *) - STR := STRP^; - - WRITELN('Pascal/MT+ Program Index Utility -- Release 5.2'); - WRITELN('Copyright (c) 1981 by MT MicroSYSTEMS'); - WRITELN; - - GETNAME(NAME); - WRITELN('Reading text from: ',NAME); - IF DOFILE(FIN,RESETT,NAME) THEN - BEGIN - GETNAME(NAME); - WRITELN('Output directed to: ',NAME); - IF DOFILE(FOUT,REWRITTE,NAME) THEN - BEGIN - GETNAME(NAME); - IF (LENGTH(NAME) > 0) AND (NAME[1] = 'L') THEN - BEGIN - SUMMARY := LONG; - NAME := 'LONG' - END - ELSE - BEGIN - SUMMARY := SHORT; - NAME := 'SHORT' - END; - WRITELN('Summary form: ', NAME); - READLN(FIN,STR); - LINES := 1; - DOINDEX; - CLOSE(FOUT,I); - WRITELN; - WRITELN('Pascal/MT+ Program Index utility processing complete'); - END - ELSE - WRITELN('Cannot create ',NAME) - END - ELSE - WRITELN('Cannot open ',NAME); -END. - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/INDEXER.SUB b/software/CPM/CPM16_MTPUG_04/INDEXER.SUB deleted file mode 100644 index fe07c07..0000000 --- a/software/CPM/CPM16_MTPUG_04/INDEXER.SUB +++ /dev/null @@ -1,3 +0,0 @@ -MTPLUS B:INDEXER $$TB RB -LINKMT B:INDEXER,PASLIB/S - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/LONGLINE.PAS b/software/CPM/CPM16_MTPUG_04/LONGLINE.PAS deleted file mode 100644 index df4306f..0000000 --- a/software/CPM/CPM16_MTPUG_04/LONGLINE.PAS +++ /dev/null @@ -1,55 +0,0 @@ -(***************************************************** -* -* LONGLINE PROGRAM -* -* This program was taken out of the Pascal/Z -* manual, page 56. It is a demo on using Pascal/Z -* STRING functions. -* -* Typed/edited by Charlie Foster, Oct 1980 -* for the Pascal/Z Users Group -*****************************************************) - -PROGRAM longline; - -CONST - linesize = 80; -TYPE - $string0 = string 0; - $string255 = string 255; -VAR - line : STRING linesize; - word : STRING 80; - -FUNCTION length (X : $string255) : INTEGER; EXTERNAL; -FUNCTION index (X, Y : $string255) : INTEGER; EXTERNAL; -PROCEDURE setlength ( VAR X : $string0; Y : INTEGER); EXTERNAL; - -BEGIN - WRITELN (' STRING DEMO'); - WRITELN; - WRITELN ('Type one word at a time and this program', - ' will assemble the words into lines of ', - linesize:1,' words each.'); - WRITELN; - WRITELN ('Type, !"#$ ,to STOP'); - setlength (word, 0); (* initialize word to 0 *) - REPEAT - setlength (line, 0); (* initialize line to 0 *) - WHILE - ( length (line) + length (word) < linesize ) and - ( index (word, '!"#$') = 0 ) DO - BEGIN - APPEND (line, word); - IF length (line) < linesize THEN - APPEND (line, ' '); (* word space word *) - WRITE ('The word is: '); - READLN (word); - END; - WRITELN ('The line is: '); - WRITE (line); - UNTIL index (word, '!"#$') <> 0; - WRITELN; - WRITELN ('I am tired of this, I quit!'); -END. - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/NADY.PAS b/software/CPM/CPM16_MTPUG_04/NADY.PAS deleted file mode 100644 index 47596a2..0000000 --- a/software/CPM/CPM16_MTPUG_04/NADY.PAS +++ /dev/null @@ -1,339 +0,0 @@ -PROGRAM NAD_ENTRY_V4; -{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{+ PROGRAM TITLE: Name and Address Entry +} -{+ version #4 +} -{+ +} -{+ WRITTEN BY: Raymond E. Penley +} -{+ DATE WRITTEN: Sept 25, 1980 +} -{+ +} -{+ WRITTEN FOR: A Name And Address (NAD) data entry +} -{+ program. The output is written +} -{+ specifically in the format that the +} -{+ word processor Magic Wand uses. +} -{+ +} -{+ SUMMARY +} -{+ I. EDITING ENTRIES. +} -{+ The program has a very limited editing capability. +} -{+ Before typing the return key if an entry is not +} -{+ correct then just type the ESCAPE key. This will +} -{+ erase the entire line just entered. You then have to +} -{+ reinput that entry. No other editing is available +} -{+ while in the program. Extensive editing must be +} -{+ done outside the data entry program such as with +} -{+ the word processor. +} -{+ +} -{+ II. TERMINATION. +} -{+ When at the FULL NAME data entry item simply entering +} -{+ a carriage return only will end the session, update +} -{+ and close the output file. +} -{+ +} -{+ III. RECORD FORMAT USED. +} -{+ LINE # +} -{+ 1 RECORD #nn < FILLED IN BY PROGRAM > +} -{+ 2 FULL NAME +} -{+ 3 ADDRESS LINE 1 < USED FOR A ONE LINE ADDRESS > +} -{+ 4 ADDRESS LINE 2 < LEAVE BLANK IF ONLY 1 LINE > +} -{+ 5 CITY +} -{+ 6 STATE < USE POST OFFICE 2 CHAR CODES >+} -{+ 7 ZIP CODE +} -{+ 8 SALUTATION +} -{+ 9 CODES < ANY TYPE OF CODES YOU REQUIRE>+} -{+ 10 BLANK LINE +} -{+ +} -{+ +} -{+ IV. INPUT/OUTPUT FILES +} -{+ INPUT is from a video terminal (must have cursor +} -{+ addressing) +} -{+ OUTPUT FILE is an ASCII text file with file name +} -{+ per your specifications. +} -{+ +} -{+ MODIFICATION RECORD +} -{+ SEPT 24, 80 -ADDED LIMITED EDITING CAPABILITY. +} -{+ ENTERING AN ESCAPE CHAR WILL ALLOW ONE TO +} -{+ REDO THAT LINE OVER AGAIN. +} -{+ NOV 22, 80 -ADDED TELEVIDEO TERMINAL FUNCTIONS. +} -{+ +} -{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -CONST - Default = 80; { Default length of all strings } - FileIdLength = 14; - ESC_CODE = 27; {ASCII Escape code} - NewLine = 13; {ASCII carriage return code} - -TYPE - TermType = (ADM, TVI, SOROC, H19, SOL); - BYTE = 0..255; - dflt_string = string default; - FID = string FileIdLength; - max_string = string 255; - sequence = packed array [1..2] of char; - S$0 = string 0; - S$255 = string 255; - -VAR - bell : char; - clear : char; - current_record: integer; - done : boolean; - esc : char; - filename : FID; - home : char; - Terminal : TermType; - - f1_line,f2_line, - f3_line,f4_line, - f5_line,f6_line, - f7_line,f8_line, - - f1_col,f2_col, - f3_col,f4_col, - f5_col,f6_col, - f7_col,f8_col: BYTE; - - LineDelete, { Delete line that cursor is on } - LineErase, { Erase from cursor to end of line } - HintOn, { Half Intensity On } - HintOff, { Half Intensity Off } - INVON, { Inverse Video On } - INVOFF : sequence; { Inverse Video Off } - - ADDR1, - ADDR2, - CITY, - CODES, - FULLNAME, - SALUTE, - STATE, - ZIP : DFLT_STRING; - - FOUT : TEXT; - -{$C- <<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>} -{$F- <<<<<<<<<<<<<>>>>>>>>>>>>>>>>} -{$M- <<<<<<<<<<<<<>>>>>>>>>>>>>>>>} - -FUNCTION LENGTH(X:S$255):INTEGER;EXTERNAL; - -PROCEDURE SETLENGTH(VAR X:S$0; Y:INTEGER);EXTERNAL; - -PROCEDURE KEYIN(VAR C:CHAR);EXTERNAL; - -PROCEDURE WRITEONE; -BEGIN - WRITELN(FOUT,'RECORD #',CURRENT_RECORD:1); - WRITELN(FOUT,FULLNAME); - WRITELN(FOUT,ADDR1); - IF ( LENGTH(ADDR2)>0 ) THEN - WRITELN(FOUT,ADDR2) - ELSE - WRITELN(FOUT); - WRITELN(FOUT,CITY); - WRITELN(FOUT,STATE); - WRITELN(FOUT,ZIP); - WRITELN(FOUT,SALUTE); - WRITELN(FOUT,CODES); - WRITELN(FOUT); -END; - - -PROCEDURE PLOT(row, column: BYTE); -{ Sequence - ESC + "=" + CHR( LINE+31 ) + CHR( COLUMN+31 ) -} -BEGIN - WRITE(CHR(27), CHR(61), CHR(31+row), CHR(31+column)); -END; - - -PROCEDURE EraseLine(VAR row,column: BYTE); -{ Erase current line from cursor to end of line } -BEGIN - CASE Terminal OF - ADM, SOROC: - BEGIN - PLOT(row,column); - WRITE( ' ':(80-column+1) ); - PLOT(row,column) - END; - - TVI: BEGIN - PLOT(row,column); - WRITE( LineErase ) - END - END {CASE} -END; - - -PROCEDURE CLEAR_ALL; -BEGIN - EraseLine(f1_line,f1_col); - EraseLine(f2_line,f2_col); - EraseLine(f3_line,f3_col); - EraseLine(f4_line,f4_col); - EraseLine(f5_line,f5_col); - EraseLine(f6_line,f6_col); - EraseLine(f7_line,f7_col); - EraseLine(f8_line,f8_col); -END; - -PROCEDURE QUIRY(VAR row, column: BYTE; - VAR ANSWER: DFLT_STRING); -VAR - CIX : CHAR; - DONE, - VALID : BOOLEAN; - -BEGIN - PLOT(row, column); - REPEAT - SETLENGTH(ANSWER,0); - DONE := FALSE; - WHILE NOT ( DONE ) DO - BEGIN - KEYIN(CIX); - VALID := ( ORD(CIX)<>ESC_CODE ); - IF NOT ( VALID ) THEN {REDO FROM START} - BEGIN - DONE := TRUE; - SETLENGTH(ANSWER,0); - EraseLine(row,column); - END - ELSE - IF ( ORD(cix)=NewLine ) THEN - DONE := TRUE - ELSE - BEGIN - WRITE(CIX); - APPEND(ANSWER,CIX); - END; - END {WHILE}; - UNTIL ( VALID ); -END {OF QUIRY}; - - -PROCEDURE FILLONE(VAR DONE: BOOLEAN); -BEGIN - PLOT(2,12);WRITELN( INVON, 'RECORD #', CURRENT_RECORD:1, ' ', INVOFF ); - QUIRY(f1_line,f1_col,FULLNAME); - IF ( LENGTH(FULLNAME) = 0 ) THEN - DONE := TRUE - {EXIT(FILLONE); } - ELSE - BEGIN - DONE := FALSE; - QUIRY(f2_line,f2_col,SALUTE); - QUIRY(f3_line,f3_col,ADDR1); - QUIRY(f4_line,f4_col,ADDR2); - QUIRY(f5_line,f5_col,CITY); - QUIRY(f6_line,f6_col,STATE); - QUIRY(f7_line,f7_col,ZIP); - QUIRY(f8_line,f8_col,CODES) - END -END {OF FILLONE}; - - -PROCEDURE WRITE_MASK; -BEGIN - WRITE( CLEAR, HOME ); - WRITELN; - WRITELN; - WRITELN; - WRITELN; - WRITELN('FULL NAME: .......');WRITELN; - WRITELN('SALUTATION: ......');WRITELN; - WRITELN('ADDRESS LINE 1: ..');WRITELN; - WRITELN('ADDRESS LINE 2: ..');WRITELN; - WRITELN('CITY: ............');WRITELN; - WRITELN('STATE: ...........');WRITELN; - WRITELN('ZIP: .............');WRITELN; - WRITELN('CODE(s): .........'); -END; - - -PROCEDURE INIT; -BEGIN - Terminal := ADM; { Select the correct terminal type } - BELL := CHR(7); - HOME := CHR(30); { Home the cursor but do not clear the screen } - CLEAR := CHR(26); { Completely clear the terminal screen } - ESC := CHR(27); - -{+++++++++++++++++++++++++++++++++++++++++++++++++++} -{+ These string sequences pertain to the Televideo +} -{+ terminal. +} -{+++++++++++++++++++++++++++++++++++++++++++++++++++} - { inverse video ON } - INVON[1] := ESC; - INVON[2] := 'j'; - { inverse video OFF } - INVOFF[1] := ESC; - INVOFF[2] := 'k'; - { delete the line the cursor is on } - LineDelete[1] := ESC; - LineDelete[2] := 'R'; - { erase from the cursor to the end of the line } - LineErase[1] := ESC; - LineErase[2] := 't'; - { half intensity ON } - HintOn[1] := ESC; - HintOn[2] := ')'; - { half intensity OFF } - HintOff[1] := ESC; - HintOff[2] := '('; - -{ f?_line = starting line for field n in the MASK } -{ f?_col = starting column for field n in the MASK } - f1_line := 5; f1_col := 20;{ FIELD #1 } - f2_line := 7; f2_col := 20;{ FIELD #2 } - f3_line := 9; f3_col := 20;{ FIELD #3 } - f4_line := 11; f4_col := 20;{ FIELD #4 } - f5_line := 13; f5_col := 20;{ FIELD #5 } - f6_line := 15; f6_col := 20;{ FIELD #6 } - f7_line := 17; f7_col := 20;{ FIELD #7 } - f8_line := 19; f8_col := 20;{ FIELD #8 } -END; - - -BEGIN{ Main program NAD entry } - INIT; - WRITE( CLEAR ); - { OPEN FILES } - SETLENGTH(FILENAME,0); - WRITELN; - WRITE(' FILE: '); - READLN(FILENAME); - APPEND(FILENAME,CHR(13)); - RESET(FILENAME,FOUT); - {++++++++++++++++++++++++++++++++++++++++++++++++++++++} - {+ IF FILE ALREADY EXISTS THEN INFORM OPERATOR THAT +} - {+ HE WILL DESTROY EXISTING FILE, AND TERMINATE. +} - {++++++++++++++++++++++++++++++++++++++++++++++++++++++} - IF NOT ( EOF(FOUT) ) THEN - BEGIN - WRITE( BELL ); - WRITELN - ( ' ':12,INVON,' FILE ALREADY EXISTS  ', INVOFF ); - WRITELN - ( ' ':12,INVON,' THIS PROGRAM WILL DESTROY YOUR FILE ', INVOFF ); - END - ELSE - BEGIN - REWRITE( FILENAME, FOUT); - WRITELN; - WRITE('Enter beginning Record No. '); - READLN(CURRENT_RECORD); - WRITE_MASK; - REPEAT - FILLONE(DONE); - IF NOT ( DONE ) THEN - BEGIN - CLEAR_ALL; - WRITEONE; - END; - CURRENT_RECORD := CURRENT_RECORD + 1 - UNTIL ( DONE ); - WRITE( CLEAR ); - END; -END.{ Program NAD Entry } - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/P1.SRC b/software/CPM/CPM16_MTPUG_04/P1.SRC deleted file mode 100644 index e2eaf77..0000000 --- a/software/CPM/CPM16_MTPUG_04/P1.SRC +++ /dev/null @@ -1,108 +0,0 @@ -(* VERSION 0002 *) -{$M plotaxis } -{$M *} -module plot1; - -(*..................................................................*) -(* PLOTLIB *) -(* Plotlib is a collection of plot routines to aid in graphics *) -(* programs. The routines were originally published in BYTE as *) -(* 'Drawing with UCSD Pascal and the Hiplot Plotter' by Dr. James *) -(* Stork, Oct 1981. The routines have been modified to run with *) -(* a MicroAngelo graphics terminal by Ray Hopkins, 8 Chestnut Hill *) -(* Ct., Cinnaminson N.J. (609) 829-4686. *) -(*..................................................................*) - -const pi = 3.14159; - -var - xpos,ypos :external real; - -(*$ISTDLIB.DEF *) - - -external procedure plotline(penpos:integer;txpos,typos:real); - -external procedure plotstring(px,py,height,theta:real;line:string); - -procedure plotaxis(px,py,leng,theta,min,max,tic:real;name:string); - -var temp1,side:integer; - print :boolean; - amount:string; - thetal,temp,rxpos,rypos,len,per,step:real; - -procedure divsteps(theta:real); - -begin - theta:=theta+pi/2; - plotline(2,xpos+0.03*cos(theta),ypos+0.03*sin(theta)); - plotline(2,xpos-0.06*cos(theta),ypos-0.06*sin(theta)); - plotline(2,xpos+0.03*cos(theta),ypos+0.03*sin(theta)); -end; - -begin {plotaxis} - if tic<0 then - begin - tic:=-tic; - side:=-1; - end - else - side:=1; - thetal:=theta; - theta:=(pi/180)*theta; - if (px+leng*cos(theta)>511) or (py+leng*sin(theta)>479) then - begin - writeln('axis off screen'); - readln; - exit; - end; - if leng<0 then - begin - print:=false; - leng:=-leng; - end - else - print:=true; - len:=leng; - plotline(1,px,py); - per:=(leng-0.01)/(max-min); - while leng>0 do - begin - if leng>tic*per then step:=tic*per - else step:=leng; - divsteps(theta); - if print then - begin - rxpos:=xpos; - rypos:=ypos; - temp1:=trunc(min*100); - intstr(temp1,0,amount); - insert('.',amount,length(amount)-1); - if temp1=0 then amount:='0'; - temp:=length(amount)/2; - plotline(1,xpos-(0.086*temp*cos(theta)- - side*(0.14+(side-1)*0.05)*sin(theta)), - ypos-(0.086*temp*sin(theta)+ - side*(0.14+(side-1)*0.05)*cos(theta))); - plotstring(xpos,ypos,0.1,thetal,amount); - plotline(1,rxpos,rypos); - end; - plotline(2,xpos+step*cos(theta),ypos+step*sin(theta)); - leng:=leng-step; - min:=min+tic - end; - if print then - begin - plotline(1, - xpos-(len/2*cos(theta)+0.108*round(length(name)/2) - *cos(theta)-side*(0.35+(side-1)*0.075)*sin(theta)), - ypos-(len/2*sin(theta)+0.108*round(length(name)/2) - *sin(theta)+side*(0.35+(side-1)*0.075)*cos(theta))); - plotstring(xpos,ypos,0.125,thetal,name); - end; - end; {plotaxis} - - -modend. -. \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/P2.SRC b/software/CPM/CPM16_MTPUG_04/P2.SRC deleted file mode 100644 index c4132b4..0000000 --- a/software/CPM/CPM16_MTPUG_04/P2.SRC +++ /dev/null @@ -1,182 +0,0 @@ -(* VERSION 0007 *) -{$M plotstring } -{$M *} -module plot2; - -(*..................................................................*) -(* PLOTLIB *) -(* Plotlib is a collection of plot routines to aid in graphics *) -(* programs. The routines were originally published in BYTE as *) -(* 'Drawing with UCSD Pascal and the Hiplot Plotter' by Dr. James *) -(* Stork, Oct 1981. The routines have been modified to run with *) -(* a MicroAngelo graphics terminal by Ray Hopkins, 8 Chestnut Hill *) -(* Ct., Cinnaminson N.J. (609) 829-4686. *) -(*..................................................................*) - -const pi = 3.14159; - -var - xpos,ypos :external real; - -(*$ISTDLIB.DEF *) - -external procedure plotline(penpos:integer;txpos,typos:real); - -procedure plotstring(px,py,height,theta:real;line:string); - -var step1,xstep,ystep,x2step,y2step,x3step,y3step: real; - step,xstep1,ystep1,x2step1,y2step1,x3step1,y3step1:real; - j,n:integer; - -procedure plotchar(ch:char); - -var rxpos,rypos:real; - plot:string[32]; - pchar:char; - i:integer; - -procedure arrow; - -begin {arrow} - step1:=0.04; - xstep1:=step1*cos(theta); - ystep1:=step1*sin(theta); - x2step1:=sqrt(2)*step1*cos(theta+pi/4); - y2step1:=sqrt(2)*step1*sin(theta+pi/4); - x3step1:=sqrt(2)*step1*cos(theta-pi/4); - y3step1:=sqrt(2)*step1*sin(theta-pi/4); - plotline(2,xpos-y2step1,ypos+x2step1); - plotline(2,xpos+ystep1,ypos-xstep1); - plotline(2,xpos+ystep1,ypos-xstep1); - plotline(2,xpos-y3step1,ypos+x3step1); -end; - -procedure getcode; - -begin - case ch of - 'A','a':plot:='d8888889oolkkkkkkaaaawwwwooooi'; - 'B','b':plot:='d8888888ooolkjuuuooolkkjuuui'; - 'C','c':plot:='dddddwjuu7888889ooli'; - 'D','d':plot:='d8888888ooolkkkkkjuuui'; - 'E','e':plot:='ddddduuuu8888oouu888ooooi'; - 'F','f':plot:='d8888oouu888ooooi'; - 'G','g':plot:='dddddwwwwww7uujkkkkkloo988uui'; - 'H','h':plot:='d8888888ddddkkkkkkkwwwwuuuui'; - 'I','i':plot:='doooouu8888888uuooooi'; - 'J','j':plot:='dwloo9888888i'; - 'K','k':plot:='d8888888dddjjjlllli'; - 'L','l':plot:='ddddduuuu8888888i'; - 'M','m':plot:='d8888888llkk8899kkkkkkki'; - 'N','n':plot:='d8888888llllwwwwkkkkkkki'; - 'O','o':plot:='dd7888889oolkkkkkjuui'; - 'P','p':plot:='d8888888ooolkkjuuui'; - 'Q','q':plot:='dd7888889oolkkkkkjuudwwlli'; - 'R','r':plot:='d8888888ooolkkjuuuooolkki'; - 'S','s':plot:='dwloo9887uu789ooli'; - 'T','t':plot:='ddd8888888aaooooi'; - 'U','u':plot:='dwwwwwwwkkkkkkloo9888888i'; - 'V','v':plot:='dwwwwwwwkkkkkll9988888i'; - 'W','w':plot:='dwwwwwwwkkkkkkk9988kkll8888888i'; - 'X','x':plot:='dwwwwwwwooookjjjjkkooooi'; - 'Y','y':plot:='dwwwwwwwkll998kjjkkkki'; - 'Z','z':plot:='dwwwwwwwooookjjjjkkooooi'; - '1':plot:='dwwwww99kkkkkkkuuooooi'; - '2':plot:='dwwwwww9oolkkjjjjooooi'; - '3':plot:='dwwwwww9ooojjjoolkkjuu7i'; - '4':plot:='dwwwwwwwkkkkooooawwwwkkkkkkki'; - '5':plot:='dddddwwwwwwwuuuukkkooolkkjuu7i'; - '6':plot:='dddddwwwwww7uujkkkkkloo9887uuji'; - '7':plot:='dwwwwww8ooookjjkkkki'; - '8':plot:='ddwwww789oolkjuujkkloo9887i'; - '9':plot:='dwloo9888887uujkkloo9i'; - '0':plot:='dd7888889oolkkkkkjuui'; - end; -end; - -procedure getcode1; - -begin - case ch of - '.':plot:='ddd8okui'; - '>':plot:='d999777i'; - '<':plot:='dddd777999i'; - '$':plot:='dwwooo97uu79ooowaakkkkkki'; - '^':plot:='ooooooo^i'; - '*':plot:='dww9999aakkkkdd7777xxooooi'; - '/':plot:='d8899998i'; - '"':plot:='dw9999aaaku8oxxxxd8ok8okuui'; - '?':plot:='ddd8w8997uujki'; - '#':plot:='ddddwwwww8okui'; - '&':plot:='dddwwwwkkuu88ooooxaooakki'; - ',':plot:='ddd8okuoji'; - '(':plot:='dddd7788899i'; - ')':plot:='dd9988877i'; - '%':plot:='dw9999aaauko8xxxxddo8uki'; - '+':plot:='dddww8888aaxxooooi'; - '-':plot:='dwwwwoooooi'; - ':':plot:='ddwwo8ukwwo8uki'; - '[':plot:='1i'; - ']':plot:='2i'; - '=':plot:='ddwwoooowwuuuui'; - end; -end; - -begin{plotchar} - rxpos:=xpos; - rypos:=ypos; - plot:='i'; - getcode; - getcode1; - i:=1; - pchar:='0'; - while pchar<>'i' do - begin - pchar:=plot[i]; - case pchar of - 'd':plotline(1,xpos+xstep,ypos+ystep); - 'w':plotline(1,xpos-ystep,ypos+xstep); - 'a':plotline(1,xpos-xstep,ypos-ystep); - '7':plotline(2,xpos-x3step,ypos-y3step); - '8':plotline(2,xpos-ystep,ypos+xstep); - '9':plotline(2,xpos+x2step,ypos+y2step); - 'o':plotline(2,xpos+xstep,ypos+ystep); - 'l':plotline(2,xpos+x3step,ypos+y3step); - 'k':plotline(2,xpos+ystep,ypos-xstep); - 'j':plotline(2,xpos-x2step,ypos-y2step); - 'u':plotline(2,xpos-xstep,ypos-ystep); - 'x':plotline(1,xpos+ystep,ypos-xstep); - '^':arrow; - '1':begin - rxpos:=rxpos-(height/2)*sin(theta)-6*xstep; - rypos:=rypos+(height/2)*cos(theta)-6*ystep; - end; - '2':begin - rxpos:=rxpos+(height/2)*sin(theta)-6*xstep; - rypos:=rypos-(height/2)*cos(theta)-6*ystep - end; - end; - i:=i+1; - end; - plotline(1,rxpos+6*xstep,rypos+6*ystep); -end; {plotchar} - -begin {plotstring} - theta:=(theta/180)*pi; - step:=height/7; - xstep:=step*cos(theta); - ystep:=step*sin(theta); - x2step:=sqrt(2)*step*cos(theta+pi/4); - y2step:=sqrt(2)*step*sin(theta+pi/4); - x3step:=sqrt(2)*step*cos(theta-pi/4); - y3step:=sqrt(2)*step*sin(theta-pi/4); - n:=length(line); - plotline(1,px,py); - for j:=1 to n do - begin - plotchar(line[j]); - end -end; {plotstring} - -modend. -. \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/P3.SRC b/software/CPM/CPM16_MTPUG_04/P3.SRC deleted file mode 100644 index b38d327..0000000 --- a/software/CPM/CPM16_MTPUG_04/P3.SRC +++ /dev/null @@ -1,48 +0,0 @@ -(* VERSION 0004 *) -{$M plotline} -{$M *} -module plot3; - -(*..................................................................*) -(* PLOTLIB *) -(* Plotlib is a collection of plot routines to aid in graphics *) -(* programs. The routines were originally published in BYTE as *) -(* 'Drawing with UCSD Pascal and the Hiplot Plotter' by Dr. James *) -(* Stork, Oct 1981. The routines have been modified to run with *) -(* a MicroAngelo graphics terminal by Ray Hopkins, 8 Chestnut Hill *) -(* Ct., Cinnaminson N.J. (609) 829-4686. *) -(*..................................................................*) - -const pi = 3.14159; - -var - xpos,ypos :external real; - -(*$ISTDLIB.DEF *) - -external procedure outp(B:byte); - -external procedure micro2(comm:byte;x,y:integer); - -procedure plotline(penpos:integer;txpos,typos:real); -var ix,iy : integer; - -begin - xpos:=txpos; - ypos:=typos; - ix:=round(xpos*51.1); - iy:=round(ypos*479/7); - case penpos of - 0:{initplot} - begin - outp($88); - micro2($84,ix,iy); - end; - 1:micro2($84,ix,iy); - 2:micro2($91,ix,iy); - end; -end; - - -modend. -t \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/P4.SRC b/software/CPM/CPM16_MTPUG_04/P4.SRC deleted file mode 100644 index 721e249..0000000 --- a/software/CPM/CPM16_MTPUG_04/P4.SRC +++ /dev/null @@ -1,42 +0,0 @@ -(* VERSION 0002 *) -{$M outp } -{$M micro2 } -{$M *} - -module plot4; - -(*..................................................................*) -(* PLOTLIB *) -(* Plotlib is a collection of plot routines to aid in graphics *) -(* programs. The routines were originally published in BYTE as *) -(* 'Drawing with UCSD Pascal and the Hiplot Plotter' by Dr. James *) -(* Stork, Oct 1981. The routines have been modified to run with *) -(* a MicroAngelo graphics terminal by Ray Hopkins, 8 Chestnut Hill *) -(* Ct., Cinnaminson N.J. (609) 829-4686. *) -(*..................................................................*) - -procedure outp(B:byte); - -{outputs a byte to MicroAngelo terminal E1=status port, E0=data port} - -begin -inline("IN/$E1/ - "ANI/1/ - "JNZ/*-4); - out[$E0]:=B; -end; - -procedure micro2(comm:byte;x,y:integer); - -{outputs command and 2 integer operands to terminal} - -begin -outp(comm); -outp(HI(x)); -outp(LO(x)); -outp(HI(y)); -outp(LO(y)); -end; - -modend. - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/P6.SRC b/software/CPM/CPM16_MTPUG_04/P6.SRC deleted file mode 100644 index a2731db..0000000 --- a/software/CPM/CPM16_MTPUG_04/P6.SRC +++ /dev/null @@ -1,67 +0,0 @@ -(* VERSION 0002 *) -module plot6; - - -(*..................................................................*) -(* PLOTLIB *) -(* Plotlib is a collection of plot routines to aid in graphics *) -(* programs. The routines were originally published in BYTE as *) -(* 'Drawing with UCSD Pascal and the Hiplot Plotter' by Dr. James *) -(* Stork, Oct 1981. The routines have been modified to run with *) -(* a MicroAngelo graphics terminal by Ray Hopkins, 8 Chestnut Hill *) -(* Ct., Cinnaminson N.J. (609) 829-4686. *) -(*..................................................................*) - -type -{$I PLOTLIB.TYP} - -const -{$I PLOTLIB.CON} - -var - xpos,ypos :external real; - -(*$IPLOTLIB.DEF*) -{$ISTDLIB.DEF} - -external procedure plotsymbol(sym:integer;height:real); - -procedure plotarray(nopoints,freq,sym:integer; - px,py,xmin,xmax,ymin,ymax,height,xlen,ylen:real; - x,y: coord); - -var pen,i:integer; - -begin - if nopoints>250 then - begin - outp($88); - write('too many points'); - readln; - outp($88); - exit; - end; - if (py+ylen>7) or (px+xlen>10) then - begin - outp($88); - write('data is off screen. Type ret'); - readln; - outp($88); - exit; - end; - xlen:=(xmax-xmin)/xlen; - ylen:=(ymax-ymin)/ylen; - if freq<0 then pen:=1 - else pen:=2; - freq:=abs(freq); - plotline(1,((x[1]-xmin)/xlen)+px,((y[1]-ymin)/ylen)+py); - for i:=2 to nopoints do - begin - plotline(pen,((x[i]-xmin)/xlen)+px,((y[i]-ymin)/ylen)+py); - if freq>0 then - if ((i+1)mod freq=0) then plotsymbol(sym,height); - end; - end; {plotarray} - -modend. -ü \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/P7.SRC b/software/CPM/CPM16_MTPUG_04/P7.SRC deleted file mode 100644 index 8341052..0000000 --- a/software/CPM/CPM16_MTPUG_04/P7.SRC +++ /dev/null @@ -1,35 +0,0 @@ -(* VERSION 0002 *) -module plot7; - - -(*..................................................................*) -(* PLOTLIB *) -(* Plotlib is a collection of plot routines to aid in graphics *) -(* programs. The routines were originally published in BYTE as *) -(* 'Drawing with UCSD Pascal and the Hiplot Plotter' by Dr. James *) -(* Stork, Oct 1981. The routines have been modified to run with *) -(* a MicroAngelo graphics terminal by Ray Hopkins, 8 Chestnut Hill *) -(* Ct., Cinnaminson N.J. (609) 829-4686. *) -(*..................................................................*) - -type -{$I PLOTLIB.TYP} - -const -{$I PLOTLIB.CON} - -var - xpos,ypos :external real; - -(*$IPLOTLIB.DEF*) -{$ISTDLIB.DEF} - -procedure plotwhere(var px,py:real); - -begin - px:=xpos; - py:=ypos; -end; - -modend. -t \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/P8.SRC b/software/CPM/CPM16_MTPUG_04/P8.SRC deleted file mode 100644 index b4cae40..0000000 --- a/software/CPM/CPM16_MTPUG_04/P8.SRC +++ /dev/null @@ -1,79 +0,0 @@ -(* VERSION 0002 *) -module plot8; - - -(*..................................................................*) -(* PLOTLIB *) -(* Plotlib is a collection of plot routines to aid in graphics *) -(* programs. The routines were originally published in BYTE as *) -(* 'Drawing with UCSD Pascal and the Hiplot Plotter' by Dr. James *) -(* Stork, Oct 1981. The routines have been modified to run with *) -(* a MicroAngelo graphics terminal by Ray Hopkins, 8 Chestnut Hill *) -(* Ct., Cinnaminson N.J. (609) 829-4686. *) -(*..................................................................*) - -type -{$I PLOTLIB.TYP} - -const -{$I PLOTLIB.CON} - -var - xpos,ypos :external real; - -(*$IPLOTLIB.DEF*) -{$ISTDLIB.DEF} - -procedure plotsymbol(sym:integer;height:real); - -var rxpos,rypos:real; - -begin - rxpos:=xpos; - rypos:=ypos; - case sym of - 1:begin {triangle} - plotline(2,xpos,ypos+height/2); - plotline(2,xpos-height/2,ypos-height); - plotline(2,xpos+height,ypos); - plotline(2,xpos-height/2,ypos+height); - plotline(1,rxpos,rypos); - end; - - 2:begin { X } - plotline(1,xpos-height/2,ypos+height/2); - plotline(2,xpos+height,ypos-height); - plotline(1,xpos-height,ypos); - plotline(2,xpos+height,ypos+height); - plotline(1,rxpos,rypos); - end; - - 3:begin {square} - plotline(1,xpos,ypos+height/2); - plotline(2,xpos-height/2,ypos); - plotline(2,xpos,ypos-height); - plotline(2,xpos+height,ypos); - plotline(2,xpos,ypos+height); - plotline(2,xpos-height/2,ypos); - plotline(1,rxpos,rypos); - end; - - 4:begin { + } - plotline(2,xpos+height/2,ypos); - plotline(2,xpos-height,ypos); - plotline(2,xpos+height/2,ypos); - plotline(2,xpos,ypos+height/2); - plotline(2,xpos,ypos-height); - plotline(2,rxpos,rypos); - end; - - 5:begin { | } - plotline(2,xpos,ypos+height/2); - plotline(2,xpos,ypos-height); - plotline(2,xpos,ypos); - end; - end; -end; {plotsymbol} - -modend. -^ \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/PLOTLIB.BLD b/software/CPM/CPM16_MTPUG_04/PLOTLIB.BLD deleted file mode 100644 index 9185ef7..0000000 --- a/software/CPM/CPM16_MTPUG_04/PLOTLIB.BLD +++ /dev/null @@ -1,9 +0,0 @@ -PLOTLIB.ERL -P1.ERL -P6.ERL -P8.ERL -P7.ERL -P2.ERL -P3.ERL -P4.ERL - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/PLOTLIB.CON b/software/CPM/CPM16_MTPUG_04/PLOTLIB.CON deleted file mode 100644 index 9af16ef..0000000 --- a/software/CPM/CPM16_MTPUG_04/PLOTLIB.CON +++ /dev/null @@ -1,2 +0,0 @@ - pi = 3.14159; -5 \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/PLOTLIB.DEF b/software/CPM/CPM16_MTPUG_04/PLOTLIB.DEF deleted file mode 100644 index ccfaeb2..0000000 --- a/software/CPM/CPM16_MTPUG_04/PLOTLIB.DEF +++ /dev/null @@ -1,21 +0,0 @@ - - -external procedure outp(B:byte); - -external procedure micro2(comm:byte;x,y:integer); - -external procedure plotwhere(var px,py:real); - -external procedure plotline(penpos:integer;txpos,typos:real); - -external procedure plotstring(px,py,height,theta:real;line:string); - -external procedure plotsymbol(sym:integer;height:real); - -external procedure plotarray(nopoints,freq,sym:integer; - px,py,xmin,xmax,ymin,ymax,height,xlen,ylen:real; - x,y:coord); - -external procedure plotaxis(px,py,leng,theta,min,max,tic:real;name:string); - - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/PLOTLIB.DOC b/software/CPM/CPM16_MTPUG_04/PLOTLIB.DOC deleted file mode 100644 index 043f046..0000000 --- a/software/CPM/CPM16_MTPUG_04/PLOTLIB.DOC +++ /dev/null @@ -1,74 +0,0 @@ - Enclosed is my check for the user group dues. I received news - letters 1,2 and 4 but not 3. If you have any copies of number 3, - I would appreciate a copy. - - I have recently gotten BLAZE/pascal utilty libraries package. The -package consists of five libraries containing handy functions and -procedures. So far I have been very impressed with the package. In -addition to several handy items which are not in standard pascal, the -bulk of the routines support data conversions to and from strings, -string editing functions, etc which can greatly improve the data input -and output portions of a program. The package also includes all the -necessary include file needed to reference the routines in your application -programs. The package sells for $200 for the source and $75 for the object -files. I got the object file package for $50 at The Trenton State Computer -Convention which my club (ACGNJ) sponsers. Starside Engineering which sells -the package may go for a group purchase. - - - Also included this disk are two programs and assorted support files. -Both programs were copied from magazines as noted and modified to run -with a MicroAngelo display board and PascalMT. While not original, the -programs are usefull and can save a lot of typing. - - The modules p1 to pn are library modules which form 'plotlib'.Programs -tplot and tplot1 test the available functions. Also included are varios -include and command files for ease of use.None of the modules are commented -except for the credits, so you must refer to the source for detailed inormation. - - The hl series is a 3d drawing package. Hl,hl1,hl2, are the drawing -routines, and hl3 creates the input data base. I just got this program working -and it still has some not implemented functions which I left in as comments. - - - Both programs use hardware dependant functions as follows: - - outp(B:byte); {sends a byte to MicroAngelo display - if b7 of the byte is set the display - will interpret it as a command. Commands - may require additional data or cause a - response which must be read. In these - programs I used the following commands - a) $88- clear screen - b) $84- set graphics cursor - c) $91- draw line to x,y - d) $B8- set alpha screen to bottom n lines - e) $80- set alpha mode parameters} - - micro2(command:byte;arg1,arg2:integer); {sends a command - and two integer operands to the MicroAngelo. - usually the operands are integer x and y - locations. Allowable x values are 0-511, y - may be 0-479. With 0,0 being the lower left - hand corner of the display.} - - at(x,y) {position alpha cursor to x,y} - - intstr(num,len:integer;var result:string); - {converts num into a string result of length - len. This can be simulated by writing to a - file num and then reading it back as result.} - - I hope the programs are of use to others. Keep up the good work.If - you think it would be usefull I could give a more detailed review of - Blase/Pascal in a future news letter after I have had a chance to try - all of the features. If you are interested drop a note on the return disk. - - Regards - Ray Hopkins - 8 Chestnut Hill Ct. - Cinnaminson N.J. - 08077 - (609) 829-4686 - - at(o \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/PLOTLIB.TYP b/software/CPM/CPM16_MTPUG_04/PLOTLIB.TYP deleted file mode 100644 index d92c627..0000000 --- a/software/CPM/CPM16_MTPUG_04/PLOTLIB.TYP +++ /dev/null @@ -1,3 +0,0 @@ - - coord = array[1..250] of real; -t \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/PTABLE.PAS b/software/CPM/CPM16_MTPUG_04/PTABLE.PAS deleted file mode 100644 index 94cc1f2..0000000 --- a/software/CPM/CPM16_MTPUG_04/PTABLE.PAS +++ /dev/null @@ -1,36 +0,0 @@ -(****************************************************** -* -* POWER TABLE PROGRAM -* -* This program was extracted from the book PROGRAMMING -* IN PASCAL by Peter Grogono during a self-study effort. -* It is a simple enough program but it shows how to build -* tables very easily. I had to modify it of course, so that -* it would run with Pascal/Z. -* -* Adaptation by Charlie Foster, Oct 1980 -* Donated to the Pascal/Z Users Group -*******************************************************) - -PROGRAM powertable; - -VAR - tablesize, base, square, cube, quad : INTEGER; -BEGIN - WRITELN; - WRITE ('How many numbers do you want to tabulate?--> '); - READ (tablesize); - WRITELN; - WRITELN (' ':30,'TABLE'); - WRITELN; - FOR base := 1 TO tablesize DO - BEGIN - square := sqr (base); - cube := base * square; - quad := sqr (square); - WRITELN (base:2,' ',square:4,' ',cube:5,' ', - quad:6,' ',1/base:12,' ',1/square:12, - ' ',1/cube:12,' ',1/quad:12) - END (* for loop *) -END. (* MAIN *) - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/PTEST.CMD b/software/CPM/CPM16_MTPUG_04/PTEST.CMD deleted file mode 100644 index 77c69ad..0000000 --- a/software/CPM/CPM16_MTPUG_04/PTEST.CMD +++ /dev/null @@ -1,3 +0,0 @@ -ptest,PLOTLIB,stdlib-f/s,a:trancend/s,a:fpreals/s,a:paslib/s - - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/PTEST.SRC b/software/CPM/CPM16_MTPUG_04/PTEST.SRC deleted file mode 100644 index dbead02..0000000 --- a/software/CPM/CPM16_MTPUG_04/PTEST.SRC +++ /dev/null @@ -1,43 +0,0 @@ -(* VERSION 0009 *) -program plotter; - - -(*..................................................................*) -(* PLOTLIB *) -(* Plotlib is a collection of plot routines to aid in graphics *) -(* programs. The routines were originally published in BYTE as *) -(* 'Drawing with UCSD Pascal and the Hiplot Plotter' by Dr. James *) -(* Stork, Oct 1981. The routines have been modified to run with *) -(* a MicroAngelo graphics terminal by Ray Hopkins, 8 Chestnut Hill *) -(* Ct., Cinnaminson N.J. (609) 829-4686. *) -(*..................................................................*) - -type -{$I PLOTLIB.TYP} - -const -{$I PLOTLIB.CON} - -var clear : char; - aline: string[20]; - xpos,ypos : real; - -(*$IPLOTLIB.DEF*) -{$ISTDLIB.DEF} - - - -begin - xpos:=0; - ypos:=0; - plotline(0,xpos,ypos); - aline:='ABCDEFGHIJ'; - plotstring(1,6,0.5,0,aline); - aline:='KLMNOPQRST'; - plotstring(1,5,0.8,0,aline); - aline:='UVWXYZ.><$'; - plotstring(1,4,0.7,0,aline); - aline:='=^*%,&#"/()+-:'; - plotstring(1,3,0.8,0,aline); -end. -ÿ \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/PTEST1.CMD b/software/CPM/CPM16_MTPUG_04/PTEST1.CMD deleted file mode 100644 index 6ffa976..0000000 --- a/software/CPM/CPM16_MTPUG_04/PTEST1.CMD +++ /dev/null @@ -1,3 +0,0 @@ -ptest1,a:trancend/s,a:fpreals/s,a:paslib/s - - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/PTEST1.SRC b/software/CPM/CPM16_MTPUG_04/PTEST1.SRC deleted file mode 100644 index d140ca6..0000000 --- a/software/CPM/CPM16_MTPUG_04/PTEST1.SRC +++ /dev/null @@ -1,43 +0,0 @@ -(* VERSION 0008 *) -program plotter; - - -(*..................................................................*) -(* PLOTLIB *) -(* Plotlib is a collection of plot routines to aid in graphics *) -(* programs. The routines were originally published in BYTE as *) -(* 'Drawing with UCSD Pascal and the Hiplot Plotter' by Dr. James *) -(* Stork, Oct 1981. The routines have been modified to run with *) -(* a MicroAngelo graphics terminal by Ray Hopkins, 8 Chestnut Hill *) -(* Ct., Cinnaminson N.J. (609) 829-4686. *) -(*..................................................................*) - -type -{$I PLOTLIB.TYP} - -const -{$I PLOTLIB.CON} - -var clear : char; - aline: string[20]; - xpos,ypos : real; - -(*$IPLOTLIB.DEF*) -{$ISTDLIB.DEF} - - - -begin - xpos:=0; - ypos:=0; - plotline(0,xpos,ypos); - aline:='ABCDEFGHIJ'; - plotstring(1,6,0.5,0,aline); - aline:='KLMNOPQRST'; - plotstring(1,5,0.8,0,aline); - aline:='UVWXYZ.><$'; - plotstring(1,4,0.7,0,aline); - aline:='=^*%,&#"/()+-:'; - plotstring(1,3,0.8,0,aline); -end. -ÿ \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/PTRS2.PAS b/software/CPM/CPM16_MTPUG_04/PTRS2.PAS deleted file mode 100644 index fe3b8ac..0000000 --- a/software/CPM/CPM16_MTPUG_04/PTRS2.PAS +++ /dev/null @@ -1,155 +0,0 @@ -{++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{+ +} -{+ PROGRAM TITLE: Copy With Prefixed Char Count +} -{+ +} -{+ WRITTEN BY: George W. Cherry [1] +} -{+ +} -{+ Modified by Raymond E. Penley, 7 Oct 1980 +} -{+ The program reads in whole lines instead +} -{+ of single characters then prints the whole +} -{+ linked list of "lines". +} -{+ +} -{+ [1] "Pascal Programming Structures", pgs 232-237 +} -{+ Reston Publishing Company, Inc. +} -{++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -PROGRAM CopyWithPrefixedCharCount; - -CONST - default = 80; - input = 0; {Pascal/Z needs this crutch} - -TYPE - items = string default; - P_pointer = ^queuecell; - queuecell = record - line : items; - next : P_pointer - end; - S$0 = string 0; - S$255 = string 255; - -VAR - charcount : integer; - currentline : items; {the current line} - FrntPtr, - RearPtr : P_pointer; - ch : char; - linecount : integer; - EndOfLine, - EndOfFile, - done : boolean; - ix : integer; - -Function length(x: S$255): integer; external; - -Procedure setlength(var x: S$0; y: integer); external; - -Procedure KEYIN(VAR cix: char); EXTERNAL; - -Procedure InitializeQueue; -begin - FrntPtr := NIL; - RearPtr := NIL; -end {of InitializeQueue}; - -Procedure Queue( currentline : items ); -VAR - new_ptr : P_pointer; -begin - NEW(new_ptr); {reserve a new queuecell } - new_ptr^.line := currentline; - new_ptr^.next := NIL; - If FrntPtr = NIL then - FrntPtr := new_ptr - Else - RearPtr^.next := new_ptr; - RearPtr := new_ptr; {complete the circular queue} -end {of Queue}; - -Function QueueIsEmpty : BOOLEAN; -begin - QueueIsEmpty := (FrntPtr = NIL); -end {of queueIsEmpty}; - -Procedure Serve(var current: items); -VAR - curitem : P_pointer; -begin - If QueueIsEmpty then - {nothing to do the queue is empty} - Else - begin - curitem := FrntPtr; - current := curitem^.line; - FrntPtr := FrntPtr^.next; - If FrntPtr = NIL then - RearPtr := NIL; - end; -end {of serve}; - -Procedure Read_a_chunck; -VAR - done_reading_lines : BOOLEAN; - - Procedure GetC(VAR ch: char); - { Recognizes "control-E" as End of File on the console. } - begin - KEYIN(ch);write(ch); - endofline := ( ord(ch)=13 ); - endoffile := ( ord(ch)=5 ); - If ( endofline ) OR ( endoffile ) then ch := ' '; - end; - - Procedure GetL(var LINE: items); - begin - setlength(LINE,0); - GetC(ch); - while not( EndOfLine OR EndOfFile ) DO - begin - charcount := charcount + 1; - append(line,ch); - GetC(ch); - end; - end; {GetLine} - -begin {of Read_a_chunck} - done_reading_lines := FALSE; - while not done_reading_lines do - begin - write('?'); - GetL(currentline);Writeln; - If (length(currentline)=0) OR ( EndOfFile ) then - done_reading_lines := TRUE - Else - Queue(currentline) - end; -end;{of Read_a_chunck} - -Procedure Process_chunck; -begin - linecount := 0; - while not QueueIsEmpty do - begin - linecount := linecount + 1; - write(linecount:3, ': '); - Serve(currentline); - Writeln(currentline); - end;{while not queueisempty} - Writeln; -end;{of Process_chunck} - -BEGIN {Main Program} - for ix:=1 to 25 Do writeln; { clear the crt } - InitializeQueue; - EndOfFile := FALSE; - while not EndOfFile do - begin - { INITIALIZE } - charcount := 0; - MARK(chunck); - Read_a_chunck; - Process_chunck; - RELEASE(chunck); - end;{while not EndOfFile} -END. - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/QQSORT.PAS b/software/CPM/CPM16_MTPUG_04/QQSORT.PAS deleted file mode 100644 index 7d086bb..0000000 --- a/software/CPM/CPM16_MTPUG_04/QQSORT.PAS +++ /dev/null @@ -1,183 +0,0 @@ -{++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{+ PROGRAM TITLE: Quick sort with minimal storage +} -{+ Test Program +} -{+ +} -{+ WRITTEN BY: Raymond E. Penley +} -{+ DATE WRITTEN: October 5, 1980 +} -{+ +} -{+ A program to show the speed of the quick sort +} -{+ with minimal storage algorithm. +} -{+ +} -{+ Average sorting times in seconds * +} -{+ No. of items Shellsort Quicksort QQuicksort +} -{+ 1000 15 8 7 +} -{+ 2000 34 20 14 +} -{+ 5000 112 50 37 +} -{+ 10,000 213 106 78 +} -{+ +} -{+ * Z80 CPU operating at 2 mcps +} -{+ +} -{++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -PROGRAM QuickerQuickSortTest; -CONST - Max_N = 10000; -TYPE - index = 0..Max_N; - Scalar = INTEGER; -VAR - cix : char; - N, - i, ix : Scalar; - A : ARRAY [index] OF Scalar; - - -Procedure Show; -var - i: index; -begin - for i:=1 to N do - begin - write(A[i]); - if i mod 8 = 0 then writeln; - end; - writeln; -end; - - - - -PROCEDURE QQSORT( left, right : INTEGER ); -{ -+ WRITTEN BY: Richard C. Singleton -+ DATE WRITTEN: Sept 17, 1968 -+ -+ This procedure sorts the elements of array A[1..n] into - ascending order. The method used is similar to QUICKERSORT - by R.S. Scowen, which in turn is similar to an algorithm given - by Hibbard and to Hoare's QUICKSORT. -+ -+ Modified 6 Oct 1980 for Pascal/Z. +} -{ -GLOBAL - TYPE - Index = 1..N; - Scalar = - VAR - A : array [Index] of Scalar; -} -VAR - t, tt: Scalar; - ii, ij, k, L, m : integer; - IL, IU : array [0..20] of integer;{Permit sorting up to 2**(K+1)-1 elements} - i, j, ix : integer; - alldone, d : BOOLEAN; -BEGIN {$C-,M-,F-} - i := left; - j := right; - m := 0; - ii := i; - alldone := FALSE; - REPEAT - If ((j-i) > 10) OR ( (i = ii) and (i < j) ) then - BEGIN - ij := (i+j) DIV 2; - t := A[ij]; - k := i; - L := j; - If (A[i] > t) then - begin - A[ij] := A[i]; A[i] := t; t := A[ij] - end; - If (A[j] < t) then - begin - A[ij] := A[j]; A[j] := t; t := A[ij]; - If (A[i] > t) then - begin - A[ij] := A[i]; A[i] := t; t := A[ij] - end; - end; - d := FALSE; - REPEAT - REPEAT - L := L - 1; - UNTIL A[L] <= t; - REPEAT - k := k + 1; - UNTIL A[k] >= t; - If (k <= L) then - begin - tt := A[L]; A[L] := A[k]; A[k] := tt; - end - Else - d := TRUE; - UNTIL d; - If (L-i) > (j-k) then - begin IL[m] := i; IU[m] := L; i := k end - Else - begin IL[m] := k; IU[m] := j; j := L end; - m := m + 1; - END - Else - BEGIN - For ix := (i+1) to j do - begin - t := A[ix]; - k := ix - 1; - If A[k] > t then - begin - REPEAT - A[k+1] := A[k]; - k := k - 1; - UNTIL A[k] <= t; - A[k+1] := t; - end; - end;{For ix} - m := m - 1; - If m >= 0 then - begin - i := IL[m]; - j := IU[m]; - end - Else - alldone := TRUE; - END; - UNTIL alldone; -END;{of QQSORT} {$C+,M+,F+} - -BEGIN (* MAIN *) - repeat - writeln; - writeln('Enter number of items to sort'); - writeln(' 10 <= n <= 10,000'); - write('?'); - readln(N); - until (N >= 10) and (N <= Max_N); - - writeln; - writeln('Please stand by while I set up.'); - {$C-,M-,F- [ctrl-c OFF]} - ix := 113; - FOR i := 1 TO N DO - BEGIN - ix := (131*ix+1) mod 221; - A[i] := ix; - if (i mod 1000 = 0) then write(i); - END; - writeln; - A[0] := -maxint; {$C+,M+,F+ [ctrl-c ON]} - - writeln('Ready'); - WRITE('Press return when ready to start'); - readln(cix); - writeln( CHR(7), 'START'); - {} - QQSORT( 1, N ); - {} - WRITELN( CHR(7), 'DONE!!!' ); - - writeln; - write('Print the array (Y/N)?'); - readln(cix); - If (cix='Y') or (cix='y') then Show; -END. - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/QSORT.PAS b/software/CPM/CPM16_MTPUG_04/QSORT.PAS deleted file mode 100644 index 937faa4..0000000 --- a/software/CPM/CPM16_MTPUG_04/QSORT.PAS +++ /dev/null @@ -1,114 +0,0 @@ -{++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{+ PROGRAM TITLE: Quicksort Test +} -{+ +} -{+ WRITTEN BY: Raymond E. Penley +} -{+ DATE WRITTEN: October 6, 1980 +} -{+ +} -{+ Show use of the quicksort algorithm in a Pascal +} -{+ program. +} -{+ +} -{+ Average sorting times in seconds * +} -{+ No. of items Shellsort Quicksort QQuicksort +} -{+ 1000 15 8 7 +} -{+ 2000 34 20 14 +} -{+ 5000 112 50 37 +} -{+ 10,000 213 106 78 +} -{+ +} -{+ * Z80 CPU operating at 2 mcps +} -{+ +} -{++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -PROGRAM Qsorttest; -CONST - Max_N = 10000; {Upper limit of all numbers} -TYPE - index = 0..Max_N; - Scalar = INTEGER; -VAR - cix : char; {Global temp char variable} - N, {The number of numbers to be sorted} - i, ix : Scalar; {Global indexers} - A : ARRAY [index] OF Scalar; {THE array to be sorted} - -Procedure Show; -var - i: index; -begin - for i:=1 to N do - begin - write(A[i]); - if i mod 8 = 0 then writeln; - end; - writeln; -end; - - - - -PROCEDURE QSORT( left,right: INTEGER ); -{ The classic Quicksort method by C.A.R Hoare. - Presented here in Pascal. } -{ -GLOBAL - TYPE - Index = 1..N; - Scalar = - VAR - A : array [Index] of Scalar; -} -VAR - II, JJ : integer; - Pivot, temp : Scalar; -BEGIN {$C-,M-,F-} - II := left; - JJ := right; - Pivot := A[(II+JJ) DIV 2]; - REPEAT - WHILE A[II] < Pivot DO II := II + 1; - WHILE A[JJ] > Pivot DO JJ := JJ - 1; - IF II <= JJ THEN - BEGIN - temp := A[II]; A[II] := A[JJ]; A[JJ] := temp; - II := II + 1; - JJ := JJ - 1 - END - UNTIL II > JJ; - IF left < JJ THEN QSORT( left, JJ ); - IF II < right THEN QSORT( II, right ) -END;{of QSORT} {$C+,M+,F+} - -BEGIN (* MAIN *) - repeat - writeln; - writeln('Enter number of items to sort'); - writeln(' 10 <= n <= 10,000'); - write('?'); - readln(N); - until (N >= 10) and (N <= Max_N); - - writeln; - writeln('Please stand by while I set up.'); - ix := 113; {$C-,M-,F- [ctrl-c OFF]} - FOR i := 1 TO N DO - BEGIN - ix := (131*ix+1) mod 221; - A[i] := ix; - if (i mod 1000 = 0) then write(i); - END; - writeln; - A[0] := -maxint; {$C+,M+,F+ [ctrl-c ON]} - - writeln('Ready'); - WRITE('Press return when ready to start'); - readln(cix); - writeln( CHR(7), 'START'); - {} - QSORT( 1, N ); - {} - WRITELN( CHR(7), 'DONE!!!' ); - - writeln; - write('Print the array (Y/N)?'); - readln(cix); - If (cix='Y') or (cix='y') then Show; -END. - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/SD.COM b/software/CPM/CPM16_MTPUG_04/SD.COM deleted file mode 100644 index cb3c3e5..0000000 Binary files a/software/CPM/CPM16_MTPUG_04/SD.COM and /dev/null differ diff --git a/software/CPM/CPM16_MTPUG_04/SEND.COM b/software/CPM/CPM16_MTPUG_04/SEND.COM deleted file mode 100644 index 0b53008..0000000 Binary files a/software/CPM/CPM16_MTPUG_04/SEND.COM and /dev/null differ diff --git a/software/CPM/CPM16_MTPUG_04/SHELL.PAS b/software/CPM/CPM16_MTPUG_04/SHELL.PAS deleted file mode 100644 index d1bf0db..0000000 --- a/software/CPM/CPM16_MTPUG_04/SHELL.PAS +++ /dev/null @@ -1,119 +0,0 @@ -{++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{+ PROGRAM TITLE: Shell Sort Test +} -{+ +} -{+ WRITTEN BY: Raymond E. Penley +} -{+ DATE WRITTEN: 5 October 1980 +} -{+ +} -{+ SUMMARY: +} -{+ This program demonstrates the Shell sort +} -{+ algorithm. +} -{+ +} -{+ Average sorting times in seconds * +} -{+ No. of items Shellsort Quicksort QQuicksort +} -{+ 1000 15 8 7 +} -{+ 2000 34 20 14 +} -{+ 5000 112 50 37 +} -{+ 10,000 213 106 78 +} -{+ +} -{+ * Z80 CPU operating at 2 mcps +} -{+ +} -{++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -PROGRAM Shellsorttest; -CONST - Max_N = 10000; -TYPE - INDEX = 0..Max_N; - SCALAR = INTEGER; - ScalarTyp = ARRAY [ INDEX ] OF SCALAR; -VAR - cix : char; {Global temp for char inputs} - A : ScalarTyp; - N, {The number of numbers to be sorted.} - i, ix : INTEGER; {Global indexer} - -Procedure Show; -var - i: index; -begin - for i:=1 to N do - begin - write(A[i]); - if i mod 8 = 0 then writeln; - end; - writeln; -end; - - - - -PROCEDURE Shellsort(VAR A : ScalarTyp; - n : INDEX); -{ -The array A[1..n] is sorted in ascending order. The method is that -of D.A. Shell, (A high-speed sorting procedure, Comm. ACM 2 (1959), -30-32) with subsequences chosen as suggested by T.N. Hibberd. -} -VAR - i, j, k, m : integer; - done : BOOLEAN; - temp : SCALAR; -begin (*$C-,M-,F-*) - m := n; - While m <> 0 do - begin - m := m DIV 2; - k := n - m; - for j:=1 to k do - begin - i := j; - done := FALSE; - repeat - if A[i+m] >= A[i] then - done := TRUE - else - begin - temp := A[i]; A[i] := A[i+m]; A[i+m] := temp; - i := i - m; - end; - until (i<1) OR ( done ); - end{for j}; - end{While}; -end;{Shellsort}{$C+,M+,F+} - - - -BEGIN (* Main program SHELLSORT*) - Repeat - writeln; - writeln('Enter number of items to sort'); - writeln(' 10 <= n <= 10,000'); - write('?'); - readln(N); - Until (N >= 10) and (N <= Max_N); - writeln; - writeln('Please stand by while I set up.'); - ix := 113; {$C-,M-,F- [ctrl-c OFF]} - FOR i := 1 TO N DO - BEGIN - ix := (131*ix+1) mod 221; - A[i] := ix; - if (i mod 1000 = 0) then write(i); - END; - writeln; - A[0] := -maxint; {$C+,M+,F+ [ctrl-c ON]} - - writeln('Ready'); - WRITE('Press return when ready to start'); - readln(cix); - writeln( CHR(7), 'START'); - {} - Shellsort(A, N ); - {} - WRITELN( CHR(7), 'DONE!!!' ); - - writeln; - write('Print the array (Y/N)?'); - readln(cix); - If (cix='Y') or (cix='y') then Show; -END. - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/SWEEP.COM b/software/CPM/CPM16_MTPUG_04/SWEEP.COM deleted file mode 100644 index 3b8e3e6..0000000 Binary files a/software/CPM/CPM16_MTPUG_04/SWEEP.COM and /dev/null differ diff --git a/software/CPM/CPM16_MTPUG_04/XREF.COM b/software/CPM/CPM16_MTPUG_04/XREF.COM deleted file mode 100644 index 4814509..0000000 Binary files a/software/CPM/CPM16_MTPUG_04/XREF.COM and /dev/null differ diff --git a/software/CPM/CPM16_MTPUG_04/XREF.DOC b/software/CPM/CPM16_MTPUG_04/XREF.DOC deleted file mode 100644 index d71a8a7..0000000 --- a/software/CPM/CPM16_MTPUG_04/XREF.DOC +++ /dev/null @@ -1,22 +0,0 @@ -The files XREF.SRC and XREF.COM as originally supplied on the MT+ -distribution disk are the source and object of a Pascal cross-referencing -program. They are public domain and not specific to Pascal/MT+ (i.e., -may be used to cross reference other Pascal programs). They may also be -used to cross reference other languages if the keyword table is changed. - -The present version has been been somewhat customized for Pascal MT+. -The keyword table was modified, and XREF now accepts '@' as a legal letter, -and recognizes '_' as a letter but discards it, just as MT+ does. - -1. Type XREF - -2. XREF asks: Input file? - -3. XREF asks: Output file name? - - -4. XREF asks: Do you want a listing? - - -And that's it! - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/XREF.ERL b/software/CPM/CPM16_MTPUG_04/XREF.ERL deleted file mode 100644 index 459f3f2..0000000 Binary files a/software/CPM/CPM16_MTPUG_04/XREF.ERL and /dev/null differ diff --git a/software/CPM/CPM16_MTPUG_04/XREF.SRC b/software/CPM/CPM16_MTPUG_04/XREF.SRC deleted file mode 100644 index 50d57d9..0000000 --- a/software/CPM/CPM16_MTPUG_04/XREF.SRC +++ /dev/null @@ -1,537 +0,0 @@ -{$L-} -{====================================================================} -{ PROGRAM TITLE: PASCAL CROSS-REFERENCING PROGRAM } -{ } -{ PROGRAM FILE: XREF.SRC } -{ } -{ LAST UPDATE: 22 July 82 by Steve Clamage } -{ } -{ NOTE: THIS PROGRAM WAS ORIGINALLY WRITTEN BY N. WIRTH AND } -{ ADAPTED FOR UCSD PASCAL (I.4 - THE PUBLIC DOMAIN VERSION) } -{ BY SHAWN FANNING (IN 1978) AND SUBSEQUENTLY ADAPTED FOR } -{ PASCAL/MT+ BY MIKE LEHMAN (IN 1981) AND IS A PUBLIC DOMAIN } -{ PROGRAM. IF YOU MAKE REVISIONS, ETC. PLEASE LEAVE THE AUTHOR} -{ AND MODIFIERS NAME IN THE SOURCE FILE. THANK YOU. } -{ } -{ PROGRAM SUMMARY: } -{ } -{ THIS PROGRAM PRODUCES A CROSS-REFERENCE LISTING FOR ANY } -{ PASCAL PROGRAM. OCCURENCES ONLY ARE LISTED. NO DISTINCTION IS } -{ MADE BETWEEN DEFINITIONS AND REFERENCES. } -{ } -{ PROGRAM FIXES: } -{ Pascal MT+ distribution version didn't recognize braces as } -{ comment delimiters. Didn't put line feeds in output files, but } -{ terminated lines with CR only. Didn't recognize lower case or } -{ underscore (_). Keyword list incomplete. Last line of file } -{ omitted from listing and xref. } -{====================================================================} - -{$L+} -PROGRAM XREF; - -(*CROSS REFERENCE GENERATOR FOR PASCAL PROGRAMS. N.WIRTH, 7.5.74*) -(*'QUADRATIC QUOTIENT' HASH METHOD*) - -CONST - P = 749; (*SIZE OF HASHTABLE*) - NK = 50; (*NO. OF KEYWORDS*) - ALFALEN = 8; - REFSPERLINE = 10; (* for 80 column line *) - REFSPERITEM = 5; (* controls node size of linked list *) - - -TYPE - ALFA = PACKED ARRAY[1..ALFALEN] OF CHAR; - INDEX = 0..P; - ITEMPTR = ^ITEM; - WORD = RECORD - KEY: ALFA; - FIRST, LAST: ITEMPTR; - FOL: INDEX - END; - NUMREFS = 1..REFSPERITEM; - REFTYPE = (COUNT, PTR); - ITEM = RECORD - REF: ARRAY[NUMREFS] OF INTEGER; - CASE REFTYPE OF - COUNT: (REFNUM: NUMREFS); - PTR: (NEXT: ITEMPTR) - END; - BUFFER = STRING[132]; - IDENTCHARS = SET OF CHAR; - -VAR - TOP: INDEX; (*TOP OF CHAIN LINKING ALL ENTRIES IN T*) - I, - LINECOUNT: INTEGER; (*CURRENT LINE NUMBER*) - CH: CHAR; (*CURRENT CHAR SCANNED *) - BUF: BUFFER; (*OUTPUT LINE*) - T: ARRAY [INDEX] OF WORD; (*HASH TABLE*) - KEY: ARRAY [1..NK] OF ALFA; (*RESERVED KEYWORD TABLE *) - ALLDONE, (*ALLDONE OR ERROR FLAG *) - LISTING: BOOLEAN; (*LISTING OPTION *) - INFILE: TEXT; (*INPUT FILE*) - LST : TEXT; (*OUTPUT FILE*) - LSTFILENAME : STRING; - INPUT_LINE : BUFFER; - INLINEP : INTEGER; (*PTR TO CURRENT CHAR IN INPUT_LINE*) - TOCONSOLE : BOOLEAN; (*WHERE LISTING GOES *) - IDENTSET : IDENTCHARS; (*LEGAL CHARS IN IDENTIFIER*) - -{$P} -PROCEDURE INITIALIZE; -VAR - I : INTEGER; - - PROCEDURE FIRSTHALF; - BEGIN - KEY[ 1] := 'ABSOLUTE'; - KEY[ 2] := 'AND '; - KEY[ 3] := 'ARRAY '; - KEY[ 4] := 'BEGIN '; - KEY[ 5] := 'BOOLEAN '; - KEY[ 6] := 'CASE '; - KEY[ 7] := 'CHAR '; - KEY[ 8] := 'CONST '; - KEY[ 9] := 'DIV '; - KEY[10] := 'DO '; - KEY[11] := 'DOWNTO '; - KEY[12] := 'ELSE '; - KEY[13] := 'END '; - KEY[14] := 'EXIT '; - KEY[15] := 'EXTERNAL'; - KEY[16] := 'FILE '; - KEY[17] := 'FOR '; - KEY[18] := 'FUNCTION'; - KEY[19] := 'GOTO '; - KEY[20] := 'IF '; - KEY[21] := 'IN '; - KEY[22] := 'INTEGER '; - KEY[23] := 'LABEL '; - KEY[24] := 'MOD '; - KEY[25] := 'MODEND '; - KEY[26] := 'MODULE '; - KEY[27] := 'NIL '; - END; - - PROCEDURE SECONDHALF; - BEGIN - KEY[28] := 'NOT '; - KEY[29] := 'OF '; - KEY[30] := 'OR '; - KEY[31] := 'PACKED '; - KEY[32] := 'PROCEDUR'; - KEY[33] := 'PROGRAM '; - KEY[34] := 'READ '; - KEY[35] := 'READLN '; - KEY[36] := 'REAL '; - KEY[37] := 'RECORD '; - KEY[38] := 'REPEAT '; - KEY[39] := 'SET '; - KEY[40] := 'STRING '; - KEY[41] := 'TEXT '; - KEY[42] := 'THEN '; - KEY[43] := 'TO '; - KEY[44] := 'TYPE '; - KEY[45] := 'UNTIL '; - KEY[46] := 'VAR '; - KEY[47] := 'WHILE '; - KEY[48] := 'WITH '; - KEY[49] := 'WRITE '; - KEY[50] := 'WRITELN '; - END; - -BEGIN (* INITIALIZE *) - WRITELN; - WRITELN( - 'Pascal/MT+ Program Xref Utility, Release 5.2, updated 26 July 82'); - WRITELN('This program is public domain'); - ALLDONE := FALSE; - FOR I := 0 TO P DO - T[I].KEY := ' '; - FIRSTHALF; - SECONDHALF; - IDENTSET := [ 'A'..'Z', 'a'..'z', '@', '_' ]; - TOP := P; - CH := ' ' -END; (* INITIALIZE *) - -{$P} -PROCEDURE OPENFILES; -VAR - NUMBLOCKS: INTEGER; - OPENOK: BOOLEAN; - OPENERRNUM : INTEGER; - LISTOPTION: CHAR; - FILENAME: STRING; - -BEGIN (* OPEN *) - REPEAT - WRITELN; - WRITE( 'Input file ? ' ); - READLN( FILENAME ); - IF LENGTH(FILENAME) > 0 THEN - BEGIN - ASSIGN(INFILE, FILENAME ); - RESET(INFILE) - END; - OPENERRNUM := IORESULT; - OPENOK := ( OPENERRNUM <> 255 ); - IF NOT OPENOK THEN - WRITELN( '*** INPUT OPEN ERROR # ', OPENERRNUM ); - UNTIL OPENOK; - - WRITE('Output file name? '); - READLN(LSTFILENAME); - TOCONSOLE := (LSTFILENAME = 'CON:'); - ASSIGN(LST,LSTFILENAME); - REWRITE(LST); - - WRITE( 'Do you want a listing (Y/N)? ' ); - READ( LISTOPTION ); - LISTING := (LISTOPTION <> 'N') AND (LISTOPTION <> 'n'); - IF LISTING THEN - PUTNUMBER(0); - READLN(INFILE,INPUT_LINE); - LINECOUNT := 0; - INLINEP := 1; - WRITELN; -END; (* OPENFILES *) - -{$P} -PROCEDURE LPWRITELN; -VAR - I : INTEGER; - CH : CHAR; -BEGIN - WRITELN(LST,BUF); - BUF[0] := CHR(0); - LINECOUNT := LINECOUNT+1; - IF (LINECOUNT MOD 60) = 0 THEN - PAGE(LST); -END; - -{$P} -PROCEDURE PUTALFA(S:ALFA); -BEGIN - MOVELEFT(S[1], BUF[ORD(BUF[0])+1], 8); - BUF[0] := CHR(ORD(BUF[0]) + 8); -END; - - - -PROCEDURE PUTNUMBER(NUM: INTEGER); -VAR I,IPOT: INTEGER; - A: ALFA; - CH: CHAR; - ZAP: BOOLEAN; - -BEGIN - ZAP := TRUE; - IPOT := 10000; - A[1] := ' '; - FOR I := 2 TO 6 DO - BEGIN - CH := CHR(NUM DIV IPOT + ORD('0')); - IF I <> 6 THEN - IF ZAP THEN - IF CH = '0' THEN - CH := ' ' - ELSE - ZAP := FALSE; - A[I] := CH; - NUM := NUM MOD IPOT; - IPOT := IPOT DIV 10; - END; - A[7] := ' '; - MOVELEFT(A, BUF[ORD(BUF[0])+1], 7); - BUF[0] := CHR(ORD(BUF[0]) + 7); -END; - -{$P} -PROCEDURE GETNEXTCHAR; -BEGIN - - IF INLINEP = LENGTH(INPUT_LINE)+1 THEN - BEGIN - CH := ' '; {DUMMY EOL CHARACTER} - INLINEP := INLINEP + 1; {NEXT TIME THRU WILL READ NEW LINE} - EXIT - END; - - IF INLINEP > LENGTH(INPUT_LINE) THEN - BEGIN - READLN(INFILE,INPUT_LINE); - INLINEP := 2; - LINECOUNT := LINECOUNT + 1; - IF LENGTH(INPUT_LINE) > 0 THEN - CH := INPUT_LINE[1] - ELSE - BEGIN - CH := ' '; - IF EOF(INFILE) THEN - ALLDONE := TRUE; - END; - IF LISTING THEN - BEGIN - IF NOT TOCONSOLE THEN - WRITE('.'); - WRITELN(LST,BUF); - BUF[0] := CHR(0); - PUTNUMBER(LINECOUNT); - END - ELSE - WRITE('.'); - IF (LINECOUNT MOD 60) = 0 THEN - BEGIN - IF LISTING THEN - PAGE(LST); - WRITELN('< ',LINECOUNT:4,', ',MEMAVAIL:5,' >'); - END - END - - ELSE - BEGIN - CH := INPUT_LINE[INLINEP]; - INLINEP := INLINEP + 1; - END; - - IF LISTING THEN - BEGIN - BUF[0] := CHR(ORD(BUF[0]) + 1); - BUF[BUF[0]] := CH; - END; - -END; (* GETNEXTCHAR *) - -{$P} - -PROCEDURE SEARCH( ID: ALFA ); (*MODULO P HASH SEARCH*) -(*GLOBAL: T, TOP*) -VAR - I,J,H,D : INTEGER; - X : ITEMPTR; - F : BOOLEAN; - -BEGIN - J := 0; - FOR I := 1 TO ALFALEN DO - J := J*10+ORD(ID[I]); - H := ABS(J) MOD P; - F := FALSE; - D := 1; - REPEAT - IF T[H].KEY = ID THEN - BEGIN (*FOUND*) - F := TRUE; - IF T[H].LAST^.REFNUM = REFSPERITEM THEN - BEGIN - NEW(X); - X^.REFNUM := 1; - X^.REF[1] := LINECOUNT; - T[H].LAST^.NEXT := X; - T[H].LAST := X; - END - ELSE - WITH T[H].LAST^ DO - BEGIN - REFNUM := REFNUM + 1; - REF[REFNUM] := LINECOUNT - END - END - ELSE - IF T[H].KEY = ' ' THEN - BEGIN (*NEW ENTRY*) - F := TRUE; - NEW(X); - X^.REFNUM := 1; - X^.REF[1] := LINECOUNT; - T[H].KEY := ID; - T[H].FIRST := X; - T[H].LAST := X; - T[H].FOL := TOP; - TOP := H - END - ELSE - BEGIN (*COLLISION*) - H := H+D; - D := D+2; - IF H >= P THEN - H := H - P; - IF D = P THEN - BEGIN - WRITELN('ITEM TABLE OVERFLOW'); - ALLDONE := TRUE - END; - END - UNTIL F OR ALLDONE -END (*SEARCH*) ; - -{$P} - -PROCEDURE PRINTWORD(W: WORD); -VAR - L: INTEGER; - X: ITEMPTR; - NEXTREF : INTEGER; - THISREF: NUMREFS; -BEGIN - PUTALFA(W.KEY); - X := W.FIRST; - L := 0; - REPEAT - IF L = REFSPERLINE - THEN - BEGIN - L := 0; - LPWRITELN; - PUTALFA(' '); - END ; - L := L+1; - THISREF := (L-1) MOD REFSPERITEM + 1; - NEXTREF := X^.REF[THISREF]; - IF THISREF = X^.REFNUM THEN - X := NIL - ELSE - IF THISREF = REFSPERITEM THEN - X := X^.NEXT; - PUTNUMBER(NEXTREF); - UNTIL X = NIL; - LPWRITELN; -END (*PRINTWORD*) ; - -{$P} -PROCEDURE PRINTTABLE; - -VAR - I,J,M: INDEX; - -BEGIN - LINECOUNT := 0; - BUF[0] := CHR(0); - I := TOP; - WHILE I <> P DO - BEGIN (*FIND MINIMAL WORD*) - M := I; - J := T[I].FOL; - WHILE J <> P DO - BEGIN - IF T[J].KEY < T[M].KEY THEN - M := J; - J := T[J].FOL - END ; - PRINTWORD(T[M]); - IF M <> I THEN - BEGIN - T[M].KEY := T[I].KEY; - T[M].FIRST := T[I].FIRST; - T[M].LAST := T[I].LAST - END; - I := T[I].FOL - END -END (*PRINTTABLE*) ; - -{$P} -PROCEDURE GETIDENTIFIER; -VAR - J,K,I: INTEGER; - ID: ALFA; - MATCH: BOOLEAN; - -BEGIN (* GETIDENTIFIER *) - I := 0; - ID := ' '; - - REPEAT - IF I < ALFALEN THEN - BEGIN - I := I+1; - IF ('a' <= CH) AND (CH <= 'z') THEN - ID[I] := CHR( ORD(CH) - ORD('a') + ORD('A') ) - ELSE - IF CH = '_' THEN - I := I-1 {DISCARD UNDERSCORE} - ELSE - ID[I] := CH - END; - GETNEXTCHAR - UNTIL NOT (CH IN IDENTSET); - - I := 1; - J := NK; - - REPEAT - K := (I+J) DIV 2; (*BINARY SEARCH*) - IF KEY[K] <= ID THEN - I := K+1; - IF KEY[K] >= ID THEN - J := K-1; - UNTIL (I > J); - - IF KEY[K] <> ID THEN - SEARCH(ID); - -END; (* GETIDENTIFIER *) - -{$P} -BEGIN (* CROSSREF *) - - INITIALIZE; - OPENFILES; - - REPEAT - - IF CH IN IDENTSET THEN - GETIDENTIFIER - - ELSE - IF (CH = '''') THEN {SCAN OFF LITERAL STRING} - BEGIN - REPEAT - GETNEXTCHAR; - UNTIL (CH = '''') OR ALLDONE; - GETNEXTCHAR; - END - - ELSE - IF CH = '(' THEN {SCAN OFF (*...*) COMMENT} - BEGIN {FAILS ON (*)...*) } - GETNEXTCHAR; - IF CH = '*' THEN - BEGIN - GETNEXTCHAR; - WHILE (CH <> ')') AND (NOT ALLDONE) DO - BEGIN - WHILE (CH <> '*') AND (NOT ALLDONE) DO - GETNEXTCHAR; - GETNEXTCHAR; - END; - GETNEXTCHAR; - END; - END - - ELSE - IF CH = '{' THEN (* SCAN OFF {...} COMMENT *) - BEGIN - REPEAT - GETNEXTCHAR - UNTIL (CH = '}') OR ALLDONE; - GETNEXTCHAR; - END - - ELSE - GETNEXTCHAR; - - UNTIL ALLDONE; - - PAGE(LST); - PRINTTABLE; - PAGE(LST); - CLOSE(LST,I); - IF I = 255 THEN - WRITELN('Error closing output file'); - -END. - - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/XREF.SUB b/software/CPM/CPM16_MTPUG_04/XREF.SUB deleted file mode 100644 index 0736b29..0000000 --- a/software/CPM/CPM16_MTPUG_04/XREF.SUB +++ /dev/null @@ -1,3 +0,0 @@ -MTPLUS B:XREF $$TB RB -LINKMT B:XREF,PASLIB/S - \ No newline at end of file diff --git a/software/CPM/CPM16_MTPUG_04/ZCOMPR.PAS b/software/CPM/CPM16_MTPUG_04/ZCOMPR.PAS deleted file mode 100644 index 29fb011..0000000 --- a/software/CPM/CPM16_MTPUG_04/ZCOMPR.PAS +++ /dev/null @@ -1,85 +0,0 @@ -(**************************************************** -* -* CHAR COMPARE PROGRAM -* -* Written by Bob Harsch during a debugging -* excercise. It was done hastily but it was such a -* good idea that I cleaned it and now its part of our -* utilities. -* -* Donated to the Pascal/Z Users Group, Oct 1980 -* Modified by Charlie Foster -***************************************************** -* -* INSTRUCTIONS -* -* The two files that you want to compare need to -* have their names changed to F1.DAT and F2.DAT. Then -* all you have to do is type PCOMPAR. It will go thro -* the entire program and list all differences and list -* those in HEX, DECIMAL and ASCII. The line numbers are -* in reference to 100H. -* -******************************************************) - -PROGRAM COMPAREFILES; - -TYPE BYTE=0..255; - -VAR F1,F2 : FILE OF BYTE; - B1,B2 : BYTE; - COUNT : INTEGER; - - -PROCEDURE HEX(N: INTEGER); - -VAR I : INTEGER; - HEXDIGIT : ARRAY [1..4] OF INTEGER; - -BEGIN - FOR I := 1 TO 4 DO - BEGIN - HEXDIGIT[I] := N MOD 16; - N := N DIV 16 - END; - FOR I:= 4 DOWNTO 1 DO - IF HEXDIGIT[I] > 9 - THEN WRITE(CHR( ORD('A')+HEXDIGIT[I]-10 ):1) - ELSE WRITE(HEXDIGIT[I]:1); - WRITE(' '); -END; (* OF HEX *) - - -FUNCTION CHRCHK(B: BYTE): CHAR; - -BEGIN - IF (B < 32) OR (B > 126) - THEN CHRCHK := '.' - ELSE CHRCHK := CHR(B) -END; (* OF CHRCHK *) - - -BEGIN (* MAIN PROGRAM *) - - RESET('F1.DAT',F1); - RESET('F2.DAT',F2); - WRITELN('HEX-ADDR HEX-B1-B2 DEC-B1-B2 CHR1-CHR2'); - WRITELN('--------------------------------------------'); -COUNT := 256; - REPEAT - READ(F1,B1); - READ(F2,B2); - IF B1 <> B2 THEN - BEGIN - HEX(COUNT); - WRITE(' ':5); - HEX(B1); - HEX(B2); - WRITE(' ',B1:3,' ',B2:3); - WRITE(' ',CHRCHK(B1),' ',CHRCHK(B2)); - WRITELN; - END; - COUNT := COUNT + 1; - UNTIL EOF(F1) OR EOF(F2); -END. - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/-MTPUG.005 b/software/CPM/CPM17_MTPUG_05/-MTPUG.005 deleted file mode 100644 index e69de29..0000000 diff --git a/software/CPM/CPM17_MTPUG_05/-MTPUG.DOC b/software/CPM/CPM17_MTPUG_05/-MTPUG.DOC deleted file mode 100644 index bbca233..0000000 --- a/software/CPM/CPM17_MTPUG_05/-MTPUG.DOC +++ /dev/null @@ -1,26 +0,0 @@ -MTPUG.005 September 25, 1982 - -This disk directory is full, although the disk only contains about -150K of code. Sorry. - -procref/src A simple minded tool which will show you all - /erl the nested procedure/function calls in a - /com program. This is a two pass program, the - /doc second of which prints each line containing of - the saved names anywhere in the line, including - inside comments. Uses two modules included - g2txt which removes two file names from an - input string and opens the first as a text file - and the second as an output text file. The - second is cpmname which checks a name for validity. - written by Steve Clamage. - -Z19/H89/asm A collection of modules for direct cursor addressing - /rel the Zenith Z19 or the Heath H89 terminals. This -Z19LIB/erl group of 26 programs is collected into a library. -External/doc English explanation of each module. -loewner/doc German explanation of each module. - Programs are compiled with the M80/L80 assembler. - (Z80 code, I think). Written by Juergen Loewner. - - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/CEOL.ASM b/software/CPM/CPM17_MTPUG_05/CEOL.ASM deleted file mode 100644 index cf8676b..0000000 --- a/software/CPM/CPM17_MTPUG_05/CEOL.ASM +++ /dev/null @@ -1,9 +0,0 @@ - title @ceol -esc equ 1bh -bdos equ 5 - -ceol:: ld de,cleol ;clear to end of line - ld c,9 - jp bdos -cleol: db esc,'K$' - end diff --git a/software/CPM/CPM17_MTPUG_05/CEOL.REL b/software/CPM/CPM17_MTPUG_05/CEOL.REL deleted file mode 100644 index c8d9e91..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/CEOL.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/CEOP.ASM b/software/CPM/CPM17_MTPUG_05/CEOP.ASM deleted file mode 100644 index 95d1934..0000000 --- a/software/CPM/CPM17_MTPUG_05/CEOP.ASM +++ /dev/null @@ -1,9 +0,0 @@ - title @ceop -esc equ 1bh -bdos equ 5 - -ceop:: ld de,cleop ;clear to end of page - ld c,9 - jp bdos -cleop: db esc,'J$' - end diff --git a/software/CPM/CPM17_MTPUG_05/CEOP.REL b/software/CPM/CPM17_MTPUG_05/CEOP.REL deleted file mode 100644 index 6701ba6..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/CEOP.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/CLS.ASM b/software/CPM/CPM17_MTPUG_05/CLS.ASM deleted file mode 100644 index 43e80a9..0000000 --- a/software/CPM/CPM17_MTPUG_05/CLS.ASM +++ /dev/null @@ -1,11 +0,0 @@ - title @cls - -esc equ 1bh -bdos equ 5 - -cls:: ld de,clearsc ;clear screan - ld c,9 - jp bdos -clearsc:db esc,'E$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/CLS.REL b/software/CPM/CPM17_MTPUG_05/CLS.REL deleted file mode 100644 index 2a255b3..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/CLS.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/CPMNAME.SRC b/software/CPM/CPM17_MTPUG_05/CPMNAME.SRC deleted file mode 100644 index 3079336..0000000 --- a/software/CPM/CPM17_MTPUG_05/CPMNAME.SRC +++ /dev/null @@ -1,80 +0,0 @@ -module tstcpmname; - {Test input string for valid CP/M file name or device} - {by Steve Clamage} - - - function cpmname(fname: string): boolean; - - const - numdevs = 6; {number of defined devices} - - type - devs = 1..numdevs; - devnames = array [devs] of string[4]; - - var - gotdot: boolean; - cname, cext, i, len: integer; - badset: set of char; - devtptr: ^devnames; - - - procedure devname; {table of device names} - - begin {[f-]} - inline( 4/ 'CON:'/ - 4/ 'KBD:'/ - 4/ 'TRM:'/ - 4/ 'LST:'/ - 4/ 'RDR:'/ - 4/ 'PUN:' - ); {[f+]} - end; - - begin {cpmname} - devtptr := addr(devname); - for i := 1 to numdevs do {check for device name} - if fname = devtptr^[i] then - begin - cpmname := true; - exit; {got one, so it's ok} - end; - cpmname := false; {assume the worst} - badset := [' ', '<', '>', ',', ':', '=', '*', '?', '[', ']']; - len := length(fname); - if len = 0 then {zero-length name} - exit; - i := 1; {start with 1st character} - if len > 1 then - if fname[2] = ':' then {if 2nd is colon...} - i := 3; {...start test with 3rd} - gotdot := false; - cname := 0; {# chars in name portion} - while (i <= len) and (not gotdot) do {scan name portion} - begin - if fname[i] = '.' then {period terminates name scan} - gotdot := true - else - begin - cname := cname + 1; - if fname[i] in badset then - exit; {illegal character} - end; - i := i + 1 - end; - cext := 0; {# chars in extent portion} - badset := badset + ['.']; - while (i <= len) do {scan extent portion} - begin - cext := cext + 1; - if fname[i] in badset then - exit; {illegal character} - i := i + 1; - end; - if (cname < 1) or (cname > 8) or (cext > 3) then - exit; {improper length} - cpmname := true; {it's ok!} - end; - -modend . - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/CPOS.ASM b/software/CPM/CPM17_MTPUG_05/CPOS.ASM deleted file mode 100644 index 95f2e9c..0000000 --- a/software/CPM/CPM17_MTPUG_05/CPOS.ASM +++ /dev/null @@ -1,40 +0,0 @@ - title @cpos -esc equ 1bh -bdos equ 5 - -cpos:: pop bc ;return addr - pop de ;e= column - pop hl ;l= line - push bc ;return addr. on stack - xor a - cp e - ret z - cp l - ret z - ld a,80 - cp e - ret c - ld a,25 - cp l - ret c - ld h,e ;now l=line and h=colmn - push hl - ld de,pos1 - ld c,9 - call bdos - pop hl - push hl - ld a,1fh - add a,l - ld e,a - ld c,2 - call bdos - pop hl - ld a,1fh - add a,h - ld e,a - ld c,2 - jp bdos -pos1: db esc,'Y$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/CPOS.REL b/software/CPM/CPM17_MTPUG_05/CPOS.REL deleted file mode 100644 index ee1fb3f..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/CPOS.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/CTOP.ASM b/software/CPM/CPM17_MTPUG_05/CTOP.ASM deleted file mode 100644 index b82cbc5..0000000 --- a/software/CPM/CPM17_MTPUG_05/CTOP.ASM +++ /dev/null @@ -1,10 +0,0 @@ - title @ctop -esc equ 1bh -bdos equ 5 - -ctop:: ld de,cltop ;clear to top of screen - ld c,9 - jp bdos -cltop: db esc,'b$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/CTOP.REL b/software/CPM/CPM17_MTPUG_05/CTOP.REL deleted file mode 100644 index 448f56a..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/CTOP.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/CUOFF.ASM b/software/CPM/CPM17_MTPUG_05/CUOFF.ASM deleted file mode 100644 index ead4e9c..0000000 --- a/software/CPM/CPM17_MTPUG_05/CUOFF.ASM +++ /dev/null @@ -1,12 +0,0 @@ - title @cuoff -esc equ 1bh -bdos equ 5 - -cuoff:: ld de,cuo2 - ld c,9 - jp bdos - dseg -cuo2: db esc,'x5$' - cseg - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/CUOFF.REL b/software/CPM/CPM17_MTPUG_05/CUOFF.REL deleted file mode 100644 index 1ec64e2..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/CUOFF.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/CUON.ASM b/software/CPM/CPM17_MTPUG_05/CUON.ASM deleted file mode 100644 index 4d93508..0000000 --- a/software/CPM/CPM17_MTPUG_05/CUON.ASM +++ /dev/null @@ -1,10 +0,0 @@ - title @cuon -esc equ 1bh -bdos equ 5 - -cuon:: ld de,cuo1 - ld c,9 - jp bdos -cuo1: db esc,'y5$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/CUON.REL b/software/CPM/CPM17_MTPUG_05/CUON.REL deleted file mode 100644 index c5e22f9..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/CUON.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/DATE.ASM b/software/CPM/CPM17_MTPUG_05/DATE.ASM deleted file mode 100644 index a02274c..0000000 --- a/software/CPM/CPM17_MTPUG_05/DATE.ASM +++ /dev/null @@ -1,48 +0,0 @@ - title @date - -date:: pop ix ;save return addr. - ld bc,3000h+'.' ;preset for "or '0'" and save '.' - pop hl ;get addr. of var - ld (hl),10 ;save length in var[0] - inc hl ;and start transfer of data - in a,(0e8h) ;day10 - and 03h ;0,1,2 or 3 - or b ;get ascii - ld (hl),a ;save it - inc hl ;for the next val - in a,(0e7h) ;and go on for the other's - and 0fh - or b - ld (hl),a - inc hl - ld (hl),c ;put '.' in string - inc hl - in a,(0eah) - and 01h - or b - lä (hl),a - inc hl - in a,(0e9h) - and 0fh - or b - ld (hl),a - inc hl - ld (hl),c - inc hl - ld (hl),'1' - inc hl - ld (hl),'9' - inc hl - in a,(0ech) - and 0fh - or b - ld (hl),a - inc hl - in a,(0ebh) - and 0fh - or b - ld (hl),a - jp (ix) ;this means RETURN (popped before) - - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/DATE.REL b/software/CPM/CPM17_MTPUG_05/DATE.REL deleted file mode 100644 index c94898e..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/DATE.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/DAY.ASM b/software/CPM/CPM17_MTPUG_05/DAY.ASM deleted file mode 100644 index 8788616..0000000 --- a/software/CPM/CPM17_MTPUG_05/DAY.ASM +++ /dev/null @@ -1,50 +0,0 @@ - title @day - -day:: pop ix ;RETURN - pop hl ;get var addr. - in a,(0e6h) ;get day of week - and 7 - cp 7 - jr nc,error ;in range? - push hl ;need hl for computing - add a,a ;double the value and clear carry - ld hl,table - ld d,0 - ld e,a - add hl,de - ld a,(hl) - inc hl - ld h,(hl) - ld l,a - pop de ;get again var addr.= destination - ld b,0 - ld c,(hl) ;get length - inc c ;transfer length is stringlength+1 - ldir ;and transfer - jp (ix) ;we are ready - - -error: ld (hl),0 ;stringlength set to 0 - jp (ix) ;ret - - -table: dw mo - dw di - dw mi - dw do - dw fr - dw sa - dw so - -mo: db 6,'Montag' -di: db 8,'Dienstag' -mi: db 8,'Mittwoch' -do: db 9,'Donnerstag' -fr: db 7,'Freitag' -sa: db 7,'Samstag' -so: db 7,'Sonntag' - - - - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/DAY.REL b/software/CPM/CPM17_MTPUG_05/DAY.REL deleted file mode 100644 index 66c11b1..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/DAY.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/DC.ASM b/software/CPM/CPM17_MTPUG_05/DC.ASM deleted file mode 100644 index 0fdd9c3..0000000 --- a/software/CPM/CPM17_MTPUG_05/DC.ASM +++ /dev/null @@ -1,10 +0,0 @@ - title @dc -esc equ 1bh -bdos equ 5 - -dc:: ld de,ddc ;DELETE character - ld c,9 - jp bdos -ddc: db esc,'N$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/DC.REL b/software/CPM/CPM17_MTPUG_05/DC.REL deleted file mode 100644 index 3e87828..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/DC.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/DL.ASM b/software/CPM/CPM17_MTPUG_05/DL.ASM deleted file mode 100644 index b4425ba..0000000 --- a/software/CPM/CPM17_MTPUG_05/DL.ASM +++ /dev/null @@ -1,10 +0,0 @@ - title @dl -esc equ 1bh -bdos equ 5 - -dl:: ld de,ddl ;DELETE line - ld c,9 - jp bdos -ddl: db esc,'M$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/DL.REL b/software/CPM/CPM17_MTPUG_05/DL.REL deleted file mode 100644 index 2b793f2..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/DL.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/EBL.ASM b/software/CPM/CPM17_MTPUG_05/EBL.ASM deleted file mode 100644 index 1ef5338..0000000 --- a/software/CPM/CPM17_MTPUG_05/EBL.ASM +++ /dev/null @@ -1,10 +0,0 @@ - title @ebl -esc equ 1bh -bdos equ 5 - -ebl:: ld de,erbl ;erase to begin of line - ld c,9 - jp bdos -erbl: db esc,'o$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/EBL.REL b/software/CPM/CPM17_MTPUG_05/EBL.REL deleted file mode 100644 index c4b0d6a..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/EBL.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/ERASEL.ASM b/software/CPM/CPM17_MTPUG_05/ERASEL.ASM deleted file mode 100644 index 0a2ef9b..0000000 --- a/software/CPM/CPM17_MTPUG_05/ERASEL.ASM +++ /dev/null @@ -1,10 +0,0 @@ - title @erasl -esc equ 1bh -bdos equ 5 - -erasel::ld de,edl ;erase entire line - ld c,9 - jp bdos -edl: db esc,'l$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/ERASEL.REL b/software/CPM/CPM17_MTPUG_05/ERASEL.REL deleted file mode 100644 index 2215443..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/ERASEL.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/EXTERNAL.DOC b/software/CPM/CPM17_MTPUG_05/EXTERNAL.DOC deleted file mode 100644 index 067fa45..0000000 --- a/software/CPM/CPM17_MTPUG_05/EXTERNAL.DOC +++ /dev/null @@ -1,113 +0,0 @@ -Comments on Juergen Loewner's procedures "MT+ Pascal Library Extensions" - -The following procedures are implemented for the Heath H19 terminal. -As clock IC the MSM 5832 from OKI was taken. The Microsoft M80/L80 -assembler/linker was used. -%U - procedure CPOS (line,column); - Positioning of the cursor. - - procedure HOME; - The cursor will be positioned to the upper left corner. - - procedure CLS; - Clear screen and set cursor to the "home" position. - - procedure CEOP; - Clear screen from cursor up to the end of the screen; - the character under the cursor will be deleted. - - procedure CTOP; - Clear screen from "home" to cursor position; the - character under the cursor will be also deleted. - - procedure CEOL; - Clear screen from "home" up to the cursor; the character - under the cursor will be also deleted. - - procedure IL; - Insert one line at "cursor line"; the following lines - are scrolled down. The last line (24) will be deleted. - - procedure DL; - Delete "cursor line"; the following lines are scrolled - up. - - procedure DC; - Delete the character at the cursor position; the following - characters of this line are shifted one character to the - left. - - procedure SAVEC; - The procedure saves the cursor position (line and column). - Later on it will be possible to return to this column by - calling "RESTC". - - procedure RESTC; - Position the cursor to the line/column which was saved - by the last call of SAVEC. - - procedure ERASEL; - Clears cursor line (without scrolling the rest of the - screen). - - procedure KBOFF; - The keyboard is switched off (no input will be possible - by it); see also KBON. -.PA - procedure KBON; - The keyboard is switched on (necessary if KBOFF was - was called). - - procedure EBL; - Clear line from the beginning of the line to the cursor; - thecharacter under the cursor is included. - - procedure CUOFF; - The cursor will be switched off; see also CUON. - - procedure CUON; - The cursor will be switched on (necessary if CUON - was called). - - procedure ON25; - Enables an entry into the status line (line 25). - - procedure OFF25; - Delete status line (line 25); furtheron an access - to the status line will not be possible; see ON25. - - procedure TIME (var X: string); - A string of the length 8 will be assigned to the - variable X: "hh:mm:ss". - - procedure DATE (var X: string); - A string of the length 10 will be assigned to the - variable X: "dd.mm.19yy". - - procedure DAY (var X: string); - A string of variable length will be assigned to the - variable X; the string contains the German day of - week. - - procedure IC; - Switches on "insert character" mode: - Insert one character at the cursor position and shift - the rest of the line one character to the right. - Positiob 80 will be deleted. - - procedure XIC; - Switch off the "IC-mode". - - procedure REVON; - The following characters will be output on the screen - in "inverse-mode" (black on white); see also REVOFF. - - procedure REVOFF; - Return from "inverse-mode" to "standard-mode". - - - -rse-mode" (black on white); see also REVOFF. - - pr \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/G2TEXT.ERL b/software/CPM/CPM17_MTPUG_05/G2TEXT.ERL deleted file mode 100644 index ec60dac..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/G2TEXT.ERL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/G2TEXT.SRC b/software/CPM/CPM17_MTPUG_05/G2TEXT.SRC deleted file mode 100644 index 943a4a2..0000000 --- a/software/CPM/CPM17_MTPUG_05/G2TEXT.SRC +++ /dev/null @@ -1,71 +0,0 @@ -{Purpose: Remove two file names from input string, open first } -{ as input text file, second as output text file } -{Input: string containing two file names separated by blank(s)} -{ two file descriptors of type TEXT } -{Output: first two names are removed from string } -{ fin and fout are initialized } -{Return: TRUE if both files opened succesfully, else FALSE } - -module get2text; - - external function cpmname(st: string): boolean; - - - function g2text(var str: string; - var fin, fout: text): boolean; - - var - name: string; - ch: char; - - - procedure gname; - - var - i: integer; - - begin {gname} - name := ''; - i := 1; - while (i <= length(str)) and (str[i] = ' ') do - i := i + 1; {skip leading blanks} - while (i <= length(str)) and (str[i] <> ' ') do - begin {copy up to next blank} - ch := str[i]; - i := i + 1; - if ch in ['a'..'z'] then - ch := chr(ord(ch) - $20); {ensure upper case} - name := concat(name, ch); - end; - if i > 1 then {remove name} - delete(str, 1, i - 1); - end; {gname} - - begin {g2text} - g2text := false; {assume the worst} - gname; {get input file name} - assign(fin, name); - reset(fin); - if ioresult = 255 then - begin - writeln('Unable to open ', name, ' for input'); - exit - end; - gname; {get output file name} - if not cpmname(name) then - begin - writeln('Illegal CP/M name: ', name); - exit - end; - assign(fout, name); - rewrite(fout); - if ioresult = 255 then - begin - writeln('Unable to open ', name, ' for output'); - exit - end; - g2text := true - end; - -modend . - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/HOME.ASM b/software/CPM/CPM17_MTPUG_05/HOME.ASM deleted file mode 100644 index 8a36c51..0000000 --- a/software/CPM/CPM17_MTPUG_05/HOME.ASM +++ /dev/null @@ -1,11 +0,0 @@ - title @home -esc equ 1bh -bdos equ 5 - - -home:: ld de,hom ;cursor home - ld c,9 - jp bdos -hom: db esc,'H$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/HOME.REL b/software/CPM/CPM17_MTPUG_05/HOME.REL deleted file mode 100644 index 301ae1d..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/HOME.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/IC.ASM b/software/CPM/CPM17_MTPUG_05/IC.ASM deleted file mode 100644 index ce99d16..0000000 --- a/software/CPM/CPM17_MTPUG_05/IC.ASM +++ /dev/null @@ -1,11 +0,0 @@ - title @ic -esc equ 1bh -bdos equ 5 - - -ic:: ld de,inc ;cursor home - ld c,9 - jp bdos -inc: db esc,'@$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/IC.REL b/software/CPM/CPM17_MTPUG_05/IC.REL deleted file mode 100644 index 30b4e83..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/IC.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/IL.ASM b/software/CPM/CPM17_MTPUG_05/IL.ASM deleted file mode 100644 index 489f186..0000000 --- a/software/CPM/CPM17_MTPUG_05/IL.ASM +++ /dev/null @@ -1,10 +0,0 @@ - title @il -esc equ 1bh -bdos equ 5 - -il:: ld de,iil ;INSERT line - ld c,9 - jp bdos -iil: db esc,'L$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/IL.REL b/software/CPM/CPM17_MTPUG_05/IL.REL deleted file mode 100644 index 80c492a..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/IL.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/KBOFF.ASM b/software/CPM/CPM17_MTPUG_05/KBOFF.ASM deleted file mode 100644 index e75fb5d..0000000 --- a/software/CPM/CPM17_MTPUG_05/KBOFF.ASM +++ /dev/null @@ -1,10 +0,0 @@ - title @kboff -esc equ 1bh -bdos equ 5 - -kboff:: ld de,kb2 ;keayboard off - ld c,9 - jp bdos -kb2: db esc,'}$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/KBOFF.REL b/software/CPM/CPM17_MTPUG_05/KBOFF.REL deleted file mode 100644 index 7930842..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/KBOFF.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/KBON.ASM b/software/CPM/CPM17_MTPUG_05/KBON.ASM deleted file mode 100644 index 95fff5a..0000000 --- a/software/CPM/CPM17_MTPUG_05/KBON.ASM +++ /dev/null @@ -1,10 +0,0 @@ - title @kbon -esc equ 1bh -bdos equ 5 - -kbon:: ld de,kb1 ;keyboard on - ld c,9 - jp bdos -kb1: db esc,'{$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/KBON.REL b/software/CPM/CPM17_MTPUG_05/KBON.REL deleted file mode 100644 index c6db6fe..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/KBON.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/LOEWNER.DOC b/software/CPM/CPM17_MTPUG_05/LOEWNER.DOC deleted file mode 100644 index fb9dae6..0000000 --- a/software/CPM/CPM17_MTPUG_05/LOEWNER.DOC +++ /dev/null @@ -1,135 +0,0 @@ -\cmd` -`formfeed off,draft,lm5,rm70,pl72 -`tm2,bm5 - - - `out14,27,69`MT+ Pascal Library Extension : - `out14`============================== -`out27,70` - - -procedure `out14`cpos`out20`(zeile,spalte); - Cursor Positionierung - - -procedure `out14`home`out20`; - Cursor wird in die linke obere Ecke gesetzt - - -procedure `out14`cls`out20`; - L|scht den Bildschirm und setzt den Cursor in die linke obere - Ecke - - -procedure `out14`ceop`out20`; - L|scht den Bildschirm bis zum Ende, inkl. Cursor Position - - -procedure `out14`ctop`out20`; - L|scht den Bildschirm bis zum Anfang, inkl. Cursor Position - - -procedure `out14`ceol`out20`; - L|scht die Zeile bis zum Ende, inkl. Cursor Position - - -procedure `out14`il`out20`; - F}gt eine Zeile in H|he der Cursor-Position ein, dabei werden - die nachfolgenden Zeilen um eine Zeile nach unten ger}ckt und - eventuell dabei die letzte Zeile gel|scht - - -procedure `out14`dl`out20`; - L|scht die Zeile in der der Cursor ist und r}ckt die - nachfolgenden Zeilen auf - - -procedure `out14`dc`out20`; - L|scht das Zeichen, auf dem der Cursor steht und l{~t den Rest - der Zeile von rechts aufr}cken - - -procedure `out14`savec`out20`; - Das Terminal merkt sich die Cursorposition, um sp{ter durch - ein "_restc_" an diese Position wieder zur}ckzukehren - - -procedure `out14`restc`out20`; - Das Terminal positioniert den Cursor an die Stelle auf dem - Bildschirm, die sich durch die "procedure _savec_" gemerkt - wurde - - -procedure `out14`erasel`out20`; - L|scht die gesamte Zeile, in der der Cursor steht, ohne - aufr}cken - - -`np`procedure `out14`kboff`out20`; - Schaltet die Tastatur aus, so da~ keine weitere Eingabe mehr - m|glich ist (siehe kbon) - - -procedure `out14`kbon`out20`; - Schaltet die Tastatur nach einem "_kboff_" wieder ein - - -procedure `out14`ebl`out20`; - L|scht die Zeile vom Beginn der Zeile bis zum Cursor (inkl.) - - -procedure `out14`cuoff`out20`; - Schaltet den Cursor aus - - -procedure `out14`cuon`out20`; - Schaltet den Cursor wieder ein - - -procedure `out14`on25`out20`; - Erm|glicht den Zugang zur Status- (25.) Zeile - - -procedure `out14`off25`out20`; - L|scht die 25. Zeile (Statuszeile) und ein weiterer Zugriff - auf diese ist bis auf ein weiteres "_on25_" Kommando nicht - m|glich - - -procedure `out14`time`out20`(var x:string); - Die Variable "x" bekommt einen String der L{nge 8 in der Form - "hh:mm:ss" zugewiesen - - -procedure `out14`date`out20`(var x:string); - Die Variable "x" bekommt einen String der L{nge 10 in der Form - "dd.mm.19yy" zugewiesen - - -procedure `out14`day`out20`(var x:string); - Die Variable "x" bekommt einen String variabler L{nge mit dem - deutschen Text des Wochentages zugewiesen - - -procedure `out14`ic`out20`; - F}gt ein Zeichen an der Cursorposition ein und l{~t den rest - der Zeile (inkl. Cursorpos.) nach rechts r}cken. Evtl. in der - 80. Spalte vorhandene Zeichen gehen verloren - - -procedure `out14`xic`out20`; - Schaltet den "_ic_" -modus aus; - - -procedure `out14`revon`out20`; - Von nun an werden die Zeichen 'invertiert' (wei~ auf schwarz) - geschrieben - - -procedure `out14`revoff`out20`; - Die Zeichen werden nun nach einem "_revon_" wieder normal - (wei~ auf schwarz) geschrieben - - -cedure `out14`revoff`out20`; - Die Zeichen werden nun nach einem "_revon_" wieder norm \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/OFF25.ASM b/software/CPM/CPM17_MTPUG_05/OFF25.ASM deleted file mode 100644 index a2a2342..0000000 --- a/software/CPM/CPM17_MTPUG_05/OFF25.ASM +++ /dev/null @@ -1,12 +0,0 @@ - title @off25 -esc equ 1bh -bdos equ 5 - -off25:: ld de,o2 - ld c,9 - jp bdos -o2: db esc,'y1$' - - end - - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/OFF25.REL b/software/CPM/CPM17_MTPUG_05/OFF25.REL deleted file mode 100644 index 2879205..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/OFF25.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/ON25.ASM b/software/CPM/CPM17_MTPUG_05/ON25.ASM deleted file mode 100644 index d858202..0000000 --- a/software/CPM/CPM17_MTPUG_05/ON25.ASM +++ /dev/null @@ -1,10 +0,0 @@ - title @on25 -esc equ 1bh -bdos equ 5 - -on25:: ld de,o1 - ld c,9 - jp bdos -o1: db esc,'x1$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/ON25.REL b/software/CPM/CPM17_MTPUG_05/ON25.REL deleted file mode 100644 index b0b084e..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/ON25.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/PROCREF.COM b/software/CPM/CPM17_MTPUG_05/PROCREF.COM deleted file mode 100644 index 7e3322c..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/PROCREF.COM and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/PROCREF.ERL b/software/CPM/CPM17_MTPUG_05/PROCREF.ERL deleted file mode 100644 index 830c49d..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/PROCREF.ERL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/PROCREF.SRC b/software/CPM/CPM17_MTPUG_05/PROCREF.SRC deleted file mode 100644 index fb97784..0000000 --- a/software/CPM/CPM17_MTPUG_05/PROCREF.SRC +++ /dev/null @@ -1,191 +0,0 @@ -{Produce a listing of procedure calls -- who calls whom} -program procref; - - type - wordtype = string[8]; - itemp = ^item; - item = - record - w: wordtype; - left, right: itemp; - end; - strptr = ^string; - - var - idstart, idset: set of char; - word: wordtype; - line: string[132]; - lptr: integer; - fin, fout: text; - t: itemp; - strp: strptr; - lower: array [char] of char; - done: boolean; - fresult: integer; - - external function g2text(var str: string; - var inf, outf: text): boolean; - external function @cmd: strptr; - - - procedure getword; - - var - wlen: integer; - ch: char; - - begin {get a word from input line} - wlen := 0; - word := ''; - while (lptr <= length(line)) and (not (line[lptr] in idstart)) do - lptr := lptr + 1; {scan to first identifier} - while (lptr <= length(line)) and (line[lptr] in idset) do - begin {copy identifier} - ch := lower[line[lptr]]; {uniform case} - if (ch <> '_') and (wlen < 8) then - begin {omit underscore, stop at 8 chars} - wlen := wlen + 1; - word[wlen] := ch - end; - lptr := lptr + 1; - end; - word[0] := chr(wlen); {update word length} - end; {getword} - - - procedure init; - - var - i: char; - - begin {initialize variables} - idstart := ['A'..'Z', 'a'..'z', '@', '_']; - idset := idstart + ['0'..'9']; - for i := chr(0) to chr(127) do - lower[i] := i; - for i := 'A' to 'Z' do - lower[i] := chr(ord(i) + $20); - t := nil; - end; {init} - - - procedure saveword; - - var - x, y: itemp; - found, less: boolean; - - begin {search for word in binary tree, add it if not already there} - if t = nil then - begin {first entry} - new(t); - t^.w := word; - t^.left := nil; - t^.right := nil; - end - else - begin {all subsequent entries} - x := t; - found := false; - while (x <> nil) and (not found) do - begin - y := x; {previous entry} - if word < x^.w then {search left subtree} - begin - x := x^.left; - less := true - end - else if word > x^.w then {search right subtree} - begin - x := x^.right; - less := false - end - else {got it} - found := true - end; - if not found then - begin - new(x); - if less then - y^.left := x - else - y^.right := x; - x^.w := word; - x^.left := nil; - x^.right := nil; - end; - end; - end; {saveword} - - - function is_saved: boolean; - - var - x: itemp; - found: boolean; - - begin {determine whether word is in binary tree} - found := false; - x := t; - while (x <> nil) and (not found) do - if word < x^.w then - x := x^.left - else if word > x^.w then - x := x^.right - else - found := true; - is_saved := found - end; {is_saved} - - begin {procref} - strp := @cmd; {get commmand line} - line := strp^; - if not g2text(line, fin, fout) then - exit; {open files if possible} - init; - while not eof(fin) do - begin - readln(fin, line); - lptr := 1; - getword; - if word = 'external' then - getword; - if (word = 'procedur') or (word = 'function') or - (word = 'program') then - begin - getword; - saveword - end; - end; - - writeln('End of pass 1'); - - reset(fin); - if ioresult = 255 then - begin - writeln('Unable to reset input file'); - exit - end; - while not eof(fin) do - begin - readln(fin, line); - lptr := 1; - getword; - done := false; - while (length(word) > 0) and (not done) do - begin - if is_saved then - begin - writeln(fout, line); - done := true - end - else - getword - end - end; - close(fout, fresult); - if fresult = 255 then - writeln('Unable to close output file'); - - end {procref} . - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/RESTC.ASM b/software/CPM/CPM17_MTPUG_05/RESTC.ASM deleted file mode 100644 index aebdc12..0000000 --- a/software/CPM/CPM17_MTPUG_05/RESTC.ASM +++ /dev/null @@ -1,10 +0,0 @@ - title @restc -esc equ 1bh -bdos equ 5 - -restc:: ld de,rest ;restore cursor - ld c,9 - jp bdos -rest: db esc,'k$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/RESTC.REL b/software/CPM/CPM17_MTPUG_05/RESTC.REL deleted file mode 100644 index 3449861..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/RESTC.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/REVOFF.ASM b/software/CPM/CPM17_MTPUG_05/REVOFF.ASM deleted file mode 100644 index 45da185..0000000 --- a/software/CPM/CPM17_MTPUG_05/REVOFF.ASM +++ /dev/null @@ -1,11 +0,0 @@ - title @revof -esc equ 1bh -bdos equ 5 - - -revoff::ld de,xrev ;cursor home - ld c,9 - jp bdos -xrev: db esc,'q$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/REVOFF.REL b/software/CPM/CPM17_MTPUG_05/REVOFF.REL deleted file mode 100644 index 9551a3b..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/REVOFF.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/REVON.ASM b/software/CPM/CPM17_MTPUG_05/REVON.ASM deleted file mode 100644 index 85dc7b8..0000000 --- a/software/CPM/CPM17_MTPUG_05/REVON.ASM +++ /dev/null @@ -1,11 +0,0 @@ - title @revon -esc equ 1bh -bdos equ 5 - - -revon:: ld de,rev ;cursor home - ld c,9 - jp bdos -rev: db esc,'p$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/REVON.REL b/software/CPM/CPM17_MTPUG_05/REVON.REL deleted file mode 100644 index 1c4c34a..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/REVON.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/SAVEC.ASM b/software/CPM/CPM17_MTPUG_05/SAVEC.ASM deleted file mode 100644 index 134a837..0000000 --- a/software/CPM/CPM17_MTPUG_05/SAVEC.ASM +++ /dev/null @@ -1,10 +0,0 @@ - title @savec -esc equ 1bh -bdos equ 5 - -savec:: ld de,sve ;save cursor - ld c,9 - jp bdos -sve: db esc,'j$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/SAVEC.REL b/software/CPM/CPM17_MTPUG_05/SAVEC.REL deleted file mode 100644 index 02a6c92..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/SAVEC.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/TIME.ASM b/software/CPM/CPM17_MTPUG_05/TIME.ASM deleted file mode 100644 index 6007138..0000000 --- a/software/CPM/CPM17_MTPUG_05/TIME.ASM +++ /dev/null @@ -1,45 +0,0 @@ - title @time - -time:: pop ix ;save return addr. - ld bc,3000h+':' ;preset for "or '0'" and save ':' - pop hl ;get addr. of var - ld (hl),8 ;save length in var[0] - inc hl ;and start transfer of data - in a,(0e5h) ;h10 - and 03h ;0,1 or 2 - or b ;get ascii - ld (hl),a ;save it - inc hl ;for the next val - in a,(0e4h) ;and go on for the other's - and 0fh - or b - ld (hl),a - inc hl - ld (hl),c ;put ':' in string - inc hl - in a,(0e3h) - and 07h - or b - lä (hl),a - inc hl - in a,(0e2h) - and 0fh - or b - ld (hl),a - inc hl - ld (hl),c - inc hl - in a,(0e1h) - and 07h - or b - ld (hl),a - inc hl - in a,(0e0h) - and 0fh - or b - ld (hl),a - jp (ix) ;this means RETURN (popped before) - - end - - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/TIME.REL b/software/CPM/CPM17_MTPUG_05/TIME.REL deleted file mode 100644 index 9470413..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/TIME.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/XIC.ASM b/software/CPM/CPM17_MTPUG_05/XIC.ASM deleted file mode 100644 index fc36412..0000000 --- a/software/CPM/CPM17_MTPUG_05/XIC.ASM +++ /dev/null @@ -1,11 +0,0 @@ - title @xic -esc equ 1bh -bdos equ 5 - - -xic:: ld de,xinc ;cursor home - ld c,9 - jp bdos -xinc: db esc,'O$' - end - \ No newline at end of file diff --git a/software/CPM/CPM17_MTPUG_05/XIC.REL b/software/CPM/CPM17_MTPUG_05/XIC.REL deleted file mode 100644 index 40484c9..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/XIC.REL and /dev/null differ diff --git a/software/CPM/CPM17_MTPUG_05/Z19LIB.ERL b/software/CPM/CPM17_MTPUG_05/Z19LIB.ERL deleted file mode 100644 index 3ad7468..0000000 Binary files a/software/CPM/CPM17_MTPUG_05/Z19LIB.ERL and /dev/null differ diff --git a/software/CPM/CPM18_MTPUG_06/-MTPUG.006 b/software/CPM/CPM18_MTPUG_06/-MTPUG.006 deleted file mode 100644 index e69de29..0000000 diff --git a/software/CPM/CPM18_MTPUG_06/-MTPUG.DOC b/software/CPM/CPM18_MTPUG_06/-MTPUG.DOC deleted file mode 100644 index eed06b7..0000000 --- a/software/CPM/CPM18_MTPUG_06/-MTPUG.DOC +++ /dev/null @@ -1,141 +0,0 @@ -**** MTPUG.006 **** October 15, 1982 - -Until noted otherwise, the following were written by Allen Miller -and appear in the book entitled "Pascal Programs For Scientists -And Engineers" which is published by Sybex. -They were submitted to this users Group by Juergen Loewner, -D-4400 Muenster, Hoher Heckenweg 3, West Germany - -MEANS.PAS: This file computes the mean and the standard - deviation of a set of numbers. - -RANDOM.LIB: A random generator (0..1). - -RANDG.LIB: A random generator with gaussian distribution. - -MATR1.PAS: A matrix multiplication program. - -DETERM.PAS: A program to calculate the determinant of a 3x3 - matrix. - -SIMPQ1.PAS: A program to solve three simultaneous equations. - -GAUSS.PAS: A program to perform simultaneous solution by - Gaussian elimination. - -SOLVGJ.PAS: same as above but Gauss-Jordan algorithm. - -GAUSSJ.LIB: Gauss-Jordan matrix inversion and solution. - -SOLVGV.PAS: A program to perform simultan. sol. by Gauss- - Jordan elimination with (mult.) const. vect. - -SOLVGJ2.PAS: A program to perform simult. solution when using - more equations than unknowns (by Gauss-Jordan - elimination). - -SOLVEC.PAS: A program to perform simultaneous solution for - complex coefficients. - -GAUSID.PAS: A program to perform simult. sol. by Gauss-Seidel. - -CFIT1.PAS: A program to perform a linear least-squares curve- - fit. - -CFIT1a.PAS: same as above but with a random generator. - -PLOT.LIB: A (printer-) plotter subroutine. - -CFIT2.PAS: A plotting program using PLOT.LIB. - -LINFIT1.LIB: A program which fits a straight line through n - sets of x and y pairs of points. - -LINFIT2.LIB: Another example of the above prog. - -CFIT4.PAS: A linear least-squares fit program. - -TSTSORT.PAS: A Bubble-sort. - -SORT-B.LIB: A variation of the above prog. - -SORT-S.LIB: A Shell-sort procedure. - -SORT-Q-S.LIB: A recursive Quick-sort. - -SORT-Q-N.LIB: A nonrecursive of Quick-sort. - -LEAST1.PAS: A program to perform a linear least-squares fit. - -LEAST2.PAS: As above but now with Gauss-Jordan procedure. - -LEAST3.PAS: A variation of LEAST2. - -GD-LINF1.LIB: and -GD-LINF2.LIB: and -LEAST6.PAS: are variationes with different problems. - -NEWDR.PAS: A program to solve equations by Newtons method. - -NEWDR2.PAS: Another version of the program above. - -NEWTON.LIB: The Newton program for a library. - -NEWTON-L.LIB: The Newton program with an iteration counter. - -TRAP1.PAS: A program for integrations by the trapezoidal - rule. - -TRAP2.PAS: Another better version of the above. - -TRAPEZ.LIB: Another improved version with end-correction. - -SIMP1.PAS: Another integration program now by Simpson's rule. - -SIMPS.LIB: Simp1.pas as a procedure and with end-correction. - -ROMB1.PAS: Last not least a integration program by the - Romberg method. - -ROMB3.PAS: As above but now with adjustable panels. - -FITPOL.PAS: A program to perform linear least-squares fit to - the ratio of 2 polynomals. - -DIFFUS.PAS: An example of the above: diffuson of Zn in Cu. - (A least squares fit to the linearized e-function) - -NLIN3.PAS: Same as above but now with a nonlinearized - e-function. - -ERFSIMP.PAS: The Gaussian Error Function by Simpson's rule. - -ERFD.PAS: An infinite series expansion for the Gaussian - error function. - -ERFD3.PAS: The Gaussian error function and its complement. - -ERF4.PAS: An improved Gaussian error function. - -TSTGAM.PAS: A program to test the Gamma function - -TSTBES.PAS: A program to test the Bessel function - -BESY.PAS: An evaluation of the Bessel function of the 2nd - kind. - -RANDOM.PAS: Another random generator. - -Following programs by Peter Hochstrasser. - -CURSOR.MAC Cursor positioning and semigraphics procedures - .ERL for VT-52 type terminals like the VISUAL 200. - Assembled with M80 .Z80 option. Uses direct calls - to CP/M conout function for speed. NO error checking. - -CURSOR2.SRC GoToXY function - -TERMINAL.IF External Procedure declarations needed in Main program. - .ERL Terminal library - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/BESY.PAS b/software/CPM/CPM18_MTPUG_06/BESY.PAS deleted file mode 100644 index d9670d3..0000000 --- a/software/CPM/CPM18_MTPUG_06/BESY.PAS +++ /dev/null @@ -1,91 +0,0 @@ -program besy; { -> 348 } -{ evaluation of Bessel function of the second kind } - -var x,ordr : real; - done : boolean; - -external procedure cls; - -function bessy(x,n: real): real; -{ cylindical bessel function of the second kind } -const small = 1.0E-8; - euler = 0.57721566; - pi = 3.1415926; - pi2 = 0.63661977; { 2/pi } -var j : integer; - - x2,sum,sum2,t,t2, - ts,term,xx,y0,y1, - ya,yb,yc,ans,a,b, - sina,cosa : real; - -begin { function bessy } - if x<12 then - begin - xx:=0.5*x; - x2:=xx*xx; - t:=ln(xx)+euler; - sum:=0.0; - term:=t; - y0:=t; - j:=0; - repeat - j:=j+1; - if j<>1 then sum:=sum+1/(j-1); - ts:=t-sum; - term:=-x2*term/(j*j)*(1-1/(j*ts)); - y0:=y0+term - until abs(term)11, asymtotic expansion } - bessy:=sqrt(2/(pi*x))*sin(x-pi/4-n*pi/2) -end; { function bessy } - -begin - cls; - done:=false; - writeln; - repeat - write('Order? '); - readln(ordr); - if ordr<0.0 then done:=true - else - begin - repeat - write('Arg? '); - readln(x) - until x>=0.0; - writeln('Y Bessel is ',bessy(x,ordr)) - end { if } - until done -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/CFIT1.PAS b/software/CPM/CPM18_MTPUG_06/CFIT1.PAS deleted file mode 100644 index 327e554..0000000 --- a/software/CPM/CPM18_MTPUG_06/CFIT1.PAS +++ /dev/null @@ -1,77 +0,0 @@ -program cfit1; { -> 139 } -{ Pascal program to perform a linear least-squares fit } - -const max = 20; - -type index = 1..max; - ary = array[index] of real; - -var x,y,y_calc : ary; - n : integer; - first,done : boolean; - seed,a,b : real; - -external procedure cls; - -{$I RANDOM.LIB } - -procedure get_data(var x,y: ary; - var n: integer); -{ get values for n and arrays x,y } -{ y is randomly scattered about a straight line } - -const a = 2.0; - b = 5.0; - -var i,j : integer; - fudge : real; - -begin - write('Fudge? '); - readln(fudge); - if fudge<0.0 then done:=true - else - begin - repeat - write('How many points? '); - readln(n) - until (n>2) and (n<=max); - if first then first:=false else cls; - - for i:=1 to n do - begin - j:=n+1-i; - x[i]:=j; - y[i]:=(a+b*j)*(1.0+(2.0*random(0)-1.0)*fudge) - end { for-loop } - end { if } -end; { procedure get_data } - - -procedure write_data; -{ print out the answers } -var i : integer; - -begin - writeln; - writeln(' I X Y'); - for i:=1 to n do - writeln(i:3,x[i]:8:1,y[i]:9:2); - writeln -end; { write_data } - -begin { MAIN program } - first:=true; - seed:=4.0; - cls; - done:=false; - repeat - get_data(x,y,n); - if not done then - begin - write_data; - { ***** ---> more lines to be added here ********* } - end - until done -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/CFIT1A.PAS b/software/CPM/CPM18_MTPUG_06/CFIT1A.PAS deleted file mode 100644 index 71f5e09..0000000 --- a/software/CPM/CPM18_MTPUG_06/CFIT1A.PAS +++ /dev/null @@ -1,92 +0,0 @@ -program cfit1A; { -> 142 } -{ Pascal program to perform a linear least-squares fit } - -const max = 20; - -type index = 1..max; - ary = array[index] of real; - -var x,y,y_calc : ary; - n : integer; - first,done : boolean; - seed,a,b : real; - -external procedure cls; - -function random(dummy: integer): real; -{ random number 0-1 } -{ define seed=4.0 as global } - -const pi = 3.14159; - -var x : real; - i : integer; - -begin { RANDOM } - x:=seed+pi; - x:=exp(5.0*ln(x)); - seed:=x-trunc(x); - random:=seed -end; { RANDOM } - - - -procedure get_data(var x,y: ary; - var n: integer); -{ get values for n and arrays x,y } -{ y is randomly scattered about a straight line } - -const a = 2.0; - b = 5.0; - -var i,j : integer; - fudge : real; - -begin - write('Fudge? '); - readln(fudge); - if fudge<0.0 then done:=true - else - begin - repeat - write('How many points? '); - readln(n) - until (n>2) and (n<=max); - if first then first:=false else cls; - for i:=1 to n do - begin - j:=n+1-i; - x[i]:=j; - y[i]:=(a+b*j)*(1.0+(2.0*random(0)-1.0)*fudge) - end { for-loop } - end { if } -end; { procedure get_data } - - -procedure write_data; -{ print out the answers } -var i : integer; - -begin - writeln; - writeln(' I X Y'); - for i:=1 to n do - writeln(i:3,x[i]:8:1,y[i]:9:2); - writeln -end; { write_data } - -begin { MAIN program } - cls; - seed:=4.0; - first:=true; - done:=false; - repeat - get_data(x,y,n); - if not done then - begin - write_data; - { ***** ---> more lines to be added here ********* } - end - until done -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/CFIT2.PAS b/software/CPM/CPM18_MTPUG_06/CFIT2.PAS deleted file mode 100644 index 78b7b42..0000000 --- a/software/CPM/CPM18_MTPUG_06/CFIT2.PAS +++ /dev/null @@ -1,96 +0,0 @@ -program cfit2; { -> 142+147 } -{ plot service included } -{ Pascal program to perform a linear least-squares fit } - -const max = 20; - -type index = 1..max; - ary = array[index] of real; - -var x,y,y_calc : ary; - n : integer; - first,done : boolean; - seed,a,b : real; - -external procedure cls; - -function random(dummy: integer): real; -{ random number 0-1 } -{ define seed=4.0 as global } - -const pi = 3.14159; - -var x : real; - i : integer; - -begin { RANDOM } - x:=seed+pi; - x:=exp(5.0*ln(x)); - seed:=x-trunc(x); - random:=seed -end; { RANDOM } - - - -procedure get_data(var x,y: ary; - var n: integer); -{ get values for n and arrays x,y } -{ y is randomly scattered about a straight line } - -const a = 2.0; - b = 5.0; - -var i,j : integer; - fudge : real; - -begin - write('Fudge? '); - readln(fudge); - if fudge<0.0 then done:=true - else - begin - repeat - write('How many points? '); - readln(n) - until (n>2) and (n<=max); - if first then first:=false else cls; - for i:=1 to n do - begin - j:=n+1-i; - x[i]:=j; - y[i]:=(a+b*j)*(1.0+(2.0*random(0)-1.0)*fudge) - end { for-loop } - end { if } -end; { procedure get_data } - - -procedure write_data; -{ print out the answers } -var i : integer; - -begin - writeln; - writeln(' I X Y'); - for i:=1 to n do - writeln(i:3,x[i]:8:1,y[i]:9:2); - writeln -end; { write_data } - -{$I PLOT.LIB } - -begin { MAIN program } - first:=true; - cls; - seed:=4.0; - done:=false; - repeat - get_data(x,y,n); - if not done then - begin - write_data; - plot(x,y,y,-n); - { ***** ---> more lines to be added here ********* } - end - until done -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/CFIT4.PAS b/software/CPM/CPM18_MTPUG_06/CFIT4.PAS deleted file mode 100644 index 7c57904..0000000 --- a/software/CPM/CPM18_MTPUG_06/CFIT4.PAS +++ /dev/null @@ -1,106 +0,0 @@ -program cfit4; {164} - -{ plot service included } -{ Pascal program to perform a linear least-squares fit } - -const max = 20; - -type index = 1..max; - ary = array[index] of real; - -var x,y,y_calc : ary; - n : integer; - first,done : boolean; - a,b,correl_coef, - sigma_a,sigma_b, - see,seed : real; - -external procedure cls; - -function random(dummy: integer): real; -{ random number 0-1 } -{ define seed=4.0 as global } - -const pi = 3.14159; - -var x : real; - i : integer; - -begin { RANDOM } - x:=seed+pi; - x:=exp(5.0*ln(x)); - seed:=x-trunc(x); - random:=seed -end; { RANDOM } - - - -procedure get_data(var x,y: ary; - var n: integer); -{ get values for n and arrays x,y } -{ y is randomly scattered about a straight line } - -const a = 2.0; - b = 5.0; - -var i,j : integer; - fudge : real; - -begin - write('Fudge? '); - readln(fudge); - if fudge<0.0 then done:=true - else - begin - repeat - write('How many points? '); - readln(n) - until (n>2) and (n<=max); - if first then first:=false else cls; - for i:=1 to n do - begin - j:=n+1-i; - x[i]:=j; - y[i]:=(a+b*j)*(1.0+(2.0*random(0)-1.0)*fudge) - end { for-loop } - end { if } -end; { procedure get_data } - - -procedure write_data; -{ print out the answers } -var i,j : integer; - -begin - writeln; - writeln(' I X Y YCALC'); - for i:=1 to n do - writeln(i:3,x[i]:8:1,y[i]:9:2,y_calc[i]:9:2); - writeln; - writeln('Intercept is ',a:8:3,', sigma is ',sigma_a:8:3); - writeln(' Slope is ',b:8:2,', sigma is ',sigma_b:8:3); - writeln; - writeln('Correlation coeffizient is ',correl_coef:7:4); - for j:=1 to 40 do for i:=1 to 10000 do; cls -end; { write_data } - -{$I C:LINFIT2.LIB } - -{$I PLOT.LIB } - -begin { MAIN program } - seed:=4.0; - cls; - first:=true; - done:=false; - repeat - get_data(x,y,n); - if not done then - begin - linfit(x,y,y_calc,a,b,n); - write_data; - plot(x,y,y_calc,n); - end - until done -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/CURSOR.ERL b/software/CPM/CPM18_MTPUG_06/CURSOR.ERL deleted file mode 100644 index 19645c8..0000000 Binary files a/software/CPM/CPM18_MTPUG_06/CURSOR.ERL and /dev/null differ diff --git a/software/CPM/CPM18_MTPUG_06/CURSOR.MAC b/software/CPM/CPM18_MTPUG_06/CURSOR.MAC deleted file mode 100644 index 55f19cf..0000000 --- a/software/CPM/CPM18_MTPUG_06/CURSOR.MAC +++ /dev/null @@ -1,515 +0,0 @@ - TITLE CURSOR - SUBTTL - Pascal definitions - - PAGE 55 - -;-------------------------------------------------------; -; ; -; MODULE CURSOR -- cursor routines in assembler. ; -; ; -; begun: 15 - Aug - 82 ; -; ; -;-------------------------------------------------------; - - .COMMENT \ - -This module contains cursor- positioning and semigraphics- procedures -for VT 52+ type terminals like the VISUAL 200. The following definitions -are to be made in your Pascal program to use them: - -TYPE - dir = (up,down,left,right); (* direction of the 3 line crossing *) - - -EXTERNAL PROCEDURE GotoXY(x,y:INTEGER); (* position cursor *) -EXTERNAL PROCEDURE ClrScr; (* clear whole screen *) -EXTERNAL PROCEDURE ClrEOS; (* clear to end of screen *) -EXTERNAL PROCEDURE ClrEOL; (* clear to end of line *) -EXTERNAL PROCEDURE EraScr; (* erase whole screen *) -EXTERNAL PROCEDURE EraEOS; (* erase to end of screen *) -EXTERNAL PROCEDURE EraEOL; (* erase to end of line *) -EXTERNAL PROCEDURE EraEOF; (* erase to end of field *) -EXTERNAL PROCEDURE Hline(y,xStart,xEnd:INTEGER); (* draw horizontal line *) -EXTERNAL PROCEDURE Vline(x,yStart,yEnd:INTEGER); (* draw vertical line *) -EXTERNAL PROCEDURE TriAt(x,y:INTEGER; where:dir);(* print 3 line crossing *) -EXTERNAL PROCEDURE EdgeAt(x,y,x2,y2: INTEGER); (* make frame- end points *) -EXTERNAL PROCEDURE CrossAt(x,y:INTEGER); (* print 4 line crossing *) -EXTERNAL PROCEDURE Mask; (* draw standard mask *) -EXTERNAL PROCEDURE Grafix; (* switch to graphics mode *) -EXTERNAL PROCEDURE EndGra; (* switch to normal mode *) -EXTERNAL PROCEDURE BakGnd; (* switch to background *) -EXTERNAL PROCEDURE ForGnd; (* switch to foreground *) - - -To link them to your program, link the CURSOR.ERL file as well as the -PASLIB.ERL file. No references to other library routines are made. - -There is no error checking done on range of coordinates,etc. The whole -library is intended to give highest speed and require minimal space. -Therefore, it does NOT use standard MT+ I/O but instead uses direct calls -to CP/Ms CONOUT function. - -The standard mask procedure draws horizontal lines of 80 characters length -on lines 0,2 and 21. I use row 1 for a title, rows 3 to 20 for the appli- -cation's screen display, and lines 22 and 23 for error- messages and as -status display (e.g. "Type any key to continue" etc.). - - \ - - .Z80 - - PUBLIC GOTOXY ; cursor positioning. - PUBLIC CLRSCR ; clear screen. - PUBLIC CLREOS ; clear to end of screen. - PUBLIC CLREOL ; clear to end of line. - PUBLIC ERASCR ; erase screen. - PUBLIC ERAEOS ; erase to end of screen. - PUBLIC ERAEOL ; erase to end of line. - PUBLIC ERAEOF ; erase to end of field. - PUBLIC GRAFIX ; select graphics. - PUBLIC ENDGRA ; select normal mode. - PUBLIC FORGND ; select foreground. - PUBLIC BAKGND ; select background. - PUBLIC HLINE ; draw horizontal line. - PUBLIC VLINE ; draw vertical line. - PUBLIC EDGEAT ; print 4 edges of a rectangle. - PUBLIC TRIAT ; print a 3 line crossing. - PUBLIC CROSAT ; print a 4 line crossing. - PUBLIC MASK ; draw standard mask. - -CONOT EQU 2 ; CP/M console output function. -BDOS EQU 5 ; CP/M entry point. -BS EQU 8 ; backspace character. -ESC EQU 1BH ; lead in character. - - - SUBTTL - cursor positioning - - PAGE - CSEG -; -;-------------------------------------------------------; -; SUBROUTINE ESCAPE -- send escape character. ; -; ; -; entry: -- ; -; exit : -- ; -;-------------------------------------------------------; -; -ESCAPE: LD C,CONOT ; - LD E,ESC ; - CALL BDOS ; - LD C,CONOT ; - RET ; - -;-------------------------------------------------------; -; SUBROUTINE GOTOXY -- position cursor on VT 52 + ; -; ; -; entry: coordinates on stack: Stk(2)=y, Stk(3)=x ; -; exit: -- ; -;-------------------------------------------------------; -; -; send initial string (ESC 'Y') -; -GOTOXY: CALL ESCAPE ; send escape. - - LD E,'Y' ; send 'Y' - CALL BDOS ; - - POP HL ; RETurn address - POP DE ; y- value - EX (SP),HL ; x- value - - LD A,20H ; offset to x- value - ADD A,L ; - LD L,A ; store x' in L - - LD A,20H ; offset to y- value - ADD A,E ; - LD E,A ; store y' in E - - PUSH HL ; x'- value - - LD C,CONOT ; send y'- value - CALL BDOS ; - - POP DE ; get x'- value - LD C,CONOT ; - JP BDOS ; BDOS returns for us, just to save - ; time. - - - SUBTTL - clear screen routines - - PAGE -; -;-------------------------------------------------------; -; SUBROUTINE CLRSCR -- clear screen ; -;-------------------------------------------------------; - -CLRSCR: CALL ESCAPE ; send escape - - LD E,'v' ; - JP BDOS ; -; -;-------------------------------------------------------; -; SUBROUTINE CLREOS -- clear to end of screen ; -;-------------------------------------------------------; -; -CLREOS: CALL ESCAPE ; send escape. - - LD E,'y' ; send 'y'. - JP BDOS ; - -; -;-------------------------------------------------------; -; SUBROUTINE CLREOL -- clear to end of line. ; -;-------------------------------------------------------; -; -CLREOL: CALL ESCAPE ; send escape - - LD E,'x' ; send 'x'. - JP BDOS ; - - SUBTTL - erase screen routines - - PAGE -; -;-------------------------------------------------------; -; SUBROUTINE ERASCR -- erase screen (foregnd only) ; -;-------------------------------------------------------; -; -ERASCR: CALL ESCAPE ; send escape - - LD E,'w' ; send 'w'. - JP BDOS ; -; -;-------------------------------------------------------; -; SUBROUTINE ERAEOS -- erase to end of screen. ; -;-------------------------------------------------------; -; -ERAEOS: CALL ESCAPE ; send escape - - LD E,'J' ; send 'J'. - JP BDOS ; -; -;-------------------------------------------------------; -; SUBROUTINE ERAEOL -- erase to end of line. ; -;-------------------------------------------------------; -; -ERAEOL: CALL ESCAPE ; send escape - - LD E,'K' ; send 'K'. - JP BDOS ; -; -;-------------------------------------------------------; -; SUBROUTINE ERAEOF -- erase to end of field. ; -;-------------------------------------------------------; -; -ERAEOF: CALL ESCAPE ; send escape - - LD E,'f' ; send 'f'. - JP BDOS ; - - SUBTTL - graphics and foreground/background logic - - PAGE -; -;-------------------------------------------------------; -; SUBROUTINE GRAFIX -- turn graphics on. ; -;-------------------------------------------------------; -; -GRAFIX: CALL ESCAPE ; send escape - - LD E,'F' ; send 'F'. - JP BDOS ; -; -;-------------------------------------------------------; -; SUBROUTINE ENDGRA -- turn graphics off. ; -;-------------------------------------------------------; -; -ENDGRA: CALL ESCAPE ; send escape - - LD E,'G' ; send 'G'. - JP BDOS ; -; -;-------------------------------------------------------; -; SUBROUTINE FORGND -- set foreground. ; -;-------------------------------------------------------; -; -FORGND: CALL ESCAPE ; send escape - - LD E,'3' ; send '3'. - JP BDOS ; -; -;-------------------------------------------------------; -; SUBROUTINE BAKGND -- set background. ; -;-------------------------------------------------------; -; -BAKGND: CALL ESCAPE ; send escape - - LD E,'4' ; send '4' - JP BDOS ; - - SUBTTL - draw lines - - PAGE -; -;-------------------------------------------------------; -; SUBROUTINE Hline -- draw horizontal line. ; -; ; -; entry: TOS=RET,Stk(2)=xEnd,Stk(3)=xStart,Stk(4)=y ; -; exit : -- ; -;-------------------------------------------------------; -; -HLINE: POP HL ; RETadr - POP DE ; xEnd - POP BC ; xStart - EX (SP),HL ; y - - PUSH DE ; xEnd (to save) - PUSH BC ; xStart (to save) -; -; setup for GotoXY -; - PUSH BC ; xStart - PUSH HL ; y - CALL GOTOXY ; position cursor.... -; -; setup for output- loop -; - POP DE ; xStart - POP HL ; xEnd - SBC HL,DE ; calc # of chars to output. - LD B,L ; must be less than 256..... - INC B ; increment to get right # of dashes. -; -; send char. -; -HLINLP: PUSH BC ; save count. - - LD C,CONOT ; setup for conout. - LD E,'`' ; send our char... - CALL BDOS ; - - POP BC ; get count back. - DJNZ HLINLP ; ... and loop. - - RET ; that's it.. -; -;-------------------------------------------------------; -; SUBROUTINE Vline -- draw vertical line. ; -; ; -; entry: coordinates on stack: Stk(1)=yEnd,Stk(2)=yStart; -; Stk(3)=x ; -; exit : -- ; -;-------------------------------------------------------; -; -VLINE: POP HL ; RETadr - POP DE ; yEnd - POP BC ; yStart - EX (SP),HL ; x - - PUSH DE ; yEnd - PUSH BC ; yStart -; -; setup for GOTOXY -; - PUSH HL ; x - PUSH BC ; yStart - CALL GOTOXY ; position the cursor. -; -; setup for loop. -; - POP DE ; yStart - POP HL ; yEnd - SBC HL,DE ; calc # of characters to output. - LD B,L ; must be less than 256... - INC B ; increment to get correct len. -; -; loop till end is reached.. -; -VLINLP: PUSH BC ; save count - LD C,CONOT ; setup for char out. - LD E,'a' ; - CALL BDOS ; - - CALL ESCAPE ; send cursor down code. - LD E,'B' ; - CALL BDOS ; - - LD C,CONOT ; send backspace - LD E,BS ; - CALL BDOS ; - - POP BC ; get count - DJNZ VLINLP ; ...and loop. - - RET ; that's it... - - SUBTTL - crossings - - PAGE -; -;-------------------------------------------------------; -; SUBROUTINE EDGEAT -- draw edge at coord... ; -; ; -; entry: coordinates of rectangle to draw on stack: ; -; ; -; TOS RETadr ; -; y2 ; -; x2 ; -; y ; -; x ; -; ; -; exit : -- ; -;-------------------------------------------------------; -; -EDGEAT: POP HL ; RETadr - POP DE ; y2 - POP BC ; x2 - LD A,C ; save y2 in accu. - POP BC ; y - EX (SP),HL ; x -; -; setup for GOTOXYs -; -; -; L = x, E = y2, C = y, A = x2 -; - PUSH HL ; x - PUSH BC ; y - PUSH HL ; x - PUSH DE ; y2 - LD L,A ; L = x2 - PUSH HL ; x2 - PUSH DE ; y2 - PUSH HL ; x2 - PUSH BC ; y - - CALL GOTOXY ; - LD E,'l' ; send upper right - CALL DOIT ; - - CALL GOTOXY ; - LD E,'m' ; lower right - CALL DOIT ; - - CALL GOTOXY ; - LD E,'e' ; lower left - CALL DOIT ; - - CALL GOTOXY ; - LD E,'s' ; upper left -DOIT: LD C,CONOT ; setup for BDOS call - JP BDOS ; send char in E. -; -;-------------------------------------------------------; -; SUBROUTINE TRIAT -- draw 3-line crossing at... ; -; ; -; entry: coordinates on stack: Stk(1)=where,Stk(2)=x, ; -; Stk(3)=y. ; -; exit : -- ; -;-------------------------------------------------------; -; -; define data type. -; -UP EQU 0 -DOWN EQU 1 -LEFT EQU 2 -RIGHT EQU 3 -; -TRIAT: POP HL ; RETadr - POP DE ; where (0..3) - POP BC ; y - EX (SP),HL ; x -; -; setup for GOTOXY -; - PUSH DE ; save where - PUSH HL ; x - PUSH BC ; y - - CALL GOTOXY ; position cursor. - - POP DE ; get where - LD A,E ; put into accu - - LD E,'c' ; - CP UP ; see if up- tri - JR Z,TRIOUT ; - - LD E,'d' ; - CP DOWN ; see if right- tri - JR Z,TRIOUT ; - - LD E,'n' ; - CP RIGHT ; see if down- tri - JR Z,TRIOUT ; - - LD E,'o' ; else, left- tri... -TRIOUT: LD C,CONOT ; setup for output - JP BDOS ; -; -;-------------------------------------------------------; -; SUBROUTINE CROSAT -- draw a cross at... ; -; ; -; entry: coordinates on stack: Stk(2)=x, Stk(3)=y ; -; exit : -- ; -;-------------------------------------------------------; -; -CROSAT: POP HL ; RETadr - POP DE ; col - POP BC ; row -; -; setup for GOTOXY -; - PUSH HL ; RETadr - PUSH BC ; row - PUSH DE ; col - - CALL GOTOXY ; position cursor. - - LD E,'b' ; - LD C,CONOT ; setup for output - JP BDOS ; - - SUBTTL - standard mask - - PAGE -; -;-------------------------------------------------------; -; SUBROUTINE MASK -- draw standard mask... ; -; ; -; entry: no parameters. ; -; exit : -- ; -;-------------------------------------------------------; -; -MASK: CALL BAKGND ; set background & graphics - CALL GRAFIX ; - XOR A ; clear accu - LD L,A ; clear HL - LD H,A ; - - PUSH HL ; Hline(0,0,79); - PUSH HL ; - LD L,79 ; - PUSH HL ; - CALL HLINE ; - - XOR A ; Hline(2,0,79) - LD H,A ; - LD L,2 ; - PUSH HL ; - LD L,A ; clear HL - PUSH HL ; - LD L,79 ; - PUSH HL ; - CALL HLINE ; - - XOR A ; Hline(21,0,79) - LD H,A ; - LD L,21 ; - PUSH HL ; - LD L,A ; - PUSH HL ; - LD L,79 ; - PUSH HL ; - CALL HLINE - - CALL ENDGRA ; EndGraphics - JP FORGND ; Foreground - - END - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/CURSOR2.ERL b/software/CPM/CPM18_MTPUG_06/CURSOR2.ERL deleted file mode 100644 index af9d282..0000000 Binary files a/software/CPM/CPM18_MTPUG_06/CURSOR2.ERL and /dev/null differ diff --git a/software/CPM/CPM18_MTPUG_06/CURSOR2.SRC b/software/CPM/CPM18_MTPUG_06/CURSOR2.SRC deleted file mode 100644 index b41b99b..0000000 --- a/software/CPM/CPM18_MTPUG_06/CURSOR2.SRC +++ /dev/null @@ -1,21 +0,0 @@ -MODULE Cursor2; - -(*******************************************) -(* *) -(* created 27 - Aug - 82 by P.Hochstrasser *) -(* *) -(* this module is part of the utility.lib *) -(* *) -(*******************************************) - -EXTERNAL PROCEDURE GotoXY(x,y: INTEGER); - -PROCEDURE PrintAt(x,y:INTEGER; someText: string); - -BEGIN - GotoXY(x,y); - WRITE(someText); -END; - -MODEND. -R \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/DETERM.PAS b/software/CPM/CPM18_MTPUG_06/DETERM.PAS deleted file mode 100644 index 8a342f8..0000000 --- a/software/CPM/CPM18_MTPUG_06/DETERM.PAS +++ /dev/null @@ -1,71 +0,0 @@ -program determ; { -> 55 } -{ pascal program to calculate the determinant of a 3-by-3matrix } - -type ary2 = array[1..3,1..3] of real; - -var a : ary2; - n : integer; - yesno : char; - d : real; - -external procedure cls; - -procedure get_data(var a: ary2; - var n: integer); - -{ get values for n and arrays x,y } - -var i,j : integer; - -begin - n:=3; - writeln; - for i:=1 to n do - begin - for j:=1 to n do - begin - write(j:3,':'); - readln(a[i,j]) - end { j-loop } - end; { i-loop } - writeln; - for i:=1 to n do - begin - for j:=1 to n do - write(a[i,j]:7:4,' '); - writeln - end; - writeln - end; { procedure get_data } - - - - -function deter(a: ary2): real; - { calculate the determinant of a 3-by-3matrix } - -var - sum : real; - -begin - sum:=a[1,1]*(a[2,2]*a[3,3]-a[3,2]*a[2,3]) - -a[1,2]*(a[2,1]*a[3,3]-a[3,1]*a[2,3]) - +a[1,3]*(a[2,1]*a[3,2]-a[3,1]*a[2,2]); - deter:=sum -end; - - - -begin { MAIN program } - cls; - repeat - get_data(a,n); - d:=deter(a); - writeln('The determinant is',d); - writeln; - write('More?'); - readln(yesno); - cls - until (yesno<>'Y')and(yesno<>'y') -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/DIFFUS.PAS b/software/CPM/CPM18_MTPUG_06/DIFFUS.PAS deleted file mode 100644 index e339d9d..0000000 --- a/software/CPM/CPM18_MTPUG_06/DIFFUS.PAS +++ /dev/null @@ -1,142 +0,0 @@ -{ die ln-funktion bei MT+ ist fuer Werte kleiner 1E-5 aeussertst langsam, - so dass man das Gefuehl bekommt, das dass Programm sich aufhaengt. In- - folgedessen konnte ich dieses Programm nicht verifizieren. -Juergen } - -program diffus; { --> 302 } - -{ Pascal program to perform a linear least-squares fit } -{ for the diffusion of Zn and Cu } -{ with Gauss-Jordan routine } -{ Sperate modules needed: - GAUSSJ, - PLOT } - - -const maxr = 20; { data prints } - maxc = 4; { polynomial terms } - r = 1.987; { gas constant } - -type ary = array[1..maxr] of real; - arys = array[1..maxc] of real; - ary2 = array[1..maxr,1..maxc] of real; - ary2s = array[1..maxc,1..maxc] of real; - -var - x,y,y_calc : ary; - t,d,resid : ary; - coef,sig : arys; - nrow,ncol : integer; - correl_coef,srs : real; - - -external procedure cls; - -procedure get_data(var x,y,t,d: ary; - var nrow: integer); -{ get values for nrow and arrays t,d } - -var i : integer; -begin - nrow:=7; - t[1]:=600.0; d[1]:=1.4E-12; - t[2]:=650.0; d[2]:=5.5E-12; - t[3]:=700.0; d[3]:=1.8E-11; - t[4]:=750.0; d[4]:=6.1E-11; - t[5]:=800.0; d[5]:=1.6E-10; - t[6]:=850.0; d[6]:=4.4E-10; - t[7]:=900.0; d[7]:=1.2E-9; - for i:=1 to nrow do - begin - x[i]:=1.0/(t[i]+273.0); - y[i]:=ln(d[i]) - end -end; { procedure get data } - - -procedure write_data; -{ print out the answers } -var i : integer; -begin - writeln; - writeln; - writeln(' I TC D DCALC'); - for i:=1 to nrow do - writeln(i:3,t[i]:8:0,d[i],' ',y_calc[i]); - writeln; writeln(' Coefficients '); - writeln(coef[1],' constant term'); - for i:=2 to ncol do - writeln(coef[i]); { other terms } - writeln; - writeln('D0=',(exp(coef[1])):7:2,' cm sq/sec.'); - writeln('Q =',(-r*coef[2]/1000.0):8:2,'kcal/mole'); - writeln;writeln('SRS= ',srs:7:3) -end; { write_data } - -{procedure square(x: ary2; - y: ary; - var a: ary2s; - var g: arys; - nrow,ncol: integer);} -{ matrix multiplication routine } -{ a= transpose x times x } -{ g= y times x } - -{$I C:SQUARE.LIB } - -{external procedure gaussj(var b: ary2s; - y: arys; - var coef: arys; - ncol: integer; - var error: boolean); -} -{$I GAUSSJ.LIB } - -procedure linfit(x, { independant variable } - y: ary; { dependent variable } - var y_calc: ary; { calculated dep. variable } - var resid: ary; { array of residuals } - var coef: arys; { coefficients } - var sig: arys; { error on coefficients } - nrow: integer; { length of array } - var ncol: integer); { number of terms } - -{ least squares fit to nrow sets of x and y pairs of points } -{ Seperate procedures needed: - SQUARE -> form square coefficient matrix - GAUSSJ -> Gauss-Jordan elimination } - -var xmatr : ary2; { data matrix } - a : ary2s; { coefficient matrix } - g : arys; { constant vector } - error : boolean; - i,j,nm : integer; - see,a1 : real; - -begin { procedure linfit } - ncol:=2; { number of terms } - for i:=1 to nrow do - begin { setup matrix } - xmatr[i,1]:=1.0; { first column } - xmatr[i,2]:=x[i] { second column } - end; - square(xmatr,y,a,g,nrow,ncol); - gaussj(a,g,coef,ncol,error); - srs:=0.0; - a1:=exp(coef[1]); - for i:=1 to nrow do - begin - y_calc[i]:=a1*exp(coef[2]*x[i]); - if y[i]<>0.0 then resid[i]:=y_calc[i]/y[i]-1.0 - else resid[i]:=y[i]/y_calc[i]-1.0; - srs:=srs+sqr(resid[i]) - end -end; { linfit } - - -begin { main program } - cls; - get_data(x,y,t,d,nrow); - linfit(x,y,y_calc,resid,coef,sig,nrow,ncol); - write_data -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/ERF4.PAS b/software/CPM/CPM18_MTPUG_06/ERF4.PAS deleted file mode 100644 index 07f9ce7..0000000 --- a/software/CPM/CPM18_MTPUG_06/ERF4.PAS +++ /dev/null @@ -1,81 +0,0 @@ -program erfd4; { -> 334 } - -{ evaluation of the gaussian error function } - -var x,er,ec : real; - done : boolean; - -external procedure cls; - -function erf(x: real): real; -{ infinite series expansion of the Gaussian error function } - -const sqrtpi = 1.7724538; - t2 = 0.66666667; - t3 = 0.66666667; - t4 = 0.07619048; - t5 = 0.01693122; - t6 = 3.078403E-3; - t7 = 4.736005E-4; - t8 = 6.314673E-5; - t9 = 7.429027E-6; - t10 = 7.820028E-7; - t11 = 7.447646E-8; - t12 = 6.476214E-9; - -var x2,sum : real; - i : integer; - -begin - x2:=x*x; - sum:=t5+x2*(t6+x2*(t7+x2*(t8+x2*(t9+x2*(t10+x2*(t11+x2*t12)))))); - erf:=2.0*exp(-x2)/sqrtpi*(x*(1+x2*(t2+x2*(t3+x2*(t4+x2*sum))))) -end; { function erf } - -function erfc(x: real): real; -{ complement of error function } -const sqrtpi = 1.7724538; - -var x2,v,sum : real; - -begin - x2:=x*x; - v:=1.0/(2.0*x2); - sum:=v/(1+8*v/(1+9*v/(1+10*v/(1+11*v/(1+12*v))))); - sum:=v/(1+3*v/(1+4*v/(1+5*v/(1+6*v/(1+7*sum))))); - erfc:=1.0/(exp(x2)*x*sqrtpi*(1+v/(1+2*sum))) -end; { function ercf } - -begin { main } - cls; - done:=false; - writeln; - repeat - write('Arg? '); - readln(x); - if x<0.0 then done:=true - else - begin - if x=0.0 then - begin - er:=0.0; - ec:=1.0 - end - else - begin - if x<1.5 then - begin - er:=erf(x); - ec:=1.0-er - end - else - begin - ec:=erfc(x); - er:=1.0-ec - end { if } - end; - writeln('X= ',x:6:2,', Erf= ',er:7:4,', Erfc= ',ec) - end { if } - until done -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/ERFD.PAS b/software/CPM/CPM18_MTPUG_06/ERFD.PAS deleted file mode 100644 index 9281b3c..0000000 --- a/software/CPM/CPM18_MTPUG_06/ERFD.PAS +++ /dev/null @@ -1,50 +0,0 @@ -program erfd; { -> 326 } - -{ evaluation of the gaussian error function } - -var x,ans : real; - done : boolean; - -function erf(x: real): real; -{ infinite series expansion of the Gaussian error function } - -const sqrtpi = 1.7724538; - tol = 1.0E-6; - -var x2,sum,sum1,term: real; - i : integer; - -begin - if x=0.0 then erf:=0.0 - else if x>4.0 then erf:=1.0 - else - begin - x2:=x*x; - sum:=x; - term:=x; - i:=0; - repeat - i:=i+1; - sum1:=sum; - term:=2.0*term*x2/(1.0+2.0*i); - sum:=term+sum1 - until term 330 } -{ evaluation of the gaussian error function } - -var x,er,ec : real; - done : boolean; - -external procedure cls; - -function erf(x: real): real; -{ infinite series expansion of the Gaussian error function } - -const sqrtpi = 1.7724538; - tol = 1.0E-4; - -var x2,sum,sum1,term: real; - i : integer; - -begin - x2:=x*x; - sum:=x; - term:=x; - i:=0; - repeat - i:=i+1; - sum1:=sum; - term:=2.0*term*x2/(1.0+2.0*i); - sum:=term+sum1 - until term0 } - begin - simps(fx,lower,upper,tol,sum); - erf:=twopi*sum; - writeln('Erf of ',upper:7:2,', is ',erf:8:4) - end - until done -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/FITPOL.PAS b/software/CPM/CPM18_MTPUG_06/FITPOL.PAS deleted file mode 100644 index ef8a172..0000000 --- a/software/CPM/CPM18_MTPUG_06/FITPOL.PAS +++ /dev/null @@ -1,148 +0,0 @@ -program fitpol; { -> 295 } -{ Pascal program to perform a linear least-squares fit } -{ to the ratio of 2 polynomials } -{ with Gauss-Jordan routine } -{ Sperate modules needed: - GAUSSJ} - - -const maxr = 20; { data prints } - maxc = 4; { polynomial terms } - -type - ary = array[1..maxr] of real; - arys = array[1..maxc] of real; - ary2 = array[1..maxr,1..maxc] of real; - ary2s = array[1..maxc,1..maxc] of real; - -var - x,y,y_calc : ary; - resid : ary; - coef,sig : arys; - nrow,ncol : integer; - correl_coef : real; - -external procedure cls; - -procedure get_data(var x: ary; { independant variable } - var y: ary; { dependant variable } - var nrow: integer); { length of vectors } -{ get values for n and arrays x,y } - -var i : integer; - -begin - { clausing factors } - nrow:=10; - x[1]:=0.1; y[1]:=0.9524; - x[2]:=0.2; y[2]:=0.9092; - x[3]:=0.5; y[3]:=0.8013; - x[4]:=1.0; y[4]:=0.6720; - x[5]:=1.2; y[5]:=0.6322; - x[6]:=1.5; y[6]:=0.5815; - x[7]:=2.0; y[7]:=0.5142; - x[8]:=3.0; y[8]:=0.4201; - x[9]:=4.0; y[9]:=0.3566; - x[10]:=6.0; y[10]:=0.2755; -end; { procedure get data } - -procedure write_data; -{ print out the answers } -var i : integer; -begin - writeln; - writeln; - writeln(' I X Y YCALC RESID'); - for i:=1 to nrow do - writeln(i:3,x[i]:8:1,y[i]:9:4,y_calc[i]:9:4,resid[i]:9:4); - writeln; writeln(' Coefficients errors '); - writeln(coef[1]:8:5,' ',sig[1],' constant term'); - for i:=2 to ncol do - writeln(coef[i]:8:5,' ',sig[i]); { other terms } - writeln; - writeln('Correlation coefficient is ',correl_coef:8:5) -end; { write_data } - -{procedure square(x: ary2; - y: ary; - var a: ary2s; - var g: arys; - nrow,ncol: integer);} -{ matrix multiplication routine } -{ a= transpose x times x } -{ g= y times x } -{$I C:SQUARE.LIB } - -{external procedure gaussj(var b: ary2s; - y: arys; - var coef: arys; - ncol: integer; - var error: boolean); -} -{$I GAUSSJ.LIB } - -procedure linfit(x, { independant variable } - y: ary; { dependent variable } - var y_calc: ary; { calculated dep. variable } - var resid: ary; { array of residuals } - var coef: arys; { coefficients } - var sig: arys; { error on coefficients } - nrow: integer; { length of array } - var ncol: integer); { number of terms } - -{ least squares fit to nrow sets of x and y pairs of points } -{ Seperate procedures needed: - SQUARE -> form square coefficient matrix - GAUSSJ -> Gauss-Jordan elimination } - -var xmatr : ary2; { data matrix } - a : ary2s; { coefficient matrix } - g : arys; { constant vector } - error : boolean; - i,j,nm : integer; - xi,yi,yc,srs,see, - sum_y,sum_y2 : real; - -begin { procedure linfit } - ncol:=4; { number of terms } - for i:=1 to nrow do - begin { setup matrix } - xi:=x[i]; - yi:=y[i]; - xmatr[i,1]:=1.0; { first column } - xmatr[i,2]:=-xi*yi; { second column } - xmatr[i,3]:=xi; { third column } - xmatr[i,4]:=-sqr(xi)*yi - end; - square(xmatr,y,a,g,nrow,ncol); - gaussj(a,g,coef,ncol,error); - sum_y:=0.0; - sum_y2:=0.0; - srs:=0.0; - for i:=1 to nrow do - begin - xi:=x[i]; - yi:=y[i]; - yc:=coef[1]+(-coef[2]*yi+coef[3]-coef[4]*xi*yi)*xi; - y_calc[i]:=yc; - resid[i]:=yc-yi; - srs:=srs+sqr(resid[i]); - sum_y:=sum_y+yi; - sum_y2:=sum_y2+yi*yi - end; - correl_coef:=sqrt(1.0-srs/(sum_y2-sqr(sum_y)/nrow)); - if nrow=ncol then nm:=1 - else nm:=nrow-ncol; - see:=sqrt(srs/nm); - for i:=1 to ncol do { errors on solution } - sig[i]:=see*sqrt(a[i,i]) -end; { linfit } - - -begin { main program } - cls; - get_data(x,y,nrow); - linfit(x,y,y_calc,resid,coef,sig,nrow,ncol); - write_data -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/GAUSID.PAS b/software/CPM/CPM18_MTPUG_06/GAUSID.PAS deleted file mode 100644 index edafb47..0000000 --- a/software/CPM/CPM18_MTPUG_06/GAUSID.PAS +++ /dev/null @@ -1,179 +0,0 @@ -program gausid; { -> 129 } -{ pascal program to perform simultaneous solution } -{ by Gauss-Seidel } -{ procedure SEID is included } - -const maxr = 8; - maxc = 8; - -type ary = array[1..maxr] of real; - arys = array[1..maxc] of real; - ary2s = array[1..maxr,1..maxc] of real; - -var y : ary; - coef : arys; - a : ary2s; - n,m : integer; - first, - error : boolean; - -external procedure cls; - -procedure get_data - (var a : ary2s; - var y : ary; - var n,m: integer); -{ get values for n and arrays a,y } - -var i,j : integer; - -begin - writeln; - repeat - write('How many equations? '); - readln(n); - if first then first:=false else cls - until n1 then - begin - for i:=1 to n do - begin - writeln('Equation',i:3); - for j:=1 to n do - begin - write(j:3,':'); - read(a[i,j]) - end; - write(' C:'); - read(y[i]); - readln { clear the line } - end; - writeln; - for i:=1 to n do - begin - for j:=1 to m do - write(a[i,j]:7:4,' '); - writeln(':',y[i]:7:4) - end; - writeln - end { if n>1 } - else if n<0 then n:=-n; - m:=n -end; { procedure get_data } - -procedure write_data; -{ print out the answers } - -var i : integer; - -begin - for i:=1 to m do - write(coef[i]:9:5); - writeln -end; { write_data } - -procedure seid - (a : ary2s; - y : ary; - var coef: arys; - ncol : integer; - var error: boolean); -{ matrix solution by Gauss Seidel } - -const tol = 1.0E-4; - max = 100; - -var done : boolean; - i,j,k,l,n: integer; - - nextc,hold, - sum,lambda, - ab,big : real; - -begin - repeat - write('Relaxation factor? '); - readln(lambda) - until (lambda<2) and (lambda>0.0); - error:=false; - n:=ncol; - for i:=1 to n-1 do - begin - big:=abs(a[i,i]); - l:=i; - for j:=i+1 to n do - begin - { search for largest element } - ab:=abs(a[j,i]); - if ab>big then - begin - big:=ab; - l:=j - end - end; { j-loop } - if big=0.0 then error:=true - else - begin - if l<>i then - begin - { interchange rows to put } - { largest element on diagonal } - for j:=1 to n do - begin - hold:=a[l,j]; - a[l,j]:=a[i,j]; - a[i,j]:=hold - end; - hold:=y[l]; - y[l]:=y[i]; - y[i]:=hold - end { if l<>i } - end { if big } - end; { i-loop } - if a[n,n]=0.0 then error:=true - else - begin - for i:=1 to n do - coef[i]:=0.0; { initial guess } - i:=0; - repeat - i:=i+1; - done:=true; - for j:=1 to n do - begin - sum:=y[j]; - for k:=1 to n do - if j<>k then - sum:=sum-a[j,k]*coef[k]; - nextc:=sum/a[j,j]; - if abs(nextc-coef[j])>tol then - begin - done:=false; - if nextc*coef[j]<0.0 then - nextc:=(coef[j]+nextc)*0.5 - end; - coef[j]:=lambda*nextc+(1.0-lambda)*coef[j]; - writeln(i:4,',coef(',j,')=',coef[j]) - end { j-loop } - until done or (i>max) - end; { if a[n,n]=0 } - if i>max then error:=true; - if error then writeln('ERROR: Matrix is singular') -end; { SEID } - -begin { MAIN program } - first:=true; - cls; - writeln; - writeln('Simultaneous solution by Gauss-Seidel'); - repeat - get_data(a,y,n,m); - if n>1 then - begin - seid(a,y,coef,n,error); - if not error then write_data - end - until n<2 -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/GAUSS.PAS b/software/CPM/CPM18_MTPUG_06/GAUSS.PAS deleted file mode 100644 index 86acb43..0000000 --- a/software/CPM/CPM18_MTPUG_06/GAUSS.PAS +++ /dev/null @@ -1,169 +0,0 @@ -program gaus; { -> 75 } -{ pascal program to perform simultaneous solution by Gaussian elimination } -{ procedure GAUSS is included } - -const maxr = 8; - maxc = 8; - -type ary = array[1..maxr] of real; - arys = array[1..maxc] of real; - ary2s = array[1..maxr,1..maxc] of real; - -var y : arys; - coef : arys; - a : ary2s; - n,m : integer; - first, - error : boolean; - -external procedure cls; - -procedure get_data(var a: ary2s; - var y: arys; - var n,m: integer); - -{ get values for n and arrays a,y } - -var i,j : integer; - -begin - writeln; - repeat - write('How many equations? '); - readln(n); - if not first then cls else first:=false; - m:=n - until n1 then - begin - for i:=1 to n do - begin - writeln('Equation',i:3); - for j:=1 to n do - begin - write(j:3,':'); - read(a[i,j]) - end; - write(',C:'); - read(y[i]); - readln { clear line } - end; - writeln; - for i:=1 to n do - begin - for j:=1 to m do - write(a[i,j]:7:4); - writeln(':',y[i]:7:4) - end; - writeln - end { if n>1 } -end; { procedure get_data} - -procedure write_data; - { print out the answeres } - -var i : integer; - -begin - for i:=1 to m do - write(coef[i]:9:5); - writeln -end; { write_data } - -procedure gauss - (a : ary2s; - y : arys; - var coef : arys; - ncol : integer; - var error : boolean); - -{ matrix solution by Gaussian Elimination } - -var - b : ary2s; { work array, nrow,ncol } - w : arys; { work array, ncol long } - i,j,i1,k, - l,n : integer; - hold,sum, - t,ab,big: real; - -begin - error:=false; - n:=ncol; - for i:=1 to n do - begin { copy to work arrays } - for j:=1 to n do - b[i,j]:=a[i,j]; - w[i]:=y[i] - end; - for i:=1 to n-1 do - begin - big:=abs(b[i,i]); - l:=i; - i1:=i+1; - for j:=i1 to n do - begin { search for largest element } - ab:=abs(b[j,i]); - if ab>big then - begin - big:=ab; - l:=j - end - end; - if big=0.0 then error:= true - else - begin - if l<>i then - begin - { interchange rows to put largest element on diagonal } - for j:=1 to n do - begin - hold:=b[l,j]; - b[l,j]:=b[i,j]; - b[i,j]:=hold - end; - hold:=w[l]; - w[l]:=w[i]; - w[i]:=hold - end; { if l<>i } - for j:=i1 to n do - begin - t:=b[j,i]/b[i,i]; - for k:=i1 to n do - b[j,k]:=b[j,k]-t*b[i,k]; - w[j]:=w[j]-t*w[i] - end { j-loop } - end { if big } - end; { i-loop } - if b[n,n]=0.0 then error:=true - else - begin - coef[n]:=w[n]/b[n,n]; - i:=n-1; - { back substitution } - repeat - sum:=0.0; - for j:=i+1 to n do - sum:=sum+b[i,j]*coef[j]; - coef[i]:=(w[i]-sum)/b[i,i]; - i:=i-1 - until i=0 - end; { if b[n,n]=0 } - if error then writeln(chr(7),'ERROR: Matrix is singular') -end; { GAUSS } - -begin { MAIN } - first:=true; - cls; - writeln; - writeln('Simultaneous solution by Gauss elimination'); - repeat - get_data(a,y,n,m); - if n>1 then - begin - gauss(a,y,coef,n,error); - if not error then write_data - end - until n<2 -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/GAUSSJ.LIB b/software/CPM/CPM18_MTPUG_06/GAUSSJ.LIB deleted file mode 100644 index 3dfa3be..0000000 --- a/software/CPM/CPM18_MTPUG_06/GAUSSJ.LIB +++ /dev/null @@ -1,167 +0,0 @@ - {87} - -procedure gaussj - (var b: ary2s; { square matrix of coefficients } - y: arys; { constant vector } - var coef: arys; { solution vector } - ncol: integer; { order of matrix } - var error: boolean); { true if matrix singular } - -{ Gauss Jordan matrix inversion and solution } - -{ B(n,n) coefficient matrix becomes inverse } -{ Y(n) original constant vector } -{ W(n,m) constant vector(s) become solution vector } -{ DETERM is the determinant } -{ ERROR=1 if singular } -{ INDEX(n,3) } -{ NV is number of constant vectors } - -label 99; - -var - w : array[1..maxc,1..maxc] of real; - index : array[1..maxc,1..3] of integer; - i,j,k,l,nv, - irow,icol, - n,l1 : integer; - determ,pivot, - hold,sum,t, - ab,big : real; - - - - -procedure swap(var a,b: real); -var hold : real; - -begin { swap } - hold:=a; - a:=b; - b:=hold -end; { procedure swap } - - -procedure gausj2; -label 98; -var i,j,k,l,l1 : integer; - - -procedure gausj3; - -var l : integer; - -begin { procedure gausj3 } - { interchange rows to put pivot on diagonal } - if irow<>icol then - begin - determ:=-determ; - for l:=1 to n do - swap(b[irow,l],b[icol,l]); - if nv>0 then - for l:=1 to nv do - swap(w[irow,l],w[icol,l]) - end { if iroe<>icol } -end; { gausj3 } - -begin { procedure gausj2 } - { actual start of gaussj } - error:=false; - nv:=1; { single constant vector } - n:=ncol; - for i:=1 to n do - begin - w[i,1]:=y[i]; { copy constant vector } - index[i,3]:=0 - end; - determ:=1.0; - for i:=1 to n do - begin - { search for largest element } - big:=0.0; - for j:=1 to n do - begin - if index[j,3]<>1 then - begin - for k:=1 to n do - begin - if index[k,3]>1 then - begin - writeln('ERROR: matrix is singular'); - error:=true; - goto 98 { abort } - end; - if index[k,3]<1 then - if abs(b[j,k])>big then - begin - irow:=j; - icol:=k; - big:=abs(b[j,k]) - end - end { k-loop } - end - end; { j-loop } - - index[icol,3]:=index[icol,3]+1; - index[i,1]:=irow; - index[i,2]:=icol; - - gausj3; { further subdivision of gaussj } - { divide pivot row by pivot column } - pivot:=b[icol,icol]; - determ:=determ*pivot; - b[icol,icol]:=1.0; - - for l:=1 to n do - b[icol,l]:=b[icol,l]/pivot; - if nv>0 then - for l:=1 to nv do - w[icol,l]:=w[icol,l]/pivot; - - { reduce nonpivot rows } - - for l1:=1 to n do - begin - if l1<>icol then - begin - t:=b[l1,icol]; - b[l1,icol]:=0.0; - for l:=1 to n do - b[l1,l]:=b[l1,l]-b[icol,l]*t; - if nv>0 then - for l:=1 to nv do - w[l1,l]:=w[l1,l]-w[icol,l]*t; - end { if l1<>icol } - end - end; { i-loop } -98: -end; { gausj2 } - -begin { gaus-jordan main program } - gausj2; { first half of gaussj } - if error then goto 99; - { interchange columns } - for i:=1 to n do - begin - l:=n-i+1; - if index[l,1]<>index[l,2] then - begin - irow:=index[l,1]; - icol:=index[l,2]; - for k:=1 to n do - swap(b[k,irow],b[k,icol]) - end { if index } - end; { i-loop } -for k:=1 to n do - if index[k,3]<>1 then - begin - writeln(chr(7),'ERROR: matrix is singular'); - error:=true; - goto 99 { abort } - end; - for i:=1 to n do - coef[i]:=w[i,1]; -99: -end; { procedure gaussj } - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/GD-LINF1.LIB b/software/CPM/CPM18_MTPUG_06/GD-LINF1.LIB deleted file mode 100644 index a4665d5..0000000 --- a/software/CPM/CPM18_MTPUG_06/GD-LINF1.LIB +++ /dev/null @@ -1,77 +0,0 @@ - -{ -> 216 } -procedure get_data(var t : ary; { independedt variable } - var cp : ary; { dependent variable } - var nrow : integer); { length of vectors } -var i : integer; - -begin - nrow:=10; - for i:=1 to nrow do - t[i]:=(i+2)*100; - cp[1]:=7.02; cp[2]:=7.2; - cp[3]:=7.43; cp[4]:=7.67; - cp[5]:=7.88; cp[6]:=8.06; - cp[7]:=8.21; cp[8]:=8.34; - cp[9]:=8.44; cp[10]:=8.53 -end; { procedure get_data } - - -{ -> 217 } -procedure linfit(X, { independent variable } - y : ary; { dependent variable } - var y_calc : ary; { calculated dep. variable } - var resid : ary; { array of residuals } - var coef : arys; { coefficients } - var sig : arys; { error on coefficients } - nrow : integer; { length of ary } - var ncol : integer); { number of terms } - -{ least-squares fit to nrow sets of x and y pairs of points } -{ Seperate procedure needed: - SQUARE -> form square coefficient matrix - GAUSSJ -> Gauus-Jordan elimination } - -var xmatr : ary2; { data matrix } - a : ary2s; { coefficient matrix } - g : arys; { constant vector } - error : boolean; - i,j,nm : integer; - xi,yi,yc,srs,see, - sum_y,sum_y2 : real; - -begin { procedure linfit } - ncol:=3; { number of terms } - for i:=1 to nrow do - begin { setup x matrix } - xi:=x[i]; - xmatr[i,1]:=1.0; { first column } - xmatr[i,2]:=xi; { second column } - xmatr[i,3]:=1.0/sqr(xi) { third column } - end; - square(xmatr,y,a,g,nrow,ncol); - gaussj(a,g,coef,ncol,error); - sum_y:=0.0; - sum_y2:=0.0; - srs:=0.0; - for i:=1 to nrow do - begin - yi:=y[i]; - yc:=0.0; - for j:=1 to ncol do - yc:=yc+coef[j]*xmatr[i,j]; - y_calc[i]:=yc; - resid[i]:=yc-yi; - srs:=srs+sqr(resid[i]); - sum_y:=sum_y+yi; - sum_y2:=sum_y2+yi*yi - end; - correl_coef:=sqrt(1.0-srs/(sum_y2-sqr(sum_y)/nrow)); - if nrow=ncol then nm:=1 - else nm:=nrow-ncol; - see:=sqrt(srs/nm); - for i:=1 to ncol do { errors on solution } - sig[i]:=see*sqrt(a[i,i]) -end; { LINFIT } - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/GD-LINF2.LIB b/software/CPM/CPM18_MTPUG_06/GD-LINF2.LIB deleted file mode 100644 index d2d1852..0000000 --- a/software/CPM/CPM18_MTPUG_06/GD-LINF2.LIB +++ /dev/null @@ -1,79 +0,0 @@ - -{ -> 220 } -procedure get_data(var t : ary; { independedt variable } - var p : ary; { dependent variable } - var nrow : integer); { length of vectors } -var i : integer; - -begin - nrow:=10; - for i:=1 to nrow do - t[i]:=(i+6.0)*100.0; - p[1]:=1.0E-9; p[2]:=5.598E-8; - p[3]:=1.234E-6; p[4]:=1.507E-5; - p[5]:=1.138E-4; p[6]:=6.067E-4; - p[7]:=2.512E-3; p[8]:=8.337E-3; - p[9]:=2.371E-2; p[10]:=5.875E-2; - for i:=1 to nrow do - p[i]:=ln(p[i]) { take log data } -end; { procedure get_data } - - - -procedure linfit(X, { independent variable } - y : ary; { dependent variable } - var y_calc : ary; { calculated dep. variable } - var resid : ary; { array of residuals } - var coef : arys; { coefficients } - var sig : arys; { error on coefficients } - nrow : integer; { length of ary } - var ncol : integer); { number of terms } - -{ least-squares fit to nrow sets of x and y pairs of points } -{ Seperate procedure needed: - SQUARE -> form square coefficient matrix - GAUSSJ -> Gauus-Jordan elimination } - -var xmatr : ary2; { data matrix } - a : ary2s; { coefficient matrix } - g : arys; { constant vector } - error : boolean; - i,j,nm : integer; - xi,yi,yc,srs,see, - sum_y,sum_y2 : real; - -begin { procedure linfit } - ncol:=3; { number of terms } - for i:=1 to nrow do - begin { setup x matrix } - xi:=x[i]; - xmatr[i,1]:=1.0; { first column } - xmatr[i,2]:=1.0/xi; { second column } - xmatr[i,3]:=ln(xi) { third column } - end; - square(xmatr,y,a,g,nrow,ncol); - gaussj(a,g,coef,ncol,error); - sum_y:=0.0; - sum_y2:=0.0; - srs:=0.0; - for i:=1 to nrow do - begin - yi:=y[i]; - yc:=0.0; - for j:=1 to ncol do - yc:=yc+coef[j]*xmatr[i,j]; - y_calc[i]:=yc; - resid[i]:=yc-yi; - srs:=srs+sqr(resid[i]); - sum_y:=sum_y+yi; - sum_y2:=sum_y2+yi*yi - end; - correl_coef:=sqrt(1.0-srs/(sum_y2-sqr(sum_y)/nrow)); - if nrow=ncol then nm:=1 - else nm:=nrow-ncol; - see:=sqrt(srs/nm); - for i:=1 to ncol do { errors on solution } - sig[i]:=see*sqrt(a[i,i]) -end; { LINFIT } - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/JULIAN.LIB b/software/CPM/CPM18_MTPUG_06/JULIAN.LIB deleted file mode 100644 index debc9ff..0000000 --- a/software/CPM/CPM18_MTPUG_06/JULIAN.LIB +++ /dev/null @@ -1,19 +0,0 @@ - - -function julian(dd,mm,yyyy: integer): integer; -var jm,jy: integer; -begin - case mm of - 1,2 : begin - jy:=yyyy-1; - jm:=mm+13 - end - else - begin - jy:=yyyy; - jm:=mm - end; - julian:=trunc(365.25*jy)+trunc(30.6001*jm)+dd+1720982 -end; { julian } - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/LEAST1.PAS b/software/CPM/CPM18_MTPUG_06/LEAST1.PAS deleted file mode 100644 index 470c841..0000000 --- a/software/CPM/CPM18_MTPUG_06/LEAST1.PAS +++ /dev/null @@ -1,182 +0,0 @@ -{$S+ } -program least1; { --> 191 } -{ Pascal Program to perform a liner least-squares fit using a parabolic } -{ curve. Aeperate procedure PLOT needed } - -const maxr = 20; - maxc = 3; - -type ary = array[1..maxr] of real; - arys = array[1..maxc] of real; - ary2s = array[1..maxc,1..maxc] of real; - -var x,y,y_calc : ary; - coef : arys; - nrow,ncol : integer; - correl_coef : real; - - -external procedure cls; - -procedure get_data(var x,y: ary; - var nrow: integer); -{ get values for n and arrays x,y } - -var i : integer; - -begin - nrow:=9; - writeln; - for i:=1 to nrow do x[i]:=i; - y[1]:=2.07; y[2]:=8.6; - y[3]:=14.42; y[4]:=15.8; - y[5]:=18.92; y[6]:=17.96; - y[7]:=12.98; y[8]:=6.45; - y[9]:=0.27; -end; { procedure get_data } - -procedure write_data; -{ print out the answers } -var i : integer; -begin - writeln; - writeln(' I X Y YCALC'); - for i:=1 to nrow do - writeln(i:3,x[i]:8:1,y[i]:9:2,y_calc[i]:9:2); - writeln; writeln(' Coefficients '); - for i:=1 to ncol do - writeln(coef[i]:8:4); - writeln; - writeln('Correlation coefficient is ',correl_coef:8:5) -end; { write_data } - -procedure solve(a: ary2s; - y: arys; - var coef: arys; - nrow: integer; - var error: boolean); - -var b : ary2s; - i,j : integer; - det : real; - - -function deter(a: ary2s): real; - { calculate the determinant of a 3-by-3matrix } -begin - deter:=a[1,1]*(a[2,2]*a[3,3]-a[3,2]*a[2,3]) - -a[1,2]*(a[2,1]*a[3,3]-a[3,1]*a[2,3]) - +a[1,3]*(a[2,1]*a[3,2]-a[3,1]*a[2,2]) -end; - - - -procedure setup(var b : ary2s; - var coef: arys; - j : integer); - -var i : integer; - -begin { setup } - for i:=1 to nrow do - begin - b[i,j]:=y[i]; - if j>1 then b[i,j-1]:=a[i,j-1] - end; - coef[j]:=deter(b)/det -end; { setup } - -begin { procedure solve } - error:=false; - for i:=1 to nrow do - for j:=1 to nrow do - b[i,j]:=a[i,j]; - det:=deter(b); - if det=0.0 then - begin - error:=true; - writeln(chr(7),'ERROR: matrix is singular') - end - else - begin - setup(b,coef,1); - setup(b,coef,2); - setup(b,coef,3) - end { esle } -end; { procedure solve } - - -procedure linfit(x,y: ary; - var y_calc: ary; - var coef: arys; - nrow: integer; - var ncol: integer); - -{ least squares fit to a parabola } -{ nrow sets of x and y pair points } - -var a : ary2s; - g : arys; - i : integer; - error : boolean; - - sum_x,sum_y,sum_xy,sum_x2, - sum_y2,xi,yi,sxy,syy, - sxx,sum_x3,sum_x4,sum_2y, - denom,srs,x2 : real; - -begin { linfit } - ncol:=3; { polynomial terms } - sum_x:=0.0; - sum_y:=0.0; - sum_xy:=0.0; - sum_x2:=0.0; - sum_y2:=0.0; - sum_x3:=0.0; - sum_x4:=0.0; - sum_2y:=0.0; - for i:=1 to nrow do - begin - xi:=x[i]; - yi:=y[i]; - x2:=xi*xi; - sum_x:=sum_x+xi; - sum_y:=sum_y+yi; - sum_xy:=sum_xy+xi*yi; - sum_x2:=sum_x2+x2; - sum_y2:=sum_y2+yi*yi; - sum_x3:=sum_x3+xi*x2; - sum_x4:=sum_x4+x2*x2; - sum_2y:=sum_2y+x2*yi - end; - a[1,1]:=nrow; - a[2,1]:=sum_x; a[1,2]:=sum_x; - a[3,1]:=sum_x2; a[1,3]:=sum_x2; - a[2,2]:=sum_x2; a[3,2]:=sum_x3; - a[2,3]:=sum_x3; a[3,3]:=sum_x4; - g[1]:=sum_y; - g[2]:=sum_xy; - g[3]:=sum_2y; - solve(a,g,coef,ncol,error); - srs:=0.0; - for i:=1 to nrow do - begin - y_calc[i]:=coef[1]+coef[2]*x[i]+coef[3]*sqr(x[i]); - srs:=srs+sqr(y[i]-y_calc[i]) - end; - correl_coef:=sqrt(1.0-srs/(sum_y2-sqr(sum_y)/nrow)) -end; { linfit } - -{ external procedure plot(x,y,y_calc: ary; nrow: integer); -} - -{$I C:PLOT.LIB } { get ptocedure PLOT } - -begin { MAIN program } - cls; - get_data(x,y,nrow); - linfit(x,y,y_calc,coef,nrow,ncol); - write_data; - plot(x,y,y_calc,nrow) -end. { MAIN } - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/LEAST2.PAS b/software/CPM/CPM18_MTPUG_06/LEAST2.PAS deleted file mode 100644 index 667a249..0000000 --- a/software/CPM/CPM18_MTPUG_06/LEAST2.PAS +++ /dev/null @@ -1,164 +0,0 @@ -program least2; { --> 203 } -{ Pascal program to perform a linear least-squares fit } -{ with Gauss-Jordan routine } -{ Sperate modules needed: - GAUSSJ, - PLOT } - - -const maxr = 20; { data prints } - maxc = 4; { polynomial terms } - -type ary = array[1..maxr] of real; - arys = array[1..maxc] of real; - ary2 = array[1..maxr,1..maxc] of real; - ary2s = array[1..maxc,1..maxc] of real; - -var x,y,y_calc : ary; - resid : ary; - coef,sig : arys; - nrow,ncol : integer; - correl_coef : real; - - -external procedure cls; - -procedure get_data(var x: ary; { independant variable } - var y: ary; { dependant variable } - var nrow: integer); { length of vectors } -{ get values for n and arrays x,y } - -var i : integer; - -begin - nrow:=9; - for i:=1 to nrow do x[i]:=i; - y[1]:=2.07; y[2]:=8.6; - y[3]:=14.42; y[4]:=15.8; - y[5]:=18.92; y[6]:=17.96; - y[7]:=12.98; y[8]:=6.45; - y[9]:=0.27; -end; { proceddure get data } - -procedure write_data; -{ print out the answers } -var i : integer; -begin - writeln; - writeln; - writeln(' I X Y YCALC RESID'); - for i:=1 to nrow do - writeln(i:3,x[i]:8:1,y[i]:9:2,y_calc[i]:9:2,resid[i]:9:2); - writeln; writeln(' Coefficients errors '); - writeln(coef[1],' ',sig[1],' constant term'); - for i:=2 to ncol do - writeln(coef[i],' ',sig[i]); { other terms } - writeln; - writeln('Correlation coefficient is ',correl_coef:8:5) -end; { write_data } - -procedure square(x: ary2; - y: ary; - var a: ary2s; - var g: arys; - nrow,ncol: integer); -{ matrix multiplication routine } -{ a= transpose x times x } -{ g= y times x } - -var i,k,l : integer; - -begin { square } - for k:=1 to ncol do - begin - for l:=1 to k do - begin - a[k,l]:=0.0; - for i:=1 to nrow do - begin - a[k,l]:=a[k,l]+x[i,l]*x[i,k]; - if k<>l then a[l,k]:=a[k,l] - end - end; { l-loop } - g[k]:=0.0; - for i:=1 to nrow do - g[k]:=g[k]+y[i]*x[i,k] - end { k-loop } -end; { SQUARE } - -{external procedure gaussj(var b: ary2s; - y: arys; - var coef: arys; - ncol: integer; - var error: boolean); -} -{$I GAUSSJ.LIB } - -procedure linfit(x, { independant variable } - y: ary; { dependent variable } - var y_calc: ary; { calculated dep. variable } - var resid: ary; { array of residuals } - var coef: arys; { coefficients } - var sig: arys; { error on coefficients } - nrow: integer; { length of array } - var ncol: integer); { number of terms } - -{ least squares fit to nrow sets of x and y pairs of points } -{ Seperate procedures needed: - SQUARE -> form square coefficient matrix - GAUSSJ -> Gauss-Jordan elimination } - -var xmatr : ary2; { data matrix } - a : ary2s; { coefficient matrix } - g : arys; { constant vector } - error : boolean; - i,j,nm : integer; - xi,yi,yc,srs,see, - sum_y,sum_y2 : real; - -begin { procedure linfit } - ncol:=3; { number of terms } - for i:=1 to nrow do - begin { setup matrix } - xi:=x[i]; - xmatr[i,1]:=1.0; { first column } - xmatr[i,2]:=xi; { second column } - xmatr[i,3]:=xi*xi { third column } - end; - square(xmatr,y,a,g,nrow,ncol); - gaussj(a,g,coef,ncol,error); - sum_y:=0.0; - sum_y2:=0.0; - srs:=0.0; - for i:=1 to nrow do - begin - yi:=y[i]; - yc:=0.0; - for j:=1 to ncol do - yc:=yc+coef[j]*xmatr[i,j]; - y_calc[i]:=yc; - resid[i]:=yc-yi; - srs:=srs+sqr(resid[i]); - sum_y:=sum_y+yi; - sum_y2:=sum_y2+yi*yi - end; - correl_coef:=sqrt(1.0-srs/(sum_y2-sqr(sum_y)/nrow)); - if nrow=ncol then nm:=1 - else nm:=nrow-ncol; - see:=sqrt(srs/nm); - for i:=1 to ncol do { errors on solution } - sig[i]:=see*sqrt(a[i,i]) -end; { linfit } - -{external procedure plot(x,y,z: ary; nrow: integer); -} -{$I C:PLOT.LIB } - -begin { main program } - cls; - get_data(x,y,nrow); - linfit(x,y,y_calc,resid,coef,sig,nrow,ncol); - write_data; - plot(x,y,y_calc,nrow) -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/LEAST3.PAS b/software/CPM/CPM18_MTPUG_06/LEAST3.PAS deleted file mode 100644 index 06b8b02..0000000 --- a/software/CPM/CPM18_MTPUG_06/LEAST3.PAS +++ /dev/null @@ -1,158 +0,0 @@ -program least3; { --> 209 } -{ Pascal program to perform a linear least-squares fit } -{ with Gauss-Jordan routine } -{ Sperate modules needed: - GAUSSJ, - PLOT } - -const maxr = 20; { data prints } - maxc = 4; { polynomial terms } - -type ary = array[1..maxr] of real; - arys = array[1..maxc] of real; - ary2 = array[1..maxr,1..maxc] of real; - ary2s = array[1..maxc,1..maxc] of real; - -var x,y,y_calc : ary; - resid : ary; - coef,sig : arys; - nrow,ncol : integer; - correl_coef : real; - first,done : boolean; - -external procedure cls; - -procedure get_data(var x: ary; { independant variable } - var y: ary; { dependant variable } - var nrow: integer); { length of vectors } -{ get values for n and arrays x,y } - -var i : integer; - -begin - nrow:=9; - for i:=1 to nrow do x[i]:=i; - y[1]:=2.07; y[2]:=8.6; - y[3]:=14.42; y[4]:=15.8; - y[5]:=18.92; y[6]:=17.96; - y[7]:=12.98; y[8]:=6.45; - y[9]:=0.27; -end; { proceddure get data } - -procedure write_data; -{ print out the answers } -var i : integer; -begin - if first then first:=false else cls; - writeln; - writeln; - writeln(' I X Y YCALC RESID'); - for i:=1 to nrow do - writeln(i:3,x[i]:8:1,y[i]:9:2,y_calc[i]:9:2,resid[i]:9:2); - writeln; writeln(' Coefficients errors '); - writeln(coef[1],' ',sig[1],' Constant term'); - for i:=2 to ncol do - writeln(coef[i],' ',sig[i]); { other terms } - writeln; - writeln('Correlation coefficient is ',correl_coef:8:5) -end; { write_data } - -{procedure square(x: ary2; - y: ary; - var a: ary2s; - var g: arys; - nrow,ncol: integer);} -{ matrix multiplication routine } -{ a= transpose x times x } -{ g= y times x } -{$I SQUARE.LIB } - -{external procedure gaussj(var b: ary2s; - y: arys; - var coef: arys; - ncol: integer; - var error: boolean); -} -{$I GAUSSJ.LIB } - -procedure linfit(x, { independant variable } - y: ary; { dependent variable } - var y_calc: ary; { calculated dep. variable } - var resid: ary; { array of residuals } - var coef: arys; { coefficients } - var sig: arys; { error on coefficients } - nrow: integer; { length of array } - var ncol: integer); { number of terms } - -{ least squares fit to nrow sets of x and y pairs of points } -{ Seperate procedures needed: - SQUARE -> form square coefficient matrix - GAUSSJ -> Gauss-Jordan elimination } - -var xmatr : ary2; { data matrix } - a : ary2s; { coefficient matrix } - g : arys; { constant vector } - error : boolean; - i,j,nm : integer; - xi,yi,yc,srs,see, - sum_y,sum_y2 : real; - -begin { procedure linfit } - for i:=1 to nrow do - begin { setup matrix } - xi:=x[i]; - xmatr[i,1]:=1.0; { first column } - for j:=2 to ncol do { other columns} - xmatr[i,j]:=xmatr[i,j-1]*xi - end; - square(xmatr,y,a,g,nrow,ncol); - gaussj(a,g,coef,ncol,error); - sum_y:=0.0; - sum_y2:=0.0; - srs:=0.0; - for i:=1 to nrow do - begin - yi:=y[i]; - yc:=0.0; - for j:=1 to ncol do - yc:=yc+coef[j]*xmatr[i,j]; - y_calc[i]:=yc; - resid[i]:=yc-yi; - srs:=srs+sqr(resid[i]); - sum_y:=sum_y+yi; - sum_y2:=sum_y2+yi*yi - end; - correl_coef:=sqrt(1.0-srs/(sum_y2-sqr(sum_y)/nrow)); - if nrow=ncol then nm:=1 - else nm:=nrow-ncol; - see:=sqrt(srs/nm); - for i:=1 to ncol do { errors on solution } - sig[i]:=see*sqrt(a[i,i]) -end; { linfit } - -{external procedure plot(x,y,z: ary; nrow: integer); -} -{$I C:PLOT.LIB } - -begin { main program } - cls; - first:=true; - done:=false; - writeln; - get_data(x,y,nrow); - repeat - repeat - write('Order of polynomial fit? '); - readln(ncol) - until ncol<5; - if ncol<1 then done:=true { quit if ncol<1 } - else - begin - ncol:=ncol+1; { order is one less } - linfit(x,y,y_calc,resid,coef,sig,nrow,ncol); - write_data; - plot(x,y,y_calc,nrow) - end { else } - until done -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/LEAST6.PAS b/software/CPM/CPM18_MTPUG_06/LEAST6.PAS deleted file mode 100644 index b748560..0000000 --- a/software/CPM/CPM18_MTPUG_06/LEAST6.PAS +++ /dev/null @@ -1,149 +0,0 @@ -program least3; { --> 226 } -{ Pascal program to perform a linear least-squares fit } -{ on the properties of steam with Gauss-Jordan routine } -{ Seperate modules needed: - GAUSSJ} - - -const maxr = 20; { data prints } - maxc = 4; { polynomial terms } - -type ary = array[1..maxr] of real; - arys = array[1..maxc] of real; - ary2 = array[1..maxr,1..maxc] of real; - ary2s = array[1..maxc,1..maxc] of real; - -var p,t,v, - y,y_calc : ary; - resid : ary; - coef,sig : arys; - nrow,ncol : integer; - correl_coef : real; - -external procedure cls; - -procedure get_data(var p,t: ary; { independant variable } - var v: ary; { dependant variable } - var nrow: integer); { length of vectors } -{ get values for n and arrays x,y } - -var i : integer; - -begin - nrow:=12; - t[1]:=400; p[1]:=120; v[1]:=4.079; - t[2]:=450; p[2]:=120; v[2]:=4.36; - t[3]:=500; p[3]:=120; v[3]:=4.633; - t[4]:=400; p[4]:=140; v[4]:=3.466; - t[5]:=450; p[5]:=140; v[5]:=3.713; - t[6]:=500; p[6]:=140; v[6]:=3.952; - t[7]:=400; p[7]:=160; v[7]:=3.007; - t[8]:=450; p[8]:=160; v[8]:=3.228; - t[9]:=500; p[9]:=160; v[9]:=3.440; - t[10]:=400; p[10]:=180; v[10]:=2.648; - t[11]:=450; p[11]:=180; v[11]:=2.850; - t[12]:=500; p[12]:=180; v[12]:=3.042; - for i:=1 to nrow do - t[i]:=t[i]+460.0 { convert to Rankine } -end; { proceddure get data } - -procedure write_data; -{ print out the answers } -var i : integer; -begin - writeln; - writeln(' I P T V Y YCALC %RES'); - for i:=1 to nrow do - writeln(i:3,p[i]:7:1,t[i]:7:1,v[i]:7:3,y[i]:9:2,y_calc[i]:9:2, - (100.0*resid[i]/y[i]):9:2); - writeln; writeln(' Coefficients errors '); - writeln(coef[1],' ',sig[1],' Constant term'); - for i:=2 to ncol do - writeln(coef[i],' ',sig[i]); { other terms } - writeln; - writeln('Correlation coefficient is ',correl_coef:8:5) -end; { write_data } - -{procedure square(x: ary2; - y: ary; - var a: ary2s; - var g: arys; - nrow,ncol: integer);} -{ matrix multiplication routine } -{ a= transpose x times x } -{ g= y times x } -{$I SQUARE.LIB } - -{external procedure gaussj(var b: ary2s; - y: arys; - var coef: arys; - ncol: integer; - var error: boolean); -} -{$I GAUSSJ.LIB } - -procedure linfit(p,t,v: ary; { independant variable } - var y: ary; { dependent variable } - var y_calc: ary; { calculated dep. variable } - var resid: ary; { array of residuals } - var coef: arys; { coefficients } - var sig: arys; { error on coefficients } - nrow: integer; { length of array } - var ncol: integer); { number of terms } - -{ least squares fit to nrow sets of x and y pairs of points } -{ Seperate procedures needed: - SQUARE -> form square coefficient matrix - GAUSSJ -> Gauss-Jordan elimination } - -const r = 85.76; { gas constant for steam } - -var xmatr : ary2; { data matrix } - a : ary2s; { coefficient matrix } - g : arys; { constant vector } - error : boolean; - i,j,nm : integer; - power,yi,yc,srs,see, - sum_y,sum_y2 : real; - -begin { procedure linfit } - ncol:=2; { number of terms } - for i:=1 to nrow do - begin { setup matrix } - power:=t[i]; - xmatr[i,1]:=p[i]/power; { first column } - xmatr[i,2]:=sqrt(p[i]); { second column } - y[i]:=v[i]*p[i]-r*t[i]/144.0 - end; - square(xmatr,y,a,g,nrow,ncol); - gaussj(a,g,coef,ncol,error); - sum_y:=0.0; - sum_y2:=0.0; - srs:=0.0; - for i:=1 to nrow do - begin - yi:=y[i]; - yc:=0.0; - for j:=1 to ncol do - yc:=yc+coef[j]*xmatr[i,j]; - y_calc[i]:=yc; - resid[i]:=yc-yi; - srs:=srs+sqr(resid[i]); - sum_y:=sum_y+yi; - sum_y2:=sum_y2+yi*yi - end; - correl_coef:=sqrt(1.0-srs/(sum_y2-sqr(sum_y)/nrow)); - if nrow=ncol then nm:=1 - else nm:=nrow-ncol; - see:=sqrt(srs/nm); - for i:=1 to ncol do { errors on solution } - sig[i]:=see*sqrt(a[i,i]) -end; { linfit } - -begin { main program } - cls; - get_data(p,t,v,nrow); - linfit(p,t,v,y,y_calc,resid,coef,sig,nrow,ncol); - write_data -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/LINFIT1.LIB b/software/CPM/CPM18_MTPUG_06/LINFIT1.LIB deleted file mode 100644 index 6065696..0000000 --- a/software/CPM/CPM18_MTPUG_06/LINFIT1.LIB +++ /dev/null @@ -1,40 +0,0 @@ - -{ -> 159 } -procedure linfit(x,y: ary; - var y_calc: ary; - var a,b: real; - n: integer); -{ fit a straight line (y_calc) through n sets of x and y pairs of points } - -var i : integer; - - sum_x,sum_y,sum_xy,sum_x2, - sum_y2,xi,yi,sxy,sxx, - syy : real; - -begin { linfit } - sum_x:=0.0; - sum_y:=0.0; - sum_xy:=0.0; - sum_x2:=0.0; - sum_y2:=0.0; - for i:=1 to n do - begin - xi:=x[i]; - yi:=y[i]; - sum_x:=sum_x+xi; - sum_y:=sum_y+yi; - sum_xy:=sum_xy+xi*yi; - sum_x2:=sum_x2+xi*xi; - sum_y2:=sum_y2+yi*yi; - end; - sxx:=sum_x2-sum_x*sum_x/n; - sxy:=sum_xy-sum_x*sum_y/n; - syy:=sum_y2-sum_y*sum_y/n; - b:=sxy/sxx; - a:=((sum_x2*sum_y-sum_x*sum_xy)/n)/sxx; - for i:=1 to n do - y_calc[i]:=a+b*x[i] -end; { LINFIT } - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/LINFIT2.LIB b/software/CPM/CPM18_MTPUG_06/LINFIT2.LIB deleted file mode 100644 index 22cf66d..0000000 --- a/software/CPM/CPM18_MTPUG_06/LINFIT2.LIB +++ /dev/null @@ -1,44 +0,0 @@ -{159} {update ->} {166} -procedure linfit(x,y: ary; - var y_calc: ary; - var a,b: real; - n: integer); -{ fit a straight line (y_calc) through n sets of x and y pairs of points } - -var i : integer; - - sum_x,sum_y,sum_xy,sum_x2, - sum_y2,xi,yi,sxy,syy, - sxx : real; - -begin { linfit } - sum_x:=0.0; - sum_y:=0.0; - sum_xy:=0.0; - sum_x2:=0.0; - sum_y2:=0.0; - for i:=1 to n do - begin - xi:=x[i]; - yi:=y[i]; - sum_x:=sum_x+xi; - sum_y:=sum_y+yi; - sum_xy:=sum_xy+xi*yi; - sum_x2:=sum_x2+xi*xi; - sum_y2:=sum_y2+yi*yi; - end; - sxx:=sum_x2-sum_x*sum_x/n; - sxy:=sum_xy-sum_x*sum_y/n; - syy:=sum_y2-sum_y*sum_y/n; - b:=sxy/sxx; - a:=((sum_x2*sum_y-sum_x*sum_xy)/n)/sxx; - correl_coef:=sxy/sqrt(sxx*syy); - see:=sqrt((sum_y2-a*sum_y-b*sum_xy)/(n-2)); - sigma_b:=see/sqrt(sxx); - sigma_a:=sigma_b*sqrt(sum_x2/n); - - for i:=1 to n do - y_calc[i]:=a+b*x[i] -end; { LINFIT } - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/MATR1.PAS b/software/CPM/CPM18_MTPUG_06/MATR1.PAS deleted file mode 100644 index 1dd3018..0000000 --- a/software/CPM/CPM18_MTPUG_06/MATR1.PAS +++ /dev/null @@ -1,107 +0,0 @@ -program matr1; { -> 50 } -{ pascal program to perform matrix multiplication } - -const rmax = 9; - cmax = 3; - - -type ary = array[1..rmax] of real; - arys = array[1..cmax] of real; - ary2 = array[1..rmax,1..cmax] of real; - ary2s = array[1..cmax,1..cmax] of real; - -var y : ary; - g : arys; - x : ary2; - a : ary2s; - nrow,ncol : integer; - -external procedure cls; - -procedure get_data(var x: ary2; - var y: ary; - var nrow,ncol: integer); - -{ get the values for nrow, ncol, and arrays x,y } - -var i,j : integer; - -begin - nrow:=5; - ncol:=3; - for i:=1 to nrow do - begin - x[i,1]:=1; - for j:=2 to ncol do - x[i,j]:=i*x[i,j-1]; - y[i]:=2*i - end -end; { procedure get_data } - - - -procedure write_data; - -{ print out the answeres } - -var - i,j : integer; - -begin - cls; - writeln; - writeln(' X Y'); - for i:=1 to nrow do - begin - for j:=1 to ncol do - write(x[i,j]:7:1,' '); - writeln(':',y[i]:7:1) - end; - writeln(' A G'); - for i:=1 to ncol do - begin - for j:=1 to ncol do - write(a[i,j]:7:1,' '); - writeln(':',g[i]:7:1) - end -end; { write_data } - - -procedure square(x: ary2; - y: ary; - var a: ary2s; - var g: arys; - nrow,ncol: integer); - -{ matrix multiplication routine } -{ a= transpose x times x } -{ g= y times x } - -var - i,k,l : integer; - -begin { square } - for k:=1 to ncol do - begin - for l:=1 to k do - begin - a[k,l]:=0; - for i:=1 to nrow do - begin - a[k,l]:=a[k,l]+x[i,l]*x[i,k]; - if k<>l then a[l,k]:=a[k,l] - end - end; { l-loop } - g[k]:=0; - for i:=1 to nrow do - g[k]:=g[k]+y[i]*x[i,k] - end { k-loop } -end; { square } - - -begin { MAIN program } - get_data(x,y,nrow,ncol); - square(x,y,a,g,nrow,ncol); - write_data -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/MEANS.PAS b/software/CPM/CPM18_MTPUG_06/MEANS.PAS deleted file mode 100644 index 83f82b6..0000000 --- a/software/CPM/CPM18_MTPUG_06/MEANS.PAS +++ /dev/null @@ -1,54 +0,0 @@ -program means; { -> 26 } -{find mean and standard deviation } - -const max = 80; - -type ary = array[1..max]of real; - -var x : ary; - i,n : integer; - mean,std: real; - -external procedure cls; - -procedure meanstd - (x : ary; {array of values} - length : integer; - var mean : real; - var std_dev : real); - -var - i : integer; - sum_x,sum_sq : real; - - - -begin {main} - sum_x:=0; - sum_sq:=0; - for i:=1 to length do - begin - sum_x:=sum_x+x[i]; - sum_sq:=sum_sq+x[i]*x[i] - end; - mean:=sum_x/length; - std_dev:=sqrt((sum_sq-sqr(sum_x)/length)/(length-1)) -end { procedure meanstd }; - -begin { MAIN program } - cls; - writeln; - writeln('Calculation of mean and standard deviation'); - repeat - write('How many points? '); - readln(n) - until n<=max; - for i:=1 to n do - begin - write(i:3,':'); - readln(x[i]) - end; - meanstd(x,n,mean,std); - writeln(chr(7),'For ',n:3,' points, mean= ',mean:8:4,' sigma= ',std:8:4) -end. { MAIN program } - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/NEWDR.PAS b/software/CPM/CPM18_MTPUG_06/NEWDR.PAS deleted file mode 100644 index ad3b0e1..0000000 --- a/software/CPM/CPM18_MTPUG_06/NEWDR.PAS +++ /dev/null @@ -1,39 +0,0 @@ -program newdr; { -> 243 } -var x,x2 : real; - alldone : boolean; - error : boolean; - -external procedure cls; - -procedure func(x: real; - var fx,dfx: real); -begin - fx:=x*x-2.0; - dfx:=2.0*x -end; { func } - -procedure newton(var x: real); -const tol = 1.0E-6; - -var fx,dfx,dx,x1: real; - -begin { newton } - repeat - x1:=x; - func(x,fx,dfx); - dx:=fx/dfx; - x:=x1-dx; - writeln('x=',x1,' fx=',fx,' dfx=',dfx); - until abs(dx)<=abs(tol*x) -end; { newton } - -begin { main program } - cls; - writeln; - x:=2.0; { first guess } - newton(x); - writeln; - writeln(chr(7),'The solution is ',x); - writeln -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/NEWDR2.PAS b/software/CPM/CPM18_MTPUG_06/NEWDR2.PAS deleted file mode 100644 index f54c730..0000000 --- a/software/CPM/CPM18_MTPUG_06/NEWDR2.PAS +++ /dev/null @@ -1,45 +0,0 @@ -program newdr; { -> 245 } - -var x,x2 : real; - alldone : boolean; - error : boolean; - -procedure func(x: real; - var fx,dfx: real); -begin - fx:=x*x-2.0; - dfx:=2.0*x -end; { func } - -procedure newton(var x: real); -const tol = 1.0E-6; - -var fx,dfx,dx,x1: real; - -begin { newton } - repeat - x1:=x; - func(x,fx,dfx); - dx:=fx/dfx; - x:=x1-dx; - writeln('x=',x1,',fx=',fx,',dfx=',dfx); - until abs(dx)<=abs(tol*x) -end; { newton } - -begin { main program } - alldone:=false; - repeat - writeln; - write('First guess: '); { first guess } - readln(x); - if x<-19.0 then alldone:=true - else - begin - newton(x); - writeln; - writeln('The solution is ',x); - writeln - end - until alldone -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/NEWTON-L.LIB b/software/CPM/CPM18_MTPUG_06/NEWTON-L.LIB deleted file mode 100644 index e7bb747..0000000 --- a/software/CPM/CPM18_MTPUG_06/NEWTON-L.LIB +++ /dev/null @@ -1,42 +0,0 @@ - - - -{ -> 252 } -procedure newton(var x: real); -const tol = 1.0E-6; - max = 20; -var fx,dfx,dx,x1 : real; - i : integer; - -begin { newton } - error:=false; - i:=0; - repeat - i:=i+1; - x1:=x; - func(x,fx,dfx); - if dfx=0.0 then - begin - error:=true; - x:=1.0; - writeln(chr(7),'ERROR: slope zero') - end - else - begin - dx:=fx/dfx; - x:=x1-dx; - writeln('x=',x,' fx=',fx,' dfx=',dfx) - end - until - error or - (i>max) or - (abs(dx)<=abs(tol*x)); - if i>max then - begin - writeln(chr(7),'ERROR: no convergence in ',max,' loops'); - error:=true - end -end; { newton } - - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/NEWTON.LIB b/software/CPM/CPM18_MTPUG_06/NEWTON.LIB deleted file mode 100644 index b5b74ad..0000000 --- a/software/CPM/CPM18_MTPUG_06/NEWTON.LIB +++ /dev/null @@ -1,32 +0,0 @@ - - - -{ -> 249 } -procedure newton(var x: real); -const tol = 1.0E-6; -var fx,dfx,dx,x1 : real; - -begin { newton } - error:=false; - repeat - x1:=x; - func(x,fx,dfx); - if dfx=0.0 then - begin - error:=true; - x:=1.0; - writeln(chr(7),'ERROR: slope zero') - end - else - begin - dx:=fx/dfx; - x:=x1-dx; - writeln('x=',x,' fx=',fx,' dfx=',dfx) - end - until - error or - (abs(dx)<=abs(tol*x)) -end; { newton } - - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/NLIN3.PAS b/software/CPM/CPM18_MTPUG_06/NLIN3.PAS deleted file mode 100644 index 8a21f6e..0000000 --- a/software/CPM/CPM18_MTPUG_06/NLIN3.PAS +++ /dev/null @@ -1,193 +0,0 @@ -{ die ln-funktion bei MT+ ist fuer Werte kleiner 1E-5 aeussertst langsam, - so dass man das Gefuehl bekommt, das dass Programm sich aufhaengt. In- - folgedessen konnte ich dieses Programm nicht verifizieren. -Juergen } - -program nlin3; { -> 310 } -{ Pascal program to perform a nonlinear least-squares fit for the diffusion - of Zn in CU } - -const maxr = 20; { data prints } - maxc = 4; { polynomial terms } - r = 1.987; { gas constant } -type - index = 1..maxr; - ary = array[index] of real; - arys = array[1..maxc] of real; - ary2 = array[1..maxr,1..maxc] of real; - -var - x,y,y_calc : ary; - t,d,ex : ary; - coef : arys; - i,n : integer; - nrow,ncol : integer; - done,error : boolean; - correl_coef,srs, - a,b,x2 : real; - -external procedure cls; - -procedure get_data(var x,y: ary; - var n: integer); -{ get values for n and arrays t,d } - -var i : integer; - -begin - n:=7; - t[1]:=600.0; d[1]:=1.4E-12; - t[2]:=650.0; d[2]:=5.5E-12; - t[3]:=700.0; d[3]:=1.8E-11; - t[4]:=750.0; d[4]:=6.1E-11; - t[5]:=800.0; d[5]:=1.6E-10; - t[6]:=850.0; d[6]:=4.4E-10; - t[7]:=900.0; d[7]:=1.2E-9; - for i:=1 to n do - begin - x[i]:=1.0/(t[i]+273.0); - y[i]:=d[i] - end -end; { proceddure get data } - -procedure write_data; -{ print out the answers } -var i : integer; -begin - writeln; - writeln; - writeln(' I TC D DCALC'); - for i:=1 to n do - writeln(i:3,t[i]:8:0,d[i],' ',y_calc[i]); - writeln; writeln(' Coefficients '); - writeln(coef[1],' constant term'); - for i:=2 to ncol do - writeln(coef[i]); { other terms } - writeln; - writeln('D0=',a:7:2,' cm sq/sec.'); - writeln('Q =',(-r*b/1000.0):8:2,'kcal/mole'); - writeln;writeln('SRS= ',srs:8:4) -end; { write_data } - -procedure func(b: real; - var fb,dfb: real); -var i : integer; - s1,s2,s3,s4,s5,s6, - ex1,ex2,xi, - x2,yi,y2 : real; -begin - s1:=0.0; - s2:=0.0; - s3:=0.0; - s4:=0.0; - s5:=0.0; - s6:=0.0; - for i:=1 to n do - begin - xi:=x[i]; - x2:=xi*xi; - yi:=y[i]; - y2:=yi*yi; - ex1:=exp(b*xi); - ex[i]:=ex1; - ex2:=ex1*ex1; - s1:=s1+xi*ex2/y2; - s2:=s2+ex1/yi; - s3:=s3+xi*ex1/yi; - s4:=s4+ex2/y2; - s5:=s5+2.0*x2*ex2/y2; - s6:=s6+x2*ex1/yi - end; - fb:=s1*s2-s3*s4; - dfb:=s2*s5-s1*s3-s4*s6; - a:=s2/s4 -end; { func } - - -procedure newton(var x: real); -const tol = 1.0E-6; - max = 20; -var fx,dfx,dx,x1 : real; - i : integer; - -begin { newton } - error:=false; - i:=0; - repeat - i:=i+1; - x1:=x; - func(x,fx,dfx); - if dfx=0.0 then - begin - error:=true; - x:=1.0; - writeln('ERROR: slope zero') - end - else - begin - dx:=fx/dfx; - x:=x1-dx; - end - until - error or - (i>max) or - (abs(dx)<=abs(tol*x)); - if i>max then - begin - writeln(chr(7),'ERROR: no convergence in ',max,' loops'); - error:=true - end -end; { newton } - -procedure nlin(x,y: ary; - var y_calc: ary; - n: integer); -{ fits the diffusion equation through n sets of x and y pairs of points } -var - resid : ary; - matr : ary2; - i : integer; - xi,yi,sum_x, - sum_y,sum_y2,b1, - sum_xy,sum_x2 : real; -begin { nlin } - ncol:=2; { number of terms } - sum_x:=0.0; - sum_y:=0.0; - sum_xy:=0.0; - sum_x2:=0.0; - for i:=1 to n do - begin - xi:=x[i]; - yi:=ln(y[i]); - sum_x:=sum_x+xi; - sum_y:=sum_y+yi; - sum_y2:=sum_y2+yi*yi; - sum_xy:=sum_xy+xi*yi; - sum_x2:=sum_x2+xi*xi - end; - b:=(sum_xy-sum_x*sum_y/n)/(sum_x2-sqr(sum_x)/n); - newton(b); - coef[1]:=a; - coef[2]:=b; - srs:=0.0; - for i:=1 to n do - begin - y_calc[i]:=a*ex[i]; - if y[i]<>0.0 then - resid[i]:=y_calc[i]/y[i]-1.0 - else resid[i]:=y[i]/y_calc[i]-1.0; - srs:=srs+sqr(resid[i]) - end -end; { nlin } - - -begin { main program } - cls; -writeln(' start get_data '); - get_data(x,y,n); -writeln(' start nlin '); - nlin(x,y,y_calc,n); -writeln(' start write_data '); - write_data -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/PLOT.LIB b/software/CPM/CPM18_MTPUG_06/PLOT.LIB deleted file mode 100644 index ac38be6..0000000 --- a/software/CPM/CPM18_MTPUG_06/PLOT.LIB +++ /dev/null @@ -1,147 +0,0 @@ - -procedure plot( { with arrays } - x, { as independant variable } - y, { as dependant variable } - ycalc { as fitted curve } - : ary; - { and } m : integer { number of points }); - -{ plot y and ycalc as a function of x for m points } -{ if m is negative, only x and y are plotted } - -const blank = ' '; - linel = 51; - -var - ylabel : array[1..6] of real; - out : array[1..linel] of char; - lines,i,j,jp,l,n: integer; - iskip,yonly : boolean; - - xlow,xhigh,xnext,xlabel,xscale,signxs, - ymin,ymax,change,yscale,ys10 : real; - -function pscale(p: real): integer; -begin - pscale:=trunc((p-ymin)/yscale+1) -end; { pscale} - -procedure outlin(xname: real); -{ output a line } - -var i,max : integer; - -begin - write(xname:8:2,blank); { line label } - max:=linel+1; - repeat { skip blanks on end of line } - max:=max-1 - until (out[max]<>blank) or (max=1); - for i:=1 to max do - write(out[i]); - writeln; - for i:=1 to max do - out[i]:=blank { blank next line } -end; { outlin} - -procedure setup(index: integer); -{ setup the plus and asterisk for printing } - -const star = '*'; - plus = '+'; - -var i : integer; - -begin - i:=pscale(y[index]); - out[i]:=plus; - if not yonly then - begin { add ycalc too } - i:=pscale(ycalc[index]); - out[i]:=star - end -end; { setup } - - -begin { body of plot } - if m>0 then { plot y and ycalc vs x } - begin - n:=m; - yonly:=false - end - else { plot only y vs x } - begin - n:=-m; - yonly:=true - end; - { space out alternate lines } - lines:=2*(n-1)+1; - writeln; - xlow:=x[1]; - xhigh:=x[n]; - ymax:=y[1]; - ymin:=ymax; - xscale:=(xhigh-xlow)/(lines-1); - signxs:=1.0; - if xscale<0.0 then signxs:=-1.0; - for i:=1 to n do - begin - if y[i]ymax then ymax:=y[i]; - if not yonly then - begin - if ycalc[i]ymax then ymax:=ycalc[i] - end { if yonly } - end; - yscale:=(ymax-ymin)/(linel-1); - ys10:=yscale*10; - ylabel[1]:=ymin; { y axis } - for i:=1 to 4 do - ylabel[i+1]:=ylabel[i]+ys10; - ylabel[6]:=ymax; - for i:=1 to linel do - out[i]:=blank; { blank line } - setup(1); - l:=1; - xlabel:=xlow; - iskip:=false; - - for i:=2 to lines do { set up a line } - begin - xnext:=xlow+xscale*(i-1); - if iskip then writeln(' -') - else - begin - l:=l+1; - while - (x[l]-(xnext-0.5*xscale))*signxs<=0.0 do - begin - setup(l); { setup print line } - l:=l+1 - end; { while } - outlin(xlabel); { print a line } - for j:=1 to linel do - out[j]:=blank { blank line } - end; { if skip } - if (x[l]-(xnext+0.5*xscale))*signxs>0.0 then iskip:=true - else - begin - iskip:=false; - xlabel:=xnext; - setup(l) { setup print line } - end - end; { for-loop } - outlin(xhigh); { last line } - write(' '); - for i:=1 to 6 do - write(' ^ '); - writeln; - write(' '); - for i:=1 to 6 do - write(ylabel[i]:9:1,blank); - writeln; - writeln -end; { PLOT } - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/RANDG.LIB b/software/CPM/CPM18_MTPUG_06/RANDG.LIB deleted file mode 100644 index 3da240b..0000000 --- a/software/CPM/CPM18_MTPUG_06/RANDG.LIB +++ /dev/null @@ -1,20 +0,0 @@ - -{ -> 35 } -function randg(mean,sigma: real): real; - -{ produce random numbers with a gaussian distribution } -{ MEAN and SIGMA are supplied by calling program } -{ function RANDOM is required !!! } - -var - i : integer; - sum : real; - -begin - sum:=0.0; - for i:=1 to 12 do - sum:=sum+random(0); - randg:=(sum-6)*sigma+mean -end; { function randg } - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/RANDOM.LIB b/software/CPM/CPM18_MTPUG_06/RANDOM.LIB deleted file mode 100644 index 9f9599e..0000000 --- a/software/CPM/CPM18_MTPUG_06/RANDOM.LIB +++ /dev/null @@ -1,20 +0,0 @@ -function random(dummy: integer): real; { --> 29} -{ random number 0-1 } - { DEFINE SEED=4.0 AS GLOBAL !!!!!!!! } -{ adapted from HP-35 applications programs } - -const - pi = 3.14159; - -var - x : real; - i : integer; - -begin { RANDOM } - x:=seed+pi; - x:=exp(5.0*ln(x)); - seed:=x-trunc(x); - random:=seed -end; { RANDOM } - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/RANDOM.PAS b/software/CPM/CPM18_MTPUG_06/RANDOM.PAS deleted file mode 100644 index 197b198..0000000 --- a/software/CPM/CPM18_MTPUG_06/RANDOM.PAS +++ /dev/null @@ -1,26 +0,0 @@ -module random; {29} - -function random(dummy: integer): real; - -{ random number 0-1 } - - { DEFINE SEED=4.0 AS GLOBAL !!!!!!!! } - -{ adapted from HP-35 applications programs } - -const - pi = 3.14159; - -var - x : real; - i : integer; - -begin { RANDOM } - x:=seed+pi; - x:=exp(5.0*ln(x)); - seed:=x-trunc(x); - random:=seed -end; { RANDOM } - -modend. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/ROMB1.PAS b/software/CPM/CPM18_MTPUG_06/ROMB1.PAS deleted file mode 100644 index ee9d650..0000000 --- a/software/CPM/CPM18_MTPUG_06/ROMB1.PAS +++ /dev/null @@ -1,91 +0,0 @@ -program romb1; { -> 281 } -{ integration by the romberg method } - -const tol = 1.0E-4; -var done : boolean; - sum,upper,lower : real; - -external procedure cls; - -function fx(x: real): real; -{ find f(x)= 1.0/x; watch out for x=0 } -begin - fx:=1.0/x -end; - -procedure romb(function f(x:real): real; - lower,upper,tol: real; - var ans: real); -{ numerical integration by the Romberg method } -var - nx : array[1..16] of integer; - t : array[1..136] of real; - done,error : boolean; - pieces,nt,i,ii,n,nn, - l,ntra,k,m,j : integer ; - delta_x,c,sum,fotom,x : real ; -begin - done:=false; - error:=false; - pieces:=1; - nx[1]:=1; - delta_x:=(upper-lower)/pieces; - c:=(f(lower)+f(upper))*0.5; - t[1]:=delta_x*c; - n:=1; - nn:=2; - sum:=c; - repeat - n:=n+1; - fotom:=4.0; - nx[n]:=nn; - pieces:=pieces*2; - l:=pieces-1; - delta_x:=(upper-lower)/pieces; - { compute trapezoidal sum for 2^(n-1)+1 points } - for ii:=1 to (l+1) div 2 do - begin - i:=ii*2-1; - x:=lower+i*delta_x; - sum:=sum+f(x) - end; - t[nn]:=delta_x*sum; - write(pieces:5,t[nn]); - ntra:=nx[n-1]; - k:=n-1; - { compute n-th row of T array } - for m:=1 to k do - begin - j:=nn+m; - nt:=nx[n-1]+m-1; - t[j]:=(fotom*t[j-1]-t[nt])/(fotom-1.0); - fotom:=fotom*4.0 - end; - writeln(j:4,t[j]); - if n>4 then - begin - if t[nn+1]<>0.0 then - if (abs(t[ntra+1]-t[nn+1])<=abs(t[nn+1]*tol)) - or (abs(t[nn-1]-t[j])<=abs(t[j]*tol)) then - done:=true - else if n>15 then - begin - done:=true; - error:=true - end - end; { if n>4 } - nn:=j+1 - until done; - ans:=t[j] -end; { ROMBERG } - -begin { main program } - cls; - lower:=1.0; - upper:=9.0; - writeln; - romb(fx,lower,upper,tol,sum); - writeln; - writeln(chr(7),'Area= ',sum) -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/ROMB3.PAS b/software/CPM/CPM18_MTPUG_06/ROMB3.PAS deleted file mode 100644 index 6f81437..0000000 --- a/software/CPM/CPM18_MTPUG_06/ROMB3.PAS +++ /dev/null @@ -1,96 +0,0 @@ -program romb3; { -> 287 } -{ integration by the romberg method } - -const tol = 1.0E-4; -var done : boolean; - sumt : real; - sum,upper,lower : real; - -external procedure cls; - -function fx(x: real): real; -{ find f(x)= 1/sqrt(x); watch out for x=0 } -begin - fx:=1.0/sqrt(x) -end; - -procedure romb(function f(x: real): real; - lower,upper,tol: real; - var ans: real); -{ numerical integration by the Romberg method } -var - nx : array[1..16] of integer; - t : array[1..136] of real; - done,error : boolean; - pieces,nt,i,ii,n,nn, - l,ntra,k,m,j : integer ; - delta_x,c,sum,fotom,x : real ; -begin - done:=false; - error:=false; - pieces:=1; - nx[1]:=1; - delta_x:=(upper-lower)/pieces; - c:=(f(lower)+f(upper))*0.5; - t[1]:=delta_x*c; - n:=1; - nn:=2; - sum:=c; - repeat - n:=n+1; - fotom:=4.0; - nx[n]:=nn; - pieces:=pieces*2; - l:=pieces-1; - delta_x:=(upper-lower)/pieces; - { compute trapezoidal sum for 2^(n-1)+1 points } - for ii:=1 to (l+1) div 2 do - begin - i:=ii*2-1; - x:=lower+i*delta_x; - sum:=sum+f(x) - end; - t[nn]:=delta_x*sum; - ntra:=nx[n-1]; - k:=n-1; - { compute n-th row of T array } - for m:=1 to k do - begin - j:=nn+m; - nt:=nx[n-1]+m-1; - t[j]:=(fotom*t[j-1]-t[nt])/(fotom-1.0); - fotom:=fotom*4.0 - end; - if n>4 then - begin - if t[nn+1]<>0.0 then - if (abs(t[ntra+1]-t[nn+1])<=abs(t[nn+1]*tol)) - or (abs(t[nn-1]-t[j])<=abs(t[j]*tol)) then - done:=true - else if n>15 then - begin - done:=true; - error:=true - end - end; { if n>4 } - nn:=j+1 - until done; - ans:=t[j] -end; { ROMBERG } - -begin { main program } - cls; - lower:=0.1; - upper:=1.0; - writeln; - sumt:=0.0; - writeln('new area total area lower upper limits'); - repeat - romb(fx,lower,upper,tol,sum); - upper:=lower; - lower:=0.1*upper; - sumt:=sumt+sum; - writeln(sum:9:6,' ',sumt:9:5,' ',lower,' ',upper) - until abs(sum) 273 } -{ integration by Simpson's method } - -const tol = 1.0E-4; -var sum,upper,lower : real; - -external procedure cls; - -function fx(x: real): real; -{ find f(x)=1/x } -{ watch out for x=0 } - -begin - fx:=1.0/x -end; { function fx } - -procedure simps(function f(x: real): real; - lower,upper,tol : real; - var sum : real); - -{ numerical integration by Simpson's rule } -{ function is f (as paramater), limits are lower and upper } -{ with number of regions equal to pieces } -{ partition is delta_x, answer is sum } - -var i : integer; - x,delta_x,even_sum, - odd_sum,end_sum, - sum1 : real; - pieces : integer; -begin - pieces:=2; - delta_x:=(upper-lower)/pieces; - odd_sum:=f(lower+delta_x); - even_sum:=0.0; - end_sum:=f(lower)+f(upper); - sum:=(end_sum+4.0*odd_sum)*delta_x/3.0; - writeln(pieces:5,sum); - repeat - pieces:=pieces*2; - sum1:=sum; - delta_x:=(upper-lower)/pieces; - even_sum:=even_sum+odd_sum; - odd_sum:=0.0; - for i:=1 to pieces div 2 do - begin - x:=lower+delta_x*(2.0*i-1.0); - odd_sum:=odd_sum+f(x) - end; - sum:=(end_sum+4.0*odd_sum+2.0*even_sum)*delta_x/3.0; - writeln(pieces:5,sum) - until abs(sum-sum1)<=abs(tol*sum) -end; { simps } - -begin { main program } - cls; - lower:=1.0; - upper:=9.0; - writeln; - simps(fx,lower,upper,tol,sum); - writeln; - writeln(chr(7),'area= ',sum) -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/SIMPS.LIB b/software/CPM/CPM18_MTPUG_06/SIMPS.LIB deleted file mode 100644 index 4cf0dd8..0000000 --- a/software/CPM/CPM18_MTPUG_06/SIMPS.LIB +++ /dev/null @@ -1,50 +0,0 @@ - - -{ -> 278 } -procedure simps(function f(x: real): real; - lower,upper,tol : real; - var sum : real); - -{ numerical integration by Simpson's rule } -{ function is f (as parameter), limits are lower and upper } -{ with number of regions equal to pieces } -{ partition is delta_x, answer is sum } - -var i : integer; - x,delta_x,even_sum, - odd_sum,end_sum, - end_cor,sum1 : real; - pieces : integer; - -function dfx(x:real):real; -begin - dfx:=-1.0/sqr(x) -end; - -begin - pieces:=2; - delta_x:=(upper-lower)/pieces; - odd_sum:=f(lower+delta_x); - even_sum:=0.0; - end_sum:=f(lower)+f(upper); - end_cor:=dfx(lower)-dfx(upper); - sum:=(end_sum+4.0*odd_sum)*delta_x/3.0; - repeat - pieces:=pieces*2; - sum1:=sum; - delta_x:=(upper-lower)/pieces; - even_sum:=even_sum+odd_sum; - odd_sum:=0.0; - for i:=1 to pieces div 2 do - begin - x:=lower+delta_x*(2.0*i-1.0); - odd_sum:=odd_sum+f(x) - end; - sum:=(7.0*end_sum+14.0*even_sum+16.00*odd_sum - +end_cor*delta_x)*delta_x/15.0; - until abs(sum-sum1)<=abs(tol*sum) -end; { simps } - - - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/SIMQ1.PAS b/software/CPM/CPM18_MTPUG_06/SIMQ1.PAS deleted file mode 100644 index 08a4032..0000000 --- a/software/CPM/CPM18_MTPUG_06/SIMQ1.PAS +++ /dev/null @@ -1,139 +0,0 @@ -program simq1; { -> 67 } -{ pascal program to solve three simultaneous equations by Cramer's rule } - -const rmax = 3; - cmax = 3; - -type arys = array[1..cmax] of real; - ary2s = array[1..rmax,1..cmax] of real; - -var y,coef : arys; - a : ary2s; - n : integer; - yesno : char; - error : boolean; - -external procedure cls; - -procedure get_data(var a: ary2s; - var y: arys; - var n: integer); - -{ get the values for n, and arrays a,y } - -var i,j : integer; - -begin { procedure get_data } - writeln; - n:=rmax; - for i:=1 to n do - begin - writeln(' Equation',i:3); - for j:=1 to n do - begin - write(j:3,':'); - read(a[i,j]) - end; - write(',C:'); - readln(y[i]) - end; - writeln; - for i:=1 to n do - begin - for j:=1 to n do - write(a[i,j]:7:4,' '); - writeln(':',y[i]:7:4) - end; - writeln -end; { procedure get_data } - -procedure write_data; - { print out the answeres } - -var i : integer; - -begin { write_data } - for i:=1 to n do - write(coef[i]:9:5); - writeln -end; { write_data } - - -procedure solve(a: ary2s; - y: arys; - var coef: arys; - n: integer; - var error: boolean); - -var - b : ary2s; - i,j : integer; - det : real; - - - -function deter(a: ary2s): real; -{ pascal program to calculate the determinant of a 3-by-3matrix } - -var - sum : real; - -begin { function deter } - sum:=a[1,1]*(a[2,2]*a[3,3]-a[3,2]*a[2,3]) - -a[1,2]*(a[2,1]*a[3,3]-a[3,1]*a[2,3]) - +a[1,3]*(a[2,1]*a[3,2]-a[3,1]*a[2,2]); - deter:=sum -end; { function deter } - - - -procedure setup(var b: ary2s; - var coef: arys; - j: integer); - -var i : integer; - -begin { setup } - for i:=1 to n do - begin - b[i,j]:=y[i]; - if j>1 then b[i,j-1]:=a[i,j-1] - end; - coef[j]:=deter(b)/det -end; { setup } - -begin { procedure solve } - error:=false; - for i:=1 to n do - for j:=1 to n do - b[i,j]:=a[i,j]; - det:=deter(b); - if det=0.0 then - begin - error:=true; - writeln(chr(7),'ERROR: matrix is singular.') - end - else - begin - setup(b,coef,1); - setup(b,coef,2); - setup(b,coef,3); - end { else } -end; {procedure solve } - - -begin { MAIN program } - cls; - writeln; - writeln('Simultaneous solution by Cramers rule'); - repeat - get_data(a,y,n); - solve(a,y,coef,n,error); - if not error then write_data; - writeln; - write('More?'); - readln(yesno); - cls - until(yesno<>'Y')and(yesno<>'y') -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/SOLVEC.PAS b/software/CPM/CPM18_MTPUG_06/SOLVEC.PAS deleted file mode 100644 index 4106836..0000000 --- a/software/CPM/CPM18_MTPUG_06/SOLVEC.PAS +++ /dev/null @@ -1,178 +0,0 @@ -program solvec; { -> 119 } -{ pascal program to perform simultaneous solution by Gauss-Jordan elimination} -{ for complex coefficients } - -const maxr = 8; - maxc = 8; - -type ary = array[1..maxr] of real; - arys = array[1..maxc] of real; - ary2s = array[1..maxr,1..maxc] of real; - aryc2 = array[1..maxr,1..maxc,1..2] of real; - aryc = array[1..maxr,1..2] of real; - -var y : arys; - coef : arys; - a,b : ary2s; - n,m,i,j : integer; - error : boolean; - -external procedure cls; -external procedure revon; -external procedure revoff; - - - -procedure get_data(var a: ary2s; - var y: arys; - var n,m: integer); - -{ get complex values for n and arrays a,y } - -var c : aryc2; - v : aryc; - i,j,k,l : integer; - -procedure show; - { print original data } -var i,j,k : integer; - -begin { show } - writeln; - for i:=1 to n do - begin - for j:=1 to m do - for k:=1 to 2 do - write(c[i,j,k]:7:4,' '); - writeln(':',v[i,1]:7:4,':',v[i,2]:7:4) - end; - n:=2*n; - m:=n; - writeln; - for i:=1 to n do - begin - for j:=1 to m do - write(a[i,j]:7:4,' '); - writeln(':',y[i]:9:5) - end; - writeln -end; { show } - -begin { procedure get_data } - writeln; - repeat - write('How many equations? '); - readln(n); - m:=n - until n1 then - begin - for i:=1 to n do - begin - writeln('Equation',i:3); - k:=0; - l:=2*i-1; - for j:=1 to n do - begin - k:=k+1; - write('Real',j:3,':'); - read(c[i,j,1]); { read real part } - a[l,k]:=c[i,j,1]; - a[l+1,k+1]:=c[i,j,1]; - k:=k+1; - write('Imag',j:3,':'); - read(c[i,j,2]); { imaginary part } - a[l,k]:=-c[i,j,2]; - a[l+1,k-1]:=c[i,j,2] - end; { j-loop } - write('Real const:'); - read(v[i,1]); { real constant } - y[l]:=v[i,1]; - write('Imag const:'); - readln(v[i,2]); { imag constant } - y[l+1]:=v[i,2] - end; { i-loop } - show { the original DATA } - end { if n>1 } -end; { procedure get_data } - - -procedure write_data; - -{ print out the answers } - -var i,j : integer; - re,im : real; - -function mag(x,y: real): real; -{ polar magnitude } -begin - mag:=sqrt(sqr(x)+sqr(y)) -end; { function mag } - -function atan(x,y: real): real; -{ arctan in degrees } -const pi180 = 57.2957795; -var a : real; - -begin { atan } - if x=0.0 then - if y=0.0 then atan:=0.0 - else atan:=90.0 - else { x<>0 } - if y=0.0 then atan:=0.0 - else { x and y <>0 } - begin - a:=arctan(abs(y/x))*pi180; - if x>0.0 then - if y>0.0 then atan:=a { x,y>0 } - else atan:=-a { x>0, y<0 } - else { x<0 } - if y>0.0 then atan:=180.0-a { x<0, y>0 } - else atan:=180.0+a { x,y<0 } - end { else } -end; { function atan } -begin - writeln(' REAL Imaginary Magnitude Angle'); - for i:=1 to (m div 2) do - begin - j:=2*i-1; - re:=coef[j]; - im:=coef[j+1]; - writeln(re:11:5,im:11:5,mag(re,im):11:5,atan(re,im):11:5) - end; { for } - writeln -end; { write_data } - - - -{external procedure gaussj - (var b : ary2s; - y : arys; - var coef : arys; - ncol : integer; - var error : boolean);} - -{$I C:GAUSSJ.LIB} - -begin { MAIN program } - cls; - writeln; - writeln; - revon; - writeln('Simultaneous solution with complex coefficients'); - writeln('by Gauss-Jordan elimination'); - revoff; - repeat - get_data(a,y,n,m); - if n>1 then - begin - for i:=1 to n do - for j:=1 to n do - b[i,j]:=a[i,j]; { setup work array } - gaussj(b,y,coef,n,error); - if not error then write_data - end - until n<2 -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/SOLVGJ.PAS b/software/CPM/CPM18_MTPUG_06/SOLVGJ.PAS deleted file mode 100644 index c716a16..0000000 --- a/software/CPM/CPM18_MTPUG_06/SOLVGJ.PAS +++ /dev/null @@ -1,100 +0,0 @@ -program solvgj; { -> 84 } -{ pascal program to perform simultaneous solution by Gauss-Jordan elimination} - -const maxr = 8; - maxc = 8; - -type ary = array[1..maxr] of real; - arys = array[1..maxc] of real; - ary2s = array[1..maxr,1..maxc] of real; - -var y : arys; - coef : arys; - a,b : ary2s; - n,m,i,j : integer; - first, - error : boolean; - -external procedure cls; - -procedure get_data(var a: ary2s; - var y: arys; - var n,m: integer); - -{ get the values for n and arrays a,y } - -var i,j : integer; - -begin - writeln; - repeat - write('How many equations? '); - readln(n); - if first then first:=false else cls; - m:=n - until n1 then - begin - for i:=1 to n do - begin - writeln('Equation',i:3); - for j:=1 to n do - begin - write(j:3,':'); - read(a[i,j]) - end; - write(',C:'); - readln(y[i]) { clear line } - end; - writeln; - for i:=1 to n do - begin - for j:=1 to m do - write(a[i,j]:7:4,' '); - writeln(':',y[i]:7:4) - end; - writeln - end { if n>1 } -end; { procedure get_data } - -procedure write_data; - -{ print out the answers } - -var i : integer; - -begin - for i:=1 to m do - write(coef[i]:9:5); - writeln -end; { write_data } - - - -{external procedure gaussj - (var b : ary2s; - y : arys; - var coef : arys; - ncol : integer; - var error : boolean);} - -{$I C:GAUSSJ.LIB} - -begin { MAIN program } - first:=true; - cls; - writeln; - writeln('Simultanuns solution by Gauss-Jordan elimination'); - repeat - get_data(a,y,n,m); - if n>1 then - begin - for i:=1 to n do - for j:=1 to n do - b[i,j]:=a[i,j]; { setup work array } - gaussj(b,y,coef,n,error); - if not error then write_data - end - until n<2 -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/SOLVGJ2.PAS b/software/CPM/CPM18_MTPUG_06/SOLVGJ2.PAS deleted file mode 100644 index a0e03d6..0000000 --- a/software/CPM/CPM18_MTPUG_06/SOLVGJ2.PAS +++ /dev/null @@ -1,110 +0,0 @@ -program solvgj2; { -> 111 } -{ pascal program to perform simultaneous solution by Gauss-Jordan elimination} -{ there may be more equations than unknowns } - -const maxr = 8; - maxc = 8; - -type ary = array[1..maxr] of real; - arys = array[1..maxc] of real; - ary2s = array[1..maxr,1..maxc] of real; - ary2 = ary2s; { for square } - -var y : ary; - coef,yy : arys; - a,b : ary2s; - n,m,i,j : integer; - first, - error : boolean; - -external procedure cls; - -procedure get_data(var a: ary2s; - var y: ary; - var n,m: integer); - -{ get the values for n and arrays a,y } - -var i,j : integer; - -begin - writeln; - repeat - write('How many unknowns? '); - readln(m); - if first then first:=false else cls; - until m1 then - begin - repeat - write('How many equations? '); - readln(n) - until n>=m; - for i:=1 to n do - begin - writeln('Equation',i:3); - for j:=1 to m do - begin - write(j:3,':'); - read(a[i,j]) - end; - write(',C:'); - readln(y[i]) { clear line } - end; { i-loop } - writeln; - for i:=1 to n do - begin - for j:=1 to m do - write(a[i,j]:7:4,' '); - writeln(':',y[i]:7:4) - end; - writeln - end { if n>1 } -end; { procedure get_data } - -procedure write_data; - -{ print out the answers } - -var i : integer; - -begin - for i:=1 to m do - write(coef[i]:9:5); - writeln -end; { write_data } - -{external procedure square - ( y : ary; - var a : ary2s; - var g : arys; - nrow,ncol : integer);} - -{$I C:SQUARE.LIB} - -{external procedure gaussj - (var b : ary2s; - y : arys; - var coef : arys; - ncol : integer; - var error : boolean);} - -{$I C:GAUSSJ.LIB} - -begin { MAIN program } - first:=true; - cls; - writeln; - writeln('Best fit to simultaneous equations'); - writeln('By Gauss-Jordan'); - repeat - get_data(a,y,n,m); - if m>1 then - begin - square(a,y,b,yy,n,m); - gaussj(b,yy,coef,m,error); - if not error then write_data - end - until m<2 -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/SOLVGV.PAS b/software/CPM/CPM18_MTPUG_06/SOLVGV.PAS deleted file mode 100644 index 6a10341..0000000 --- a/software/CPM/CPM18_MTPUG_06/SOLVGV.PAS +++ /dev/null @@ -1,273 +0,0 @@ -program solvgv; { -> 96 } -{ pascal program to perform simultaneous solution by gauss-jordan elimination } -{ with multiple constant vectors } - -const maxr = 7; - maxc = 7; - -type ary2s = array[1..maxr,1..maxc] of real; - -var dummy : char; - a,y : ary2s; - n,nvec : integer; - first, - error : boolean; - determ : real; - -external procedure cls; -external procedure revon; -external procedure revoff; - -procedure get_data(var a: ary2s; - var y: ary2s; - var n,nvec: integer); -{ get values for n,nvec and arrays a,y } - -var i,j : integer; - -begin - if not first then cls else first:=false; - writeln; - repeat - write('How many equations? '); - readln(n) - until n1 then - begin - write('How many constant vectors? '); - readln(nvec); - for i:=1 to n do - begin - for j:=1 to n do - begin - write(j:3,': '); - read(a[i,j]); - if (j mod n+nvec)=0 then writeln - end; - if nvec>0 then - begin - for j:=1 to nvec do - begin - write(' C:'); - read(y[i,j]) - end; - readln - end - end; { i-loop } - - writeln; - write(' Matrix'); - if nvec>0 then write(' Constants'); - writeln; - for i:=1 to n do - begin - for j:=1 to n do - write(a[i,j]:7:4,' '); - for j:=1 to nvec do - write(':',y[i,j]:7:4); - writeln - end; { i-loop } - writeln - end { if n>1 } - end; { procedure get_data } - -procedure write_data; - { print out answers } - -var i,j : integer; - -begin - if nvec>0 then - begin - writeln('Solution '); - for i:=1 to n do - begin - for j:=1 to nvec do - write(y[i,j]:9:5); - writeln - end - end { if } - else - begin - writeln(' Inverse'); - for i:=1 to n do - begin - for j:=1 to n do - write(a[i,j]:9:5); - writeln - end; - writeln; - write('Determinant is ',determ:10:5) - end; { else } - writeln -end; { write_data } - - -procedure gausjv - (var b : ary2s; { square matrix of coefficients } - var w : ary2s; { constant vector matrix } - var determ : real; { the determinant } - ncol : integer; { order of matrix } - nv : integer; { number of constants } - var error : boolean); { true if matrix is singular } - -{ Gauss Jordan matrix inversion and solution } -{ B(n,n) coefficients matrix becomes inverse } -{ W(n,m) constant vector(s) become solution vector } -{ determ is the determinant } -{ error=1 if singular } -{ INDEX(n,3) } -{ NV is the number of vectors } - -label 99; - -var - index : array[1..maxc,1..3] of integer; - i,j,k,l, - irow,icol, - n,l1 : integer; - pivot,hold, - sum,ab, - t,big : real; - -procedure swap(var a,b: real); -var hold : real; - -begin - hold:=a; - a:=b; - b:=hold -end; { procedure swap } - - -procedure gausj2; - label 98; - var i,j,k,l,l1 : integer; - - -procedure gausj3; - -var l : integer; - -begin { procedure gausj3 } - { interchange rows to put pivot on diagonal } - if irow<>icol then - begin - determ:=-determ; - for l:=1 to n do - swap(b[irow,l],b[icol,l]); - if nv>0 then - for l:=1 to nv do - swap(w[irow,l],w[icol,l]) - end { if irow<>icol } -end; { gausj3 } - -begin { procedure gausj2 } - { actual start of gaussj } - error:=false; - n:=ncol; - for i:=1 to n do - index[i,3]:=0; - determ:=1.0; - for i:=1 to n do - begin - { search for the largest element } - big:=0.0; - for j:=1 to n do - begin - if index[j,3]<>1 then - begin - for k:=1 to n do - begin - if index[k,3]>1 then - begin - writeln(chr(7),'ERROR: matrix is singular'); - error:=true; - goto 98 { abort } - end; - if index[k,3]<1 then - if abs(b[j,k])>big then - begin - irow:=j; - icol:=k; - big:=abs(B[j,k]) - end - end { k-loop } - end { if } - end; { j-loop } - index[icol,3]:=index[icol,3]+1; - index[i,1]:=irow; - index[i,2]:=icol; - gausj3; { further subdivision of gaussj } - { divide pivot row by pivot column } - pivot:=b[icol,icol]; - determ:=determ*pivot; - b[icol,icol]:=1.0; - for l:=1 to n do - b[icol,l]:=b[icol,l]/pivot; - if nv>0 then - for l:=1 to nv do - w[icol,l]:=w[icol,l]/pivot; - { reduce nonpivot rows } - for l1:=1 to n do - begin - if l1<>icol then - begin - t:=b[l1,icol]; - b[l1,icol]:=0; - for l:=1 to n do - b[l1,l]:=b[l1,l]-b[icol,l]*t; - if nv>0 then - for l:=1 to nv do - w[l1,l]:=w[l1,l]-w[icol,l]*t - end { if l1<>icol } - end { for l1 } - end; { i-loop } -98: -end; { gausj2 } - -begin { GAUS-JORDAN main program } - gausj2; { first half of gaussj } - if error then goto 99; - { interchange columns } - for i:=1 to n do - begin - l:=n-i+1; - if index[l,1]<>index[l,2] then - begin - irow:=index[l,1]; - icol:=index[l,2]; - for k:=1 to n do - swap(b[k,irow],b[k,icol]) - end { if index } - end; { i-loop } -for k:=1 to n do - if index[k,3]<>1 then - begin - writeln(chr(7),'ERROR: matrix is singular'); - error:=true; - goto 99 { abort } - end; -99: -end; { procedure gaussj } - - -begin { main program } - first:=true; - cls; - writeln; - revon; - writeln('Simultaneous solution by Gauss-Jordan'); - writeln('Multiple constant vectors, or matrix inverse'); - revoff; - repeat - get_data(a,y,n,nvec); - if n>1 then - begin - gausjv(a,y,determ,n,nvec,error); - if not error then write_data; - read(dummy) - end - until n<2 -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/SORT-B.LIB b/software/CPM/CPM18_MTPUG_06/SORT-B.LIB deleted file mode 100644 index 21d4aa6..0000000 --- a/software/CPM/CPM18_MTPUG_06/SORT-B.LIB +++ /dev/null @@ -1,34 +0,0 @@ - - -{ --> 176} -procedure {bubble} sort(var a: ary; n: integer); -{ adapted from 'Introduction to PASCAL', - R.Zaks, Sybex, 1980 } - -var no_change : boolean; - j : integer; - -procedure swap(p,q: real); -var hold : real; -begin - hold:=p; - p:=q; - q:=hold -end; { swap } - -begin { procedure sort } - repeat - no_change:=true; - for j:=1 to n-1 do - begin - if a[j]>a[j+1] then - begin - swap(a[j],a[j+1]); - no_change:=false - end - end { for } - until no_change -end; { procedure sort } - - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/SORT-Q-N.LIB b/software/CPM/CPM18_MTPUG_06/SORT-Q-N.LIB deleted file mode 100644 index e46a586..0000000 --- a/software/CPM/CPM18_MTPUG_06/SORT-Q-N.LIB +++ /dev/null @@ -1,74 +0,0 @@ - - -{ --> 183} -procedure sort(var x: ary; n: integer); -{ a NONRECURSIVE quicksort routine } -{ Adapted from 'Software-Tools', - B.Kernighan, Addison Wesley, 1976 } - -var left,right : array[1..20] of integer; - i,j,sp,mid : integer; - pivot : real; - -procedure swap(var p,q: real); -var hold : real; - -begin - hold:=p; - p:=q; - q:=hold -end; { swap } - - -begin - left[1]:=1; - right[1]:=n; - sp:=1; - while sp>0 do - begin - if left[sp]>=right[sp] then sp:=sp-1 - else - begin - i:=left[sp]; - j:=right[sp]; - pivot:=x[j]; - mid:=(i+j)div 2; - if (j-i)>5 then - if ((x[mid]x[i])) - or - ((x[mid]>pivot)and(x[mid]pivot)) - or ((x[i]>x[mid])and(x[i]=right[sp]-i then - begin { put shorter part first } - left[sp]+1:=left[sp]; - right[sp+1]:=i-1; - left[sp]:=i+1 - end - else - begin - left[sp+1]:=i+1; - right[sp+1]:=right[sp]; - right[sp]:=i-1 - end; - sp:=sp+1 { push stack } - end { if } - end { while } -end; { QUICK SORT } - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/SORT-Q-R.LIB b/software/CPM/CPM18_MTPUG_06/SORT-Q-R.LIB deleted file mode 100644 index c087c54..0000000 --- a/software/CPM/CPM18_MTPUG_06/SORT-Q-R.LIB +++ /dev/null @@ -1,58 +0,0 @@ - - -{ --> 180} -procedure {quick} sort(var x: ary; n: integer); -{ a RECURSIVE sorting routine } -{ Adapted from 'The design of Well-Structured and Correct Programs', - S. Alagic, Springer-Verlag, 1978 } - - -procedure qsort(var x: ary; m,n: integer); -var i,j : integer; - - -procedure partit(var a: ary; var i,j: integer; left,right: integer); -var pivot : real; - -procedure swap(var p,q: real); -var hold : real; -begin - hold:=p; - p:=q; - q:=hold -end; { swap } - -begin - pivot:=a[(left+right)div 2]; - i:=left; - j:=right; - while i<=j do - begin - while a[i] 178} - -procedure {shell} sort(var a: ary; n: integer); -{ Shell-Metzner sort } -{ Adapted from 'Programming in pascal', - P. Grogono, Addison-Wesley, 1980 } - -var done : boolean; - jump,i,j: integer; - -procedure swap(var p,q: real); -var hold : real; - -begin - hold:=p; - p:=q; - q:=hold -end; { swap } - -begin - jump:=n; - while jump>1 do - begin - jump:=jump div 2; - repeat - done:=true; - for j:=1 to n do - begin - i:=j+jump; - if a[j]>a[i] then - begin - swap(a[j],a[i]); - done:=false - end { if } - end { for } - until done - end { while } -end; { SORT } - - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/SQUARE.LIB b/software/CPM/CPM18_MTPUG_06/SQUARE.LIB deleted file mode 100644 index a92c6a3..0000000 --- a/software/CPM/CPM18_MTPUG_06/SQUARE.LIB +++ /dev/null @@ -1,33 +0,0 @@ - -procedure square(x: ary2; - y: ary; - var a: ary2s; - var g: arys; - nrow,ncol: integer); - -{ matrix multiplication routine } -{ a= transpose x times x } -{ g= y times x } - -var - i,k,l : integer; - -begin { square } - for k:=1 to ncol do - begin - for l:=1 to k do - begin - a[k,l]:=0.0; - for i:=1 to nrow do - begin - a[k,l]:=a[k,l]+x[i,l]*x[i,k]; - if k<>l then a[l,k]:=a[k,l] - end - end; { l-loop } - g[k]:=0.0; - for i:=1 to nrow do - g[k]:=g[k]+y[i]*x[i,k] - end { k-loop } -end; { square } - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/TERMINAL.BLD b/software/CPM/CPM18_MTPUG_06/TERMINAL.BLD deleted file mode 100644 index e24aeaf..0000000 --- a/software/CPM/CPM18_MTPUG_06/TERMINAL.BLD +++ /dev/null @@ -1,4 +0,0 @@ -TERMINAL.ERL -CURSOR.ERL -CURSOR2.ERL - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/TERMINAL.ERL b/software/CPM/CPM18_MTPUG_06/TERMINAL.ERL deleted file mode 100644 index 65a46b6..0000000 Binary files a/software/CPM/CPM18_MTPUG_06/TERMINAL.ERL and /dev/null differ diff --git a/software/CPM/CPM18_MTPUG_06/TERMINAL.IF b/software/CPM/CPM18_MTPUG_06/TERMINAL.IF deleted file mode 100644 index f78b7f0..0000000 --- a/software/CPM/CPM18_MTPUG_06/TERMINAL.IF +++ /dev/null @@ -1,27 +0,0 @@ -(* define also: -TYPE - dir = (up,down,left,right); {direction of the 3 line crossing} -*) - -EXTERNAL PROCEDURE GotoXY(x,y:INTEGER); (* position cursor *) -EXTERNAL PROCEDURE ClrScr; (* clear whole screen *) -EXTERNAL PROCEDURE ClrEOS; (* clear to end of screen *) -EXTERNAL PROCEDURE ClrEOL; (* clear to end of line *) -EXTERNAL PROCEDURE EraScr; (* erase whole screen *) -EXTERNAL PROCEDURE EraEOS; (* erase to end of screen *) -EXTERNAL PROCEDURE EraEOL; (* erase to end of line *) -EXTERNAL PROCEDURE EraEOF; (* erase to end of field *) -EXTERNAL PROCEDURE Hline(y,xStart,xEnd:INTEGER); (* draw horizontal line *) -EXTERNAL PROCEDURE Vline(x,yStart,yEnd:INTEGER); (* draw vertical line *) -EXTERNAL PROCEDURE TriAt(x,y:INTEGER; where:dir);(* print 3 line crossing *) -EXTERNAL PROCEDURE EdgeAt(x,y,x2,y2: INTEGER); (* make frame- end points *) -EXTERNAL PROCEDURE CrossAt(x,y:INTEGER); (* print 4 line crossing *) -EXTERNAL PROCEDURE Mask; (* draw standard mask *) -EXTERNAL PROCEDURE Grafix; (* switch to graphics mode *) -EXTERNAL PROCEDURE EndGra; (* switch to normal mode *) -EXTERNAL PROCEDURE BakGnd; (* switch to background *) -EXTERNAL PROCEDURE ForGnd; (* switch to foreground *) -EXTERNAL PROCEDURE PrintAt(x,y: INTEGER; someText: string); - - -; \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/TRAP1.PAS b/software/CPM/CPM18_MTPUG_06/TRAP1.PAS deleted file mode 100644 index 31ef66e..0000000 --- a/software/CPM/CPM18_MTPUG_06/TRAP1.PAS +++ /dev/null @@ -1,55 +0,0 @@ -program trap1; { -> 264 } -{ integration by the trapezoidal rule } - -var done : boolean; - sum,upper,lower : real; - pieces : integer; - -function fx(x: real): real; -{ find f(x)=1/x } -{ watch out for x=0 ! } -begin - fx:=1.0/x -end; - -procedure trapez(lower,upper : real; - pieces : integer; - var sum : real); -{ numerical integration by the trapezoid method } -{ function is FX, limits are LOWER and UPPER } -{ with number of regions equal to PIECES } -{ fixed partition is DELTA_X, answer is SUM } - -var i : integer; - x,delta_x,esum,psum : real; -begin - delta_x:=(upper-lower)/pieces; - esum:=fx(lower)+fx(upper); - psum:=0.0; - - for i:=1 to pieces do - begin - x:=lower+i*delta_x; - psum:=psum+fx(x) - end; - sum:=(esum+2.0*psum)*delta_x*0.5 -end; { TRAPEZ } - -begin { main program } - done:=false; - lower:=1.0; - upper:=9.0; - writeln; - repeat - write('How many sections? '); - readln(pieces); - if pieces<0 then done:=true - - else - begin - trapez(lower,upper,pieces,sum); - writeln('area=',sum) - end - until done -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/TRAP2.PAS b/software/CPM/CPM18_MTPUG_06/TRAP2.PAS deleted file mode 100644 index 570bfd5..0000000 --- a/software/CPM/CPM18_MTPUG_06/TRAP2.PAS +++ /dev/null @@ -1,56 +0,0 @@ -program trap2; { -> 266 } -{ integration by the trapezoidal rule } - -const tol = 1.0E-4; -var sum,upper,lower : real; - -external procedure cls; - -function fx(x: real): real; -{ find f(x)=1/x } -{ watch out for x=0 ! } -begin - fx:=1.0/x -end; - -procedure trapez(lower,upper,tol: real; - var sum : real); - -{ numerical integration by the trapezoid method } -{ function is FX, limits are LOWER and UPPER } -{ with number of regions equal to PIECES } -{ fixed partition is DELTA_X, answer is SUM } - -var pieces,i : integer; - x,delta_x,end_sum,mid_sum,sum1 : real; -begin - pieces:=1; - delta_x:=(upper-lower)/pieces; - end_sum:=fx(lower)+fx(upper); - sum:=end_sum*delta_x/2.0; - writeln(' 1',sum); - mid_sum:=0.0; - repeat - pieces:=pieces*2; - sum1:=sum; - delta_x:=(upper-lower)/pieces; - for i:=1 to pieces div 2 do - begin - x:=lower+delta_x*(2.0*i-1.0); - mid_sum:=mid_sum+fx(x) - end; - sum:=(end_sum+2.0*mid_sum)*delta_x*0.5; - writeln(pieces:5,sum) - until abs(sum-sum1)<=abs(tol*sum) -end; { TRAPEZ } - -begin { main program } - cls; - lower:=1.0; - upper:=9.0; - writeln; - trapez(lower,upper,tol,sum); - writeln; - writeln(chr(7),'area=',sum) -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/TRAPEZ.LIB b/software/CPM/CPM18_MTPUG_06/TRAPEZ.LIB deleted file mode 100644 index d32552c..0000000 --- a/software/CPM/CPM18_MTPUG_06/TRAPEZ.LIB +++ /dev/null @@ -1,43 +0,0 @@ - - -{ -> 270 } -procedure trapez(function f(x:real):real; - lower,upper,tol: real; - var sum : real); - -{ numerical integration by the trapezoid method } -{ function is f (as parameter), limits are LOWER and UPPER } -{ with number of regions equal to PIECES } -{ fixed partition is DELTA_X, answer is SUM } - -var pieces,i : integer; - x,delta_x,end_sum,mid_sum, - end_cor,sum1 : real; - -function dfx(x: real): real; -begin - dfx:=1.0/sqr(x) -end; - -begin - pieces:=1; - delta_x:=(upper-lower)/pieces; - end_sum:=f(lower)+f(upper); - end_cor:=(dfx(upper)-dfx(lower))/12.0; - sum:=end_sum*delta_x/2.0; - mid_sum:=0.0; - repeat - pieces:=pieces*2; - sum1:=sum; - delta_x:=(upper-lower)/pieces; - for i:=1 to pieces div 2 do - begin - x:=lower+delta_x*(2.0*i-1.0); - mid_sum:=mid_sum+f(x) - end; - sum:=(end_sum+2.0*mid_sum)*delta_x*0.5*0.5-sqr(delta_x)*end_cor; - until abs(sum-sum1)<=abs(tol*sum) -end; { TRAPEZ } - - - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/TSTBES.PAS b/software/CPM/CPM18_MTPUG_06/TSTBES.PAS deleted file mode 100644 index 504f351..0000000 --- a/software/CPM/CPM18_MTPUG_06/TSTBES.PAS +++ /dev/null @@ -1,83 +0,0 @@ -program tstbes; { -> 344 } -{ test the bessel function } -{ the Gamma function is included } - -var done :boolean; - x,ordr : real; - - -function gamma(x: real): real; -const pi = 3.1415926; - -var i,j : integer; - y,gam : real; - -begin { gamma function } - if x>=0.0 then - begin - y:=x+2.0; - gam:=sqrt(2*pi/y)*exp(y*ln(y)+(1-1/(30*y*y))/(12*y)-y); - gamma:=gam/(x*(x+1)) - end - else { x<0 } - begin - j:=0; - y:=x; - repeat - j:=j+1; - y:=y+1.0 - until y>0.0; - gam:=gamma(y); { recursive call } - for i:=0 to j-1 do - gam:=gam/(x+1); - gamma:=gam - end { x<0 } -end; { gamma function } - -function bessj(x,n: real): real; -{ cylindrical Bessel function of the first kind } -{ the gamma function is required } - -const tol = 1.0E-4; - pi = 3.1415926; - -var i : integer; - term,new_term, - sum,x2 : real; - -begin { bessj } - x2:=x*x; - if (x=0.0)and(N=1.0) then bessj:=0.0 - else if x>15 then { asymptotic expansion } - bessj:=sqrt(2/(pi*x))*cos(x-pi/4-n*pi/2) - else - begin - if n=0.0 then sum:=1.0 - else sum:=exp(n*ln(x/2))/gamma(n+1.0); - new_term:=sum; - i:=0; - repeat - i:=i+1; - term:=new_term; - new_term:=-term*x2*0.25/(i*(n+1)); - sum:=sum+new_term - until abs(new_term)<=abs(sum*tol); - bessj:=sum - end { if} -end; { bessj } - -begin { main } - done:=false; - repeat - write('Order: '); - readln(ordr); - if ordr<-25.0 then done:=true - else - begin - write('X: '); - readln(x); - writeln('J Bessel is ',bessj(x,ordr)) - end - until done -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/TSTGAM.PAS b/software/CPM/CPM18_MTPUG_06/TSTGAM.PAS deleted file mode 100644 index 4b9078e..0000000 --- a/software/CPM/CPM18_MTPUG_06/TSTGAM.PAS +++ /dev/null @@ -1,48 +0,0 @@ - -program tstgam; { -> 340 } -{ test the gamma function } - -var x : real; - -external procedure cls; - -function gamma(x: real): real; -const pi = 3.1415926; - -var i,j : integer; - y,gam : real; - -begin { gamma function } - if x>=0.0 then - begin - y:=x+2.0; - gam:=sqrt(2*pi/y)*exp(y*ln(y)+(1-1/(30*y*y))/(12*y)-y); - gamma:=gam/(x*(x+1)) - end - else { x<0 } - begin - j:=0; - y:=x; - repeat - j:=j+1; - y:=y+1.0 - until y>0.0; - gam:=gamma(y); { recursive call } - for i:=0 to j-1 do - gam:=gam/(x+i); - gamma:=gam - end { x<0 } -end; { gamma function } - -begin - cls; - writeln; - repeat - repeat - write('X: '); - read(x) - until x<>0.0; - writeln('Gamma is ',gamma(x)) - until x<-22.0; -end. - \ No newline at end of file diff --git a/software/CPM/CPM18_MTPUG_06/TSTSORT.PAS b/software/CPM/CPM18_MTPUG_06/TSTSORT.PAS deleted file mode 100644 index b3ead66..0000000 --- a/software/CPM/CPM18_MTPUG_06/TSTSORT.PAS +++ /dev/null @@ -1,76 +0,0 @@ -program tstsort; { -> 172 } -{ test speed of sorting routine } - -const max = 1000; - -type ary = array[1..300] of real; - -var x : ary; - n,i : integer; - seed : real; - first : boolean; - -external procedure cls; - -{$I RANDOM.LIB } - -procedure print; -var i : integer; - -begin - writeln; - for i:=1 to n do - begin - write(x[i]:7:2); - if (i mod 10)=0 then writeln - end -end; - -procedure { bubble- } sort(var a: ary; n: integer); -var i,j : integer; - hold : real; - -begin { procedure sort } - for i:=1 to n-1 do - for j:=i+1 to n do - begin - if a[i]>a[j] then - begin - hold:=a[i]; - a[i]:=a[j]; - a[j]:=hold - end - end { for } -end; { procedure sort } - -begin { MAIN program } - cls; - seed:=4.0; - repeat - repeat - writeln; - write('How many points? '); - readln(n) - until n<=max; - if first then first:=false else cls; - for i:=1 to n do - x[i]:=100*random(0); - print; - write(chr(7)); - sort(x,n); { random numbers } - write(chr(7)); - print; - writeln(' random '); - write(chr(7)); - sort(x,n); { sorted numbers } - write(chr(7)); - print; - writeln(' sorted '); - for i:=1 to n do - x[i]:=n+1-i; - write(chr(7)); - print; - writeln(' reversed '); - until n<5 -end. - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/-MTPUG.007 b/software/CPM/CPM19_MTPUG_07/-MTPUG.007 deleted file mode 100644 index e69de29..0000000 diff --git a/software/CPM/CPM19_MTPUG_07/-MTPUG.DOC b/software/CPM/CPM19_MTPUG_07/-MTPUG.DOC deleted file mode 100644 index c67780b..0000000 --- a/software/CPM/CPM19_MTPUG_07/-MTPUG.DOC +++ /dev/null @@ -1,56 +0,0 @@ -MTPUG.007 December 11, 1982 - -PRMAC.SRC A program for typing the .PRN and .SYM files produced - .COM by the Digital Research's MAC assembler. Has improved - .DOC output format. - -GRAPH.DOC This set of programs was the result of a concerted -GRPH.SRC effort to produce a PORTABLE set of graphic procedures -GRAPHADM.SRC which could be easily used on more than one machine. - Written by J.A. Koehler and Jack Gilmer. - -PRETTY.DOC A starter program for Pascal programs. At present it - .SRC only converts lower case reserved words to upper case. - .COM Written by J.A. Koehler. - -DISKIO.DOC Start of a library of I/O routines. At present only - .SRC includes a routine to obtain up to two arguments on - a command line. Written by J.A. Koehler. - -SHAREFIL.DOC This is an application program using a Pascal interface - to assembly modules provided by Sue Arnold of Centaurus - Software. These modules together provide file sharing - and record locking/unlocking capability for Pascal/MT+ - programs ver 5.5 running under MP/M II. This package of - programs is not supported by the author or by Digital - Research, Inc. - -SHAREFIL.TST A simple program example showing the use of the above - routines. Written by Dick Lovelace and Dan Erickson. - -BCD.DOC Z80 Version of BCDREALS.ERL(Ver 5.5). This module is - .ERL about 20% shorter and 25% faster than the original - library. It is highly Z-80 specific. Provided by - Guenter Musstopf, author unknown. - -TYPESET.DOC Program converts a text file written by "WORDSTAR" - .SRC to a format acceptable to type setting equipment. - .PRM Special Wordstar symbols are translated to symbols - acceptable to the type setting equipment. Operator - intervention requested when needed. May also be - used to translate to other word processor formats. - Written by Per Strangeland, Norway. - -FOTOSATS.DOC Norwegian version of TYPESET above. - .SRC - .PRM - -MYLIB.ERL Contains corrected versions of MT+(5.5) run time - modules, GETSTR and DELBLNK described in News #7. - Written by Henry Lucas - -3740UTIL.DOC A CPM program to read/write IBM 3740 format disks - .COM and read/write CPM format disks. Maintained by - Bob White. - - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/3740UTIL.COM b/software/CPM/CPM19_MTPUG_07/3740UTIL.COM deleted file mode 100644 index ec973a5..0000000 Binary files a/software/CPM/CPM19_MTPUG_07/3740UTIL.COM and /dev/null differ diff --git a/software/CPM/CPM19_MTPUG_07/3740UTIL.DOC b/software/CPM/CPM19_MTPUG_07/3740UTIL.DOC deleted file mode 100644 index f77c893..0000000 --- a/software/CPM/CPM19_MTPUG_07/3740UTIL.DOC +++ /dev/null @@ -1,232 +0,0 @@ - - - **************************************************************** - * * - * N O T E * - * ------- * - * * - * The source code (.ASM file) for the software described in * - * the following documentation requires the macro assembler, * - * "MAC.COM", available from Digital Research, for assembly * - * as well as a macro library called "MACS3740.LIB". The * - * macro library (MACS3740.LIB) is included with the 3740UTIL * - * package and must be present on the same disk on which the * - * main source file "3740UTIL.ASM" is assembled. An already * - * assembled and loaded object code file (3740UTIL.OBJ) ready * - * to run is included with the 3740UTIL software package. Be * - * sure to rename it 3740UTIL.COM for CP/M. * - * * - * -Calamity Cliffs Computer Center * - * * - **************************************************************** - - - - - INTRODUCTION - - - The following manual describes the use and function of the - CP/M - IBM disk utility. It is designed to allow the user to - easily transfer data between CP/M and IBM disk formats. - - - CP/M is a registered trademark of Digital Research, Garden Grove, - CA. IBM is a registered trademark of International Business - Machines, Poughkeepsie, NY. - - - - TABLE OF CONTENTS - - - INTRODUCTION ................................................ 1 - INITIALIZE AN IBM DISKETTE .................................. 2 - CHANGE AN IBM VOLUME SERIAL NUMBER .......................... 3 - CHANGE AN IBM DATASET'S DIRECTORY ENTRY ..................... 4 - DELETE AN IBM DATASET'S DIRECTORY ENTRY ..................... 5 - LIST AN IBM DATASET'S DIRECTORY ............................. 6 - TRANSFER CP/M TO IBM DATASET (BLOCK FORMAT) ................. 7 - TRANSFER IBM TO CP/M DATASET (BLOCK FORMAT) ................. 8 - TRANSFER CP/M TO IBM DATASET (SOURCE FORMAT) ................ 9 - TRANSFER IBM TO CP/M DATASET (SOURCE FORMAT) ................ 10 - DISPLAY AN IBM DATASET ...................................... 11 - HARDWARE/SOFTWARE REQUIREMENTS .............................. 12 - MAINTENANCE POLICIES ........................................ 13 - PROGRAM ERROR REPORT ........................................ 14 - - - - INTRODUCTION - - - Introduction - - This program was developed so that developement could be - performed on a small computer utilizing CP/M for large IBM site. - The data or programs were coded using the small computer, and - then transfered to the IBM computer utilizing this program. - Also, certain data were transferred back to the small computer - for updating and again transferred back to the IBM computer. - Thus, the time involved for coding and keypunching were absorbed - on the small machine. All transfers were performed by diskette. - This manual assumes that the reader has a working knowledge - of both CP/M and IBM operating systems. In particular, the user - should fully understand the basic disk layout for IBM Standard - Interchange Format. This program assumes the SIF throughout and - was written to be compatible with only it. NO other IBM format - is utilized. For further information concerning this format, - please review manual GA21-9182, IBM General Information Manual on - Diskettes. - The program was designed to be menu driven with prompting. - Currently, each response is verified, and if incorrect, re- - prompted. If you make a mistake which is a valid reply, re-boot - CP/M and restart the program. At this time, no backup facility - is offered so be careful as to your responses. - When working with CP/M files, the file names are assumed to - be an 1-8 byte name with a type of '.DAT'. The 1-8 byte name - must correspond with a file name on the IBM diskette. - - - - INITIALIZE AN IBM DISKETTE - - - Initialize an IBM Diskette - - To initialize a diskette in IBM SIF format, use this - command. Place the diskette to be initialized in the appropriate - drive. Select this function (1). Reply with the drive (A-D). - Then reply with the new 6-byte volume serial number. The program - will then format the diskette to IBM specifications. This may - take a few minutes so don't be alarmed if it doesn't reply to - you immediately. After initialization, the diskette is ready to - use as an IBM diskette. - - - - CHANGE AN IBM VOLUME SERIAL NUMBER - - - Change an IBM Volume Serial Number - - This function allows the user to simply change an IBM - diskette's volume serial number. Use function code (2) to invoke - it. Reply with the disk drive (A-D) that the diskette is on, and - then reply with the new volume serial number, 1-6 characters. No - checking is done on the rest of the diskette. Only the volume - serial number is changed. - - - - CHANGE AN IBM DATASET'S DIRECTORY ENTRY - - - Change an IBM Dataset's Directory Entry - - This function allows you to change the directory entry for - an IBM file. You will use this entry to create a file, rename - it or adjust its parameters. To invoke this function, use code - (3). Reply with the disk drive containing the IBM diskette. - Then reply with the directory sector to be changed. You can find - the sector number by using function (6), List Directory. The - program will then display all the fields in the entry and request - that you entry a new value. Enter ONLY the fields that you want - to change. When the last field has been entered, the directory - will automatically be updated, and a completion message will be - posted to the terminal. You will then return to the main menu. - - - - DELETE AN IBM DATASET'S DIRECTORY ENTRY - - - Delete an IBM Dataset's Directory Entry - - To delete a dataset from an IBM diskette, place the diskette - in a drive, invoke function code (4), enter the disk drive (A-D) - on which the diskette resides, and enter the sector number of the - directory entry. If you are in doubt as to the sector number, - use function code (6), List Directory, to find out what it is. - When the entry has been deleted and a completion message has been - posted, control will return to the main menu. - - - - LIST AN IBM DIRECTORY - TRANSFER A CP/M FILE TO IBM FORMAT (BLOCK) - TRANSFER AN IBM FILE TO CP/M FORMAT (BLOCK) - TRANSFER A CP/M FILE TO IBM FORMAT (SOURCE) - TRANSFER AN IBM FILE TO CP/M FORMAT (SOURCE) - - - - MAINTENANCE POLICIES - - - Maintenance Policies - - In the event of a problem, contact Robert M. White at (208) - 377-0336. He is responsible for answering questions relating to - installation, operation and maintenance. If the problem is - determined to be a part of this package, please obtain a printed - dump before calling for support. ALL user modifications must be - removed before obtaining any error analysis and correction from - Robert M. White. If the problem persists after initial contact, - please complete the Program Error Report supplied as a part of - this manual and send it along with all supporting documentation - to: - Robert M. White - 8530 Stonehaven - Boise, ID 83704 - - Robert M. White will provide custom modifications to users - who request them. These modifications may require an additional - charge and may not be quaranteed to function correctly in all - future releases. All agreements must be in writing. Estimates - will be issued pertaining to the work involved in performing the - modifications. - - - - - Program Error Report - - - Date: ________ Title:___________________________________________ - - Submittor:______________________________________________________ - - Address: ______________________________________________________ - - ______________________________________________________ - - ______________________________________________________ - - Phone: ( ) ___-____ ext. ____ - - Error Description: - - - - - - - - - - - Environment: - Computer Type: ________________________________________ - - Core Size: _____k - - No. and type of disks: ________________________________ - - Console type: ________________________________________ - - CP/M release: ________________________________________ - - - - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/ALOCK.Z80 b/software/CPM/CPM19_MTPUG_07/ALOCK.Z80 deleted file mode 100644 index e0040f3..0000000 --- a/software/CPM/CPM19_MTPUG_07/ALOCK.Z80 +++ /dev/null @@ -1,50 +0,0 @@ -TITLE KOCLA -; -; 9/22/82 Sue Arnold -; -; This is an assembly program that will lock a file record so that no -; other programs may access it. This routine should only be used to -; WRITE to a record that has been previously READ by the calling routine. -; It is VERY important to call UNLOCK after the write operation so as -; to free up the record for other routines. -; -; CALLING PROCEDURE= -; -; ALOCK (VAR FIB.addr: file_descriptor); (pointer to the file FIB) -; VAR lck_err: INTEGER; (0=success) -; -; This routine uses XDOS function number 2Ah for a lock. -; - - PAGE - .Z80 -; -BDOSJP EQU 5 ; Use this to call XDOS -; -; - PAGE - PUBLIC ALOCK - CSEG -; -; -ALOCK: - POP HL ; HL = Pascal Return Address - POP DE ; DE = The addr of the error code variable - EX (SP), HL ; HL = The addr of the file descriptor - ; (top of stack now has the Pascal rtn addr) - EX DE, HL ; DE = The addr of the descriptor - ; HL = The addr of the err code variable - LD C, 2AH ; LOCK function number - PUSH DE ; Save the addr of the descriptor - PUSH HL ; Save the error code addr - LD HL, 11H ; Add 17 to the address - ADD HL,DE ; To get the addr of the FCB within - EX DE,HL ; The file descriptor block - CALL BDOSJP ; lock out the record - POP HL ; Restore error code addr - POP DE ; Restore file descriptor address - LD (HL), A ; Put error code in err code variable - RET ; Else, Return to calling routine - - END ALOCK - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/AUNLCK.Z80 b/software/CPM/CPM19_MTPUG_07/AUNLCK.Z80 deleted file mode 100644 index f742381..0000000 --- a/software/CPM/CPM19_MTPUG_07/AUNLCK.Z80 +++ /dev/null @@ -1,48 +0,0 @@ -TITLE KCLNUA -; -; 9/22/82 Sue Arnold -; -; This is an assembly program that will UNLOCK a file record so that -; other programs may access it. This routine should only be used to -; UNLOCK a record that has been previously LOCKED by the calling routine. -; It is VERY important to unlock the record as no one else can do it -; for you. -; -; CALLING PROCEDURE= -; -; AUNLCK (VAR FIB.addr: file_descriptor); (pointer to the file FIB) -; VAR lck_err: INTEGER; (0=success) -; -; This routine uses XDOS function number 2Bh for an AUNLCK. -; - - .Z80 -; -BDOSJP EQU 5 ; Use this to call XDOS -; -; - PUBLIC AUNLCK - CSEG -; -; -AUNLCK: - POP HL ; HL = Pascal Return Address - POP DE ; DE = The addr of the error code variable - EX (SP), HL ; HL = The addr of the file descriptor - ; (top of stack now has the Pascal rtn addr) - EX DE, HL ; DE = The addr of the descriptor - ; HL = The addr of the err code variable - LD C, 2BH ; UNLOCK function number - PUSH DE ; Save the addr of the descriptor - PUSH HL ; Save the error code addr - LD HL, 11H ; Add 17 to the address - ADD HL,DE ; To get the addr of the FCB within - EX DE,HL ; The file descriptor block - CALL BDOSJP ; lock out the record - POP HL ; Restore error code addr - POP DE ; Restore file descriptor address - LD (HL), A ; Put error code in err code variable - RET ; Else, Return to calling routine - - END AUNLCK - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/BCD.DOC b/software/CPM/CPM19_MTPUG_07/BCD.DOC deleted file mode 100644 index 98d5ff7..0000000 --- a/software/CPM/CPM19_MTPUG_07/BCD.DOC +++ /dev/null @@ -1,13 +0,0 @@ -***************************************************************** -* * -* BCD.ERL -- Z80 VERSION OF BCDREALS.ERL (OF 5.5) * -* * -***************************************************************** - - -Thå  filå  BCD.ERÌ caî bå linkeä insteaä oæ BCDREALS.ERÌ anä  haó -thå samå entrù pointó aó thaô one¬ ió approx® 20¥ shorteò anä 25¥ -fasteò  thaî  thå originaì library®  Iô ió highlù  Z80- specific® -Durinç linë time¬ thå modulå namå displayó aó "Z80BCD¢ insteaä oæ -"BCD" to show that it is a different version. - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/BCD.ERL b/software/CPM/CPM19_MTPUG_07/BCD.ERL deleted file mode 100644 index a031a4e..0000000 Binary files a/software/CPM/CPM19_MTPUG_07/BCD.ERL and /dev/null differ diff --git a/software/CPM/CPM19_MTPUG_07/DISKIO.DOC b/software/CPM/CPM19_MTPUG_07/DISKIO.DOC deleted file mode 100644 index 8981437..0000000 --- a/software/CPM/CPM19_MTPUG_07/DISKIO.DOC +++ /dev/null @@ -1,37 +0,0 @@ - This file is the start of a library of I/O routines. The only -one implemented to date is the procedure 'GETARG'. - - GETARG is a procedure for getting command line arguments. For -example, if it were used in a program called DUMMY, then invoking the -program by typing: - - DUMMY NAME1 NAME2 - -will result in the procedure getarg returning NAME1 and NAME2. It also -returns the number of arguments ( up to 2). - - For example, in the above case, the number returned would be 2. -If the command line were: - - DUMMY NAME - -the procedure would return a number of 1 and it would be NAME. - - Finally, typing in a command line which caontains more than -two arguments causes getarg to return a number of 2 and the second -returned string would contain all the succeeding arguments. Thus, -if the command line were: - - DUMMY NAME1 NAME2 NAME3 NAME4 - -it would return NAME1 as the first string and NAME2 NAME3 NAME4 as the -second. - - The source code could, of course, be modified to separate out -more than two arguments. - - I first saw the technique used in this procedure in an article -in S-100 Microsystems by two Gilbreath's. - - J.A. Koehler, Saskatoon, 28 October, 1982 - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/DISKIO.SRC b/software/CPM/CPM19_MTPUG_07/DISKIO.SRC deleted file mode 100644 index 070fb2e..0000000 --- a/software/CPM/CPM19_MTPUG_07/DISKIO.SRC +++ /dev/null @@ -1,52 +0,0 @@ -module diskio; -{ - A file of diskio routines. - -} - - -procedure getarg(var narg:integer;var arg1,arg2:string); -{ - This procedure gets the arguments from the command line - and returns them as strings. narg is the number detected -} - -const cpm_buf_adr = $80; - sp = ' '; - -var p: ^byte; - sep: integer; - cmd_line: - string; - -begin - arg1:=''; - arg2:=''; - p:=cpm_buf_adr; - move(p^,cmd_line,sizeof(cmd_line)); - while pos(sp,cmd_line) = 1 do delete(cmd_line,1,1); - if length(cmd_line) = 0 - then narg := 0 - else - begin - sep:=pos(sp,cmd_line); - if sep = 0 - then - begin - narg:=1; - arg1:=cmd_line; - end - else - begin - arg1:=copy(cmd_line,1,sep-1); - delete(cmd_line,1,sep); - while copy(cmd_line,1,1)=sp do - delete(cmd_line,1,1); - narg:=2; - arg2:=cmd_line; - end; - end; -end; - -modend. - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/FOTOSATS.DOC b/software/CPM/CPM19_MTPUG_07/FOTOSATS.DOC deleted file mode 100644 index 413c18b..0000000 --- a/software/CPM/CPM19_MTPUG_07/FOTOSATS.DOC +++ /dev/null @@ -1,217 +0,0 @@ -.lh 10 -Versjon 8.10.82 Per Stangeland -.he - # - -TRYKKING AV WORDSTAR TEKST - -Teksô  soí  eò skreveô meä Wordstaò haò eî deì spesiellå  kjenne -tegn¬ soí gj|ò aô deî ikkå uteî viderå kaî leseó elleò skriveó aö -andrå  programmeò  foò  behandlinç aö  tekst®  Foò  eksempeì  viì -ordrenº  .pá f|rsô pý eî nù linjå gé nù side® Skriveó dettå uô aö -eô anneô tekstbehandlingsprogram¬  viì eî slië ordrå blé  st}endå -midt i teksten, og har ingen effekt. - -Detaljenå  é  hvá  soí  skilleò WS- teksô frá  andrå  teksteò  eò -gjengitô  é PP- nytô frá \stfolä Distriktsh|gskolå nò  7-82®  Heò -finó ogsý eô prograí soí oversetteò eî wordstar- teksô tiì vanliç -tekst¬  dvs®  ASCII- kodå  soí  kaî leseó undeò  operativsystemeô -CP/M. - -Problemeô  meä  dettå programmeô eò aô maî derveä ogsý misteò  då -spesiellå  redigeringsmulighetenå  soí eò lagô inî é  teksteî  aö -Wordstar®  Då fjernes¬  é stedeô foò ý oversetteó tiì kodeò  soí -kaî  leseó aö eô anneô tekstbehandlingssystem®  Dessuteî viì  deô -oftå v{rå n|dvendiç ý oversettå ogsý standarä CP/Í tegî tiì andrå -koder®  Eî fotosetteò aö merkeô LINOTRON¬  foò eksempel¬ viì ikkå -reagerå  riktiç pý standarä tegneô foò nù linjå é CP/M®  Deî  viì -helleò ikkå godtá meò eî etô mellomroí melloí hverô ord¬  menó WÓ -leggeò  inî flerå mellomroí foò ý fý tiì eî retô  h|yremarg®  Deî -f|lgeò helleò ikkå ASCII- tegnsettetº  Eô anf|rselstegî viì kommå -ut som en e med aksent over. - -Prograí FOTOSATS‚ oversetteò eî WS- teksô tiì eî teksô soí  egneò -seç  foò trykkinç aö eî fotosetter®  Etô enkelô skilletegî leggeó -inî  melloí  hverô  ord®  \vrigå blankå  tegî  oç  blankå  linjeò -fjernes®  Avsnitô  markereó  meä eô  egeô  symbol®  Overskrifter¬ -understrekningeò  oç  sitateò f}ò eî egeî mark|ò foraî oç  etter® -Deô  gió muligheô foò ý byttå uô enkeltå tegî meä eô fritô  valgô -annet tegn. - -Då  nyå tegî oç symboleò soí skaì leggeó inî é teksteî leseó  frá -eî egeî filº  FOTOSATS.PRM® Dennå mý liggå pý innloggeô diskenheô -veä kj|rinç aö programmet® - -É  dennå tabelleî eò kodenå soí eò brukô moô eî LINOTROΠ 202Î -gjengitt. -.lh 8 -.po 4 -.cp 20 Š -KONVERTERINGSKODER FRA SPESIELLE WS- TEGN TIL FOTOSETTER-TEGN - -Nr  Doô commandó é WS- fiì FOTOSATS.PRM - for LINOTRON 202N - --  .cð ø (indikereò oftå starô pý tabell© on-linå valg -1  .pá (ny side) Bell c1> -2  .lè 1° (halvanneî linjeavstand) ON: Bell c2> - OFF: Bell c5> -3  .lè ¸ smalå linjeò Bell c3> -´ .lè 1² dobbeì linjeavstanä Belì c4> -    Etter .lh 8: Bell c5> -   ASCII-kode -   Heø des. Betyr: -    --  0¸ 0¸ BÓ Backspacå bliò fjernet - -8  0² 0² feô trykë ^Ð Â ON: Bell c¸> -9   OFF: Bell c9> - -10 1³ 1¹ understrekinç p}/aö ^Ð Ó ON: Bell c10¾ -11 OFF: Bell c11> - -12 1´ 2° tegî halö linjå opð p}/aö ^Ð T ON: 0· 3ã 75 32 hex -13 OFF: Bell c13> - -14 22 34 anf|rselstegn " quote ON: 02 hex -15 OFF: 01 hex - -17 1Å 3° orddelingsforslag (Midt p} linja) @ (blir fjernet) -    -17 1Æ 3± orddelingsforslag( Pý slutten @ (blir fjernet) -    aö linjá, blir skrevet av WS) -    -18 0F 1µ non- breaë spacå (ordmellomrom ON: Bell c 15> - OFF:Bell c 15> - -19 8D SOFTLINÅ Markerinç aö linjeskifô Hvis eneste skilletegn -    inné avsnitô mellom to hele ord: 20 hex -    Ellers: blir fjernet - -20 0D 1³ CÒ - nytt avsnitt 1¶ 0³ 5E hex -    Š-  0á 1° LÆ (ny linje-f|lger etter CR) bliò fjernet -    -2± 0¹ 0¹  TAB(hopð fraí tiì bestemô kolonne©  Vanliç ordmellomrom - 20 hex - Belì      betyò 07hex -________________________________________________________________ -.lh 10 -.po 8 -En linje i fotosats.prm kan ogs} inneholde et spesielt symbol: - -Tegnet @ (40 hex) betyr "ingen tegn"- fjerning av WS-symbolet -Tegnet $ betyr standard linjeskift (0D 0A hex) - -Kodå  nò 6¬  · oç 1¶ eò lediç foò on-linå  markeringer¬  dvó  aô -brukereî  kaî  oppgé disså tallenå undeò kj|rinç aö  programmet¬ -n}ò  deô  dukkeò  opð  eî doô commanä soí  ikkå  eò  definerô  pý -forh}nd® - -Eksempelº  É  dennå  bruksanvisningeî liggeò deô eî .cð 3°  foraî -tabellen®  Deô betyò aô skrivereî skaì begynnå pý nù sidå  dersoí -deô  ikkå eò plasó tiì 3° nyå linjeò pý arket®  Kj|reò maî  dennå -teksteî  gjennoí  FOTOSATS- programmet¬  viì deô kommå  eô  BELL- -signal¬  oç utf|rinç aö programmeô viì stoppå opp®  Teksteî viseó -pý skjermen¬ oç brukereî kaî leggå inî eî |nskeô kode® ° betyò aô -ordreî skaì overses. - - -Bruk av programmet - -FOTOSATS.SRC er programkoden -FOTOSATS.COM er den kj|rbare versjonen -FOTOSATS.PRM inneholder LINOTRON 202N- parametrene. - -Ethvert CP/M system med minst en platestasjon kan brukes. - -FOTOSATS.COM, tekstfila og FOTOSATS.PRM m} ligge i systemet -S|rç  foò aô deô eò plasó pý tekstplateî tiì deî  nyå  versjonen® -Den blir lagt p} samme plate som originalen. - -Skriv FOTOSATS, og trykk RETURN - -Programmet sp|r om navn p} tekstfila. Oppgi dette, og trykk RETURN - -Teksteî  viseó pý skjermeî slië deî leseó inn®  Kontrolltegî  soí -ikkå kaî skrives¬ f® eks® linjeskift¬ erstatteó meä ? - ŠM|teò programmeô pý eî doô commanä soí ikkå eò  forh}ndsdefinert¬ -viì  deî  pipå oç bå oí eî verdé foò denne®  - -Deî nyå filá skriveó uô é sekvenseò pý 4Ë oí  gangen®  Programmeô -giò meldinç n}r dettå blir gjort® Filá f}ò navî .FOT® - -ENDRINGER I PARAMETERFILA - FOTOSATS.PRM - -Symbolenå  soí liggeò é FOTOSATS.PRÍ kaî skifteó uô etteò  |nske® -Hverô  symboì liggeò pý eî linje®  É dennå programversjoneî  skaì -deô  é  alô  v{rå  2±  slikå linjer®  Då  eò  gjengitô  é  riktiç -rekkef|lgå  é  tabelleî  ovenfor®  \nskeò  maî  eô  anneô  symboì -plasserô inî é teksteî é stedeô foò då soí eò foresl}tô her¬  kaî -maî  endrå  vedkommendå  symboì é FOTOSATS.PRÍ veä  hjelð  aö  eô -redigeringsprogram®  - -Eksempelº  Viì maî há eô vanliç linjeskifô é stedeô foò 1¶ 0³  5å -hex¬  mý  maî  endrå pý linjå 2° é parameterfila®  Legç inî eô  ¤ -symboì  (2´  hex©  é stedeô foò disså trå tegn®  Eî  vanliç  CP/Í -brukeò kaî fý dettå tiì veä hjelð aö WÓ oç DDT® Maî kunnå jï ogsý -lagå  eî interaktiö prosedyrå tiì FOTOSATS.SRà soí danneô  eî  nù -parameterfil® - -ENDRINGER I PROGRAMMET - -M}lsetningeî haò v{rô ý lagå eô generelô anvendbarô oversettings -prograí foò tekstfiler® Brukerå soí |nskeò ý skiftå frá WÓ tiì eô -anneô tekstbehandlingssystem¬  kaî derfoò ogsý há nyttå aö  prog -rammet®  É noeî tilfelleò skullå dettå kunnå gj|reó uteî ý  endrå -FOTOSATS.COM¬  barå veä ý skiftå uô noeî symboleò é FOTOSATS.PRM® -Meî  dersoí  definisjoneò elleò listeî oveò tegî soí skaì  endreó -skaì skifteó ut¬ mý deô skjå veä tilf|yelseò é FOTOSATS.SRà oç nù -kompilerinç  aö  programmet®  Programteksteî eò  strukturerô  oç -kommentert¬  slië  aô deô skullå v{rå muliç ý endrå pý deî  etteò -behoö  foò allå meä eô vissô kjennskað tiì  programmeringsspr}keô -PASCAL®  \nskeò  maî foò eksempeì ý skiftå uô allå û ü oç  ý  meä -andrå tegn¬ mý f|lgendå endringeò gj|res: - -i sekvensen CASE ord(ch) OF (* i procedure convert- linje 257 *) - -f|yer man til: - -'{': Enter(22); -'|': Enter(23); Š'}': Enter(24); - -CONSÔ no_of_codeó ½ 21» (F|rsô é programmet- linjå 4© endreó til - -CONST no_of_codes = 24; (*tre ekstra koder for {,|,}*) - -oç  filá FOTOSATS.PRÍ giò trå nyå linjer¬  soí inneholdeò då  trå -symbolene som {, |,} skal erstattes med. - -Programmeô   mý  deretteò  kompilereó  pý  nytt®   Andrå  Pascal- -kompilatorer enn MT+ vil kreve enkelte endringer i teksten. - -FOTOSATS.PRÍ  inneholdeò  då nyå symbolenå soí skaì inî  é  fila® -Hverô   symboì  avslutteó  meä  linjeskift¬   oç  nummerereó   aö -programmeô  é deî rekkef|lgå då leseó inn®  - -KAN TEKSTEN TRYKKES OPP N\YAKTIG SOM DEN BLIR? - -Eî visó sluttredigerinç é setterieô viì noë v{rå n|dvendiç meä då -flestå  tekstfiler®  Mengdeî aö slikå redigeringeò viì avhengå aö -hvordaî WS- teksteî vaò skreveô opprinnelig® Inkonsekvenô bruë aö -utheveô trykk¬ understrekningeò etc® kaî gé forvirrendå resultat® -Enkeltå  ordrå é WÓ viì blé oversetô - f.eks®  bruë aö smaì elleò -breä marg¬  oç marginnrykë veä sitater®  Tabelleò oç innholdsfor -tegnelseò viì oftå gé problemer®  Setterieô mý ogsý f|rå pý kodeò -foò skrifttype¬ sideformaô etc® - -Konsekvenô  bruë aö doô commandó oç andrå WS- ordrå viì  reduserå -behovet for slike rettinger. Forslag: - -Sett alltid .lh 10 ved start av teksten -Bruk .lh 8 for markering av sitat -Bruk .pa for markering av kapitler -Bruë  feô  skrifô  tiì  allå  overskrifter¬ og  understrekinç   tiì -uthevelser i teksten. - -Dettå  programmeô  eò gratió foò privatpersoner®  Dersoí  forlag¬ -trykkerieò elleò firmaeò |nskeò ý tá deô é kommersielì bruk¬  beó -då kontaktå Peò Stangeland¬ tlf® 04· 9761µ foò n{rmerå avtale® *) - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/FOTOSATS.PRM b/software/CPM/CPM19_MTPUG_07/FOTOSATS.PRM deleted file mode 100644 index 82d8d04..0000000 Binary files a/software/CPM/CPM19_MTPUG_07/FOTOSATS.PRM and /dev/null differ diff --git a/software/CPM/CPM19_MTPUG_07/FOTOSATS.SRC b/software/CPM/CPM19_MTPUG_07/FOTOSATS.SRC deleted file mode 100644 index 1e39d15..0000000 --- a/software/CPM/CPM19_MTPUG_07/FOTOSATS.SRC +++ /dev/null @@ -1,353 +0,0 @@ -PROGRAM FOTOSATS; -(*$R+*) -(* Versjon 4.10 1982 Per Stangeland*) - CONST - no_of_codes = 21; - - VAR - inn,(*WS- tekst*) - ut, (*Ferdig fotosats- kode*) - par, (*parameterfil*) - skjerm (*dvs. vanlig output, m} defineres for prosedyre ASCII*) : text; - ior, - i : integer; - tegn : char; - navn : string; - symbol : ARRAY [1..no_of_codes] OF string; - - EXTERNAL PROCEDURE @HLT; - - PROCEDURE ASCII(VAR print : text; ch : char); -(*Hentet fra program tofiler. Trengs bare til debugging her. -skriver ut vanlige ascii- symboler, evt. et sp|rsm}lstegn, p} forh}nds- -definert PRINT- fil (skjerm eller skriver). Gj|r om wordstar- tegn -til "normal" ASCII-kode ved hjelp av clrbit. Det spesielle trikset -med chr 255 skyldes at en clrbit vil konvertere den til chr 127, dvs. -delete - tegnet.*) - - BEGIN - IF ord(ch) = 255 THEN - ch := '?'; - clrbit(ch,7); - IF ord(ch) < 32 THEN - ch := '?'; - write(print,ch); - END; (*ASCII*) - - PROCEDURE convert(VAR s,d : text); -(* S = input file, D = output file. The S file is read, character by - character, by the CASE statement- line 258. - Special printer symbols are put into the buffer through procedure enter. - Ordinarù ASCIÉ characteró arå puô intï thå buffeò througè thå - IÆ statemenô in line 280. Symboì foò EOLÎ/enä oæ paragrapè are entered - bù thå nexô IF® Checë foò doô commands are done at the beginning of a - file and after each EOLN. Other symbols found in file S will be disregarded. - The D- file is written in 4 K blocks whenever the buffer is full.*) - - CONST -(*ASCII symbols used by Wordstar. Decimal notation.*) - SKIP = 0; (* characters that should not be transferred are set to 0 hex*) - fat = 2; (*backspace and double print*) - bel = 7; (*bell*) - bs = 8; (*back space ?*) - tab = 9; - lf = 10; - softline = 13; (*A "true" chr 13 will be trapped by the EOLN - check. Softline is an 8D hex after clrbit.*) - ns = 15; - underline = 19; - halfup = 20; - softhy = 30; - hy = 31; - space = 32; - quote = 34; - max = 4080; - bufsize = 4095; (*count may exceed max when - a long printer symbol is entered into the file. The buffer - size is therefore set to max+15 to prevent overflow.*) - - VAR - LAST_SYMBOL, - idx, - count, (*counts characters put into the buffer*) - i : integer; - buff :ARRAY [0..bufsize] OF char; (* 1..bufsize gives overflow. Why?*) - ch : char; - normaltext,fat_test,under_test,quote_test,half_test: boolean; - (*Set to FALSE in Switch, when printing in special typesets is in effect*) - dotcommand : string; - - PROCEDURE Dot; - (*DOT is called at every end- of line encountered in the S - file. - It detects dot commands. No action is taken if the first symbol - on a new line is not a '.' *) - - PROCEDURE lineheight; - (* Used by procedure dot to interpret line height symbols in the - WS file. '.LH 10' or 'LH 12' (1 1/2 and double spaced lines) - start a normal text sequence. '.LH 8' (narrow lines) is assumed - to indicate a quotation sequence. This sequence is marked by - symbol 3 (start) and symbol 5 (end) in the output file. Symbol - 2 and 4 should be alternate character sets. *) - - VAR - Digit, - L, - i, - NO : integer; - - BEGIN - NO := 0; - delete(dotcommand,1,3); (*remove the .lh *) - L := length(dotcommand); - IF (L = 0) THEN - undefined; - FOR i := 1 TO L DO - BEGIN (*transform string characters to integers*) - (*works OK in the 0 to 32767 range - no warning given - for larger numbers. Non-integer values are - ignored.*) - Digit := ord(dotcommand[i]) - 48; - IF digit in [0..9] THEN NO := NO * 10 + digit; - END; - CASE NO OF - 8 : switch(3,0,normaltext); (*normaltext is never false when a - .lh 8 is encountered. Enter 3 is - assumed to give a special typeset - for quotations. Is is terminated - when the text contains a .lh 10, - with enter 5.. - Normal printing is indicated by - Enter 2 - at the beginning of a - text and after quotations. *) - - 10 : BEGIN if normaltext then enter(2) - ELSE BEGIN - enter(5); - enter(2); - normaltext:=true; - END; - END; - 12 : BEGIN if normaltext then enter(4) - ELSE BEGIN - enter(5); - enter(4); - normaltext:=true; - END; - END;(*.lh 12*) - ELSE undefined; - END; (*CASE*) - END; (*lineheight*) - -(******************** DOT ***********************) - - BEGIN - IF EOF(S) THEN exit; - ch := S^; - WHILE ch = '.' DO - BEGIN - readln(s,dotcommand); - CASE dotcommand[2] OF - 'l','L' : - lineheight; - 'p','P' : - enter(1); - ELSE undefined; - END; (*CASE*) - ch := s^; - END; (*WHILE*) - END; (*DOT*) - -(**************** UNDEFINED ******************************) -(* Called by DOT at a command that requires operator intervention. - Also called by ENTER if 'normaltext' is FALSE at a '.LH 8' state- - ment. (E.G. two .lh 8 in a row. *) - - PROCEDURE undefined; - Var i: integer; - BEGIN - write(chr(BEL)); - writeln; - writeln('udefinert dot command: ',dotcommand); - writeln('oppgi |nsket parameternummer og trykk RETURN'); - writeln('skriv 0 hvis ordren skal oversees'); - readln(i); - IF (I in [1..no_of_codes]) THEN - enter(i); - END; - -(******************* ENTER **********************************) - PROCEDURE enter(code : integer); - - VAR - i : integer; - this_symbol : string; - SUBSTITUTE: CHAR; - - BEGIN - If code in [1..no_of_codes] then This_symbol := symbol[code] - ELSE BEGIN undefined; exit; END; - SUBSTITUTE:=this_SYMBOL[1]; - - CASE SUBSTITUTE OF - '$': (*A '$' symbol means a standard ASCII end of line. These symbols - cannot be present in the parameter file, since end of line - is used as separator between symbols.*) - BEGIN - Buff[count]:=chr(13); - Buff[count+1]:=chr(10); - count:=count+2; - END; - '@':EXIT; (*A chr(64) in the FOTOSATS.PRM means that no action is taken - at the corresponding ENTER number. Example: A '@' at line 11 - in FOTOSATS.PRM means that soft hyphens are omitted in the - output text.*) -ELSE - BEGIN - FOR i := 1 TO length(this_symbol) DO - BEGIN - buff[count] := this_symbol[i]; - count := count + 1; - END;(*FOR*) - END; (*ELSE*) - END; (*CASE*) - LAST_SYMBOL:=CODE; -END; (*enter*) - - PROCEDURE Switch(start,stop : integer; VAR normal: Boolean); - - (* Determines if a special symbol marks the start or the end of a - sequence. Calls enter to write the correct symbol to the output - buffer. *) - - BEGIN - IF normal THEN (* TRUE switch to special print symbol*) - BEGIN - normal := false; - enter(start); - END - ELSE (* FALSE End of special text - switch back to normal print*) - BEGIN - Normal := true; - Enter(stop); - END; - END; (*Switch*) - -(***************** CONVERT *******************************) - - BEGIN - normaltext := true; - fat_test:=true; - under_test :=true;; - half_test :=true;; - quote_test :=true; - count := 1; - dot; - WHILE not eof(s) DO - BEGIN - WHILE (not eof(s)) and (count < max) DO - BEGIN - WHILE (not eoln(s)) and (count < max) DO - BEGIN - ch := S^; - ASCII(skjerm,ch); - get(s); - clrbit(ch,7); - CASE ord(ch) OF - space :IF (BUFF[COUNT-1] =' ') OR (LASTSYMBOL=20) - THEN CH:=CHR(SKIP); - (*First space character is kept. Additional - space is skipped. No space after hard eoln.*) - fat: switch(8,9,fat_test); - underline:switch(10,11,under_test); - halfup: switch(12,13,half_test); - quote: BEGIN switch(14,15,quote_test); ch:=chr(skip);END; - hy: enter(17); - softhy: enter(17); - ns: enter(18); - softline: IF (buff[count-1] =' ') OR (lastsymbol = 17) then - ch:=chr(skip) ELSE enter(19); - (*soft line shifts are removed when the last - character on that line was a space character or - a soft hyphen. Symbol 19 - usually a space - character - is entered when line shift - is the only delimiter between two words in - the text.*) - tab: enter(21); - END; (*Case*) - - IF ch in [' '..'~'] THEN (*Enter ordinary ASCII symbols*) - BEGIN - buff[count] := ch; - count := count + 1; - last_symbol:=0; - END; (*IF*) - END; (*while not eoln*) - IF (eoln(s)) AND (not eof(s))THEN (*Enter end-of-line symbol*) - BEGIN - Readln(s); - IF lastsymbol <> 20 THEN Enter(20); - (*The first RETURN is kept,following ones are removed*) - Dot; (* check for dot commands*) - END; (*IF*) - IF (count <1) OR (count>max) then writeln(count); - END; (*while not EOF and count < max *) - -(****************** WRITE PHASE ***************************) - Writeln; - WRITELN(' Fil ',navn,' skrives - vennligst vent'); - FOR idx := 1 TO count - 1 DO - BEGIN - d^ := buff[idx]; - put(d); - END; (*FOR*) - Count:=1; (*start a new buffer*) - END; (*while not eof*) - END; (*procedure convert*) - - (********************************************************** - MAIN PROGRAM **) - - BEGIN - REPEAT - write('Navn p} Wordstar- fil: '); - readln(navn); - open(inn,navn,ior); - IF ior = 255 THEN - writeln('finner ikke ',navn); - UNTIL ior < 255; - I:=Pos('.',navn); - IF I>0 THEN delete(navn,I,length(navn)-I+1); - navn:=concat(navn,'.FOT'); - open(ut,navn,ior); - IF ior <> 255 THEN - BEGIN - write('fila ',navn,' fins fra f|r. Skal den slettes? (J/N)'); - read(tegn); - readln; - IF not (tegn in ['J','j']) THEN - @hlt; - END; - rewrite(ut); - assign(skjerm,'CON:'); - rewrite(skjerm); - open(par,'FOTOSATS.PRM',I); - IF i = 255 THEN - BEGIN - writeln('Finner ikke "FOTOSATS.PRM" '); - @hlt; - END; - FOR i := 1 TO no_of_codes DO - BEGIN - IF eof(par) then writeln('for f} symboler i fila "FOTOSATS.PRM') - ELSE readln(par,symbol[i]); - END; - writeln('Filene er }pnet - lesing begynner '); - IF not eof(inn) THEN - convert(inn,ut); - close(ut,ior); - IF ior < 255 THEN - writeln('fil ',navn,' er skrevet.'); - END. (*FOTOSATS*) - - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/GRAPH.DOC b/software/CPM/CPM19_MTPUG_07/GRAPH.DOC deleted file mode 100644 index d5abc42..0000000 --- a/software/CPM/CPM19_MTPUG_07/GRAPH.DOC +++ /dev/null @@ -1,140 +0,0 @@ - This set of program packages was the result of a concerted effort -to produce a PORTABLE set of graphic procedures which could be easily -transported from one machine to another. It was produced by myself and -a colleague .. Jack Gilmer. - - The problem originated because we had access to a number of -computers ranging from a large mainframe where we work ( at a university) -through several minis to the micros we have at home. There are many -different graphical packages available to us but it was all too -confusing to keep straight - life is just too short to become adept in -such a variety of programs. Secondly, most graphical packages are very -generalized and really are not well adapted to the type of work we do. -As physical scientists, we mostly wanted procedures which were well -suited to plotting line graphs - we essentially NEVER use bar plots, -pie plots etc. - - So, we designed a number of procedures which would fulfill our -requirements. The philosophy was to write the desired user oriented -procedures in terms of simpler procedures which ultimately call a very few -very primitive procedures which can be modified easily for any particular -combination of computer and plotter. - - The first set of these was written by me using Apple UCSD Pascal -with its 'Turtlegraphics' procedures for CRT graphics and a Houston -Instruments 'HIPLOT' plotter. Later, Jack adapted the packages to an LSI-11 -using Whitesmith's Pascal. This was done for two plotting systems; one of -these was an ADM3+ CRT plus a Digital Engineering 'Graphx' hard copy unit. -The other was for a HP 7225A pen plotter. - - The packages on this diskette are the latter two which have been -copied from the DEC diskettes using a program on the MTPUG program disk #1. -That program has, incidentally, been a godsend. - - If you want to use these procedures, you will have to adapt the -package to your machine/plotter combination by rewriting the serial I/O -outines and the primitive procedures called; - - PENUP - PENDOWN - DRAWTO - -I have modified the ADM3 package slightly so that it will at least compile -under Pascal MT+. The other one, called GRHP.SRC is just as it was on the -LSI-11. You will have to modify it a bit more extensively since Whitesmith's -Pascal does not have the UCSD string data type we have in MT+ but uses ZERO -terminated strings instead. - - Incidentally, since these procedures were all originally written -using UCSD Pascal, the more primitive procedures could all be hidden from -the user and so I used procedure names which were fairly descriptive. In -Pascal MT+, you may want to change the names to something more unusual for -these procedures in order not to give other procedures in your program the -same name. - - The plotted data is specified by a number of pre-defined data types -which are listed below. All plots were to be in absolute coordinates with -values given in MILLIMETERS. - - The data types are: - - astringtype = STRING[132]; - - aendtype = (noend, point, square, triangle, cross, ecks, diamond, - circle); - - alinetype = (noline, solid, dotted, dashed, dotdashed, - dotdotdashed); - - apointtype = RECORD (* absolute position in millimeters *) - x, - y: REAL; - END; - - You can see that we were primarily concerned with scientific type -plots since we wanted to be able to specify the type of line plotted and the -type of end to that line. For example, to plot a number of data points as -triangles, you use a particular procedure to set the type of line to 'noline' -and the type of endpoint to 'triangle'. Then you just call the plotting -procedure with the x,y positions of the points. - - The procedures and functions which you will use in your program are: - - AINIT - this initializes the plotter ( if it needs it ) to the - lower left corner. - - AWINDOW - this sets the plotting window. Lines which are called to - be plotted and which extend outside this window are cut off - at the boundaries by the software. - - ADEFAULT - sets the default parameters such as the pattern size for - patterned lines (dotted, dashed etc), the endpoint sizes etc. - - ABADCALL - a function to determine whether or not the called for point - is so far outside the plotting window that serious arithmetic - round off errors will cause plotting errors. This function - has not been implemented in any of the packages we've written. - This probably means that it is not necessary. - - AMAKECOPY - sets the hard copy unit into motion if it is different - from the CRT display. - - ASETWINDOW - sets up the window limits. - - ASETPLOT - sets up the plotting parameters. These are the type of - line, the type of endpoint etc. - - APLOT - plots a line to the point specified. The characteristics of - the line and its end are what has last been set with - ASETPLOT. - - ASETSTR - sets up the characteristics of the text plotting. These - are the character size, character orientation, character - spacing, string orientation and character width. For many - plotters like the ADM3+ plus Graphx combination, this - procedure does nothing since the text characteristics are - fixed. - - ASTR - writes a string starting in the current pen location. - - ATEXT - switches back from graphical to text mode ( needed for - all types of CRT monitors). - - AGRAPH - switches to graph mode - - AWHERE - returns the current pen position. - - - Good luck... I would be interested in hearing from anyone who uses -these packages for another computer/plotter combination. I would be glad to -help out anyone who is having difficulty in transporting these procedures -to another system - just please don't expect me to rewrite the whole thing. -Jack and I would also be interested in hearing from anyone who has construct- -ive comments about the utility of the procedures and suggestions for -improvements. - - J.A. Koehler - 2 Sullivan St. - Saskatoon, SK, S7H-3G8 28 October, 1982 - - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/GRAPHADM.SRC b/software/CPM/CPM19_MTPUG_07/GRAPHADM.SRC deleted file mode 100644 index d14634e..0000000 --- a/software/CPM/CPM19_MTPUG_07/GRAPHADM.SRC +++ /dev/null @@ -1,795 +0,0 @@ -MODULE GRAPH ; - (*------------------------------------------------------------------*) - (* *) - (* Written Mar 22,'82 by Jack Gilmer *) - (* *) - (* Modified Oct 23,'82 by J.A. Koehler from Whitesmiths PASCAL *) - (* as used on LSI-11 to PASCAL MT+ *) - (* *) - (* This file of absolute graphic routines implements the standard *) - (* graphics package for the Lear Seigler ADM 3A+ equipped with the *) - (* Graphx hard copy. All positions are in mm. on a 170 by 130 mm. *) - (* page. All angles are in degrees up from the x-axis. *) - (* *) - (* NOTE - The ADM 3A+ emulates a Tektronix terminal and uses a *) - (* virtual screen size of 1024 by 780, and translates this to pixel *) - (* co-ordinates of 512 by 250 internally. *) - (*------------------------------------------------------------------*) - - CONST - xfactor = 6.0532; (* # of steps/mm on the Tektronix 1024 by *) - yfactor = 6.0387; (* 780 - ADM 3A+ translates to 512 by 250.*) - - nulcode = 0; (* ASCII NUL *) - eotcode = 4; (* ASCII EOT *) - enqcode = 5; (* ASCII ENQ *) - etbcode = 23; (* ASCII ETB *) - cancode = 24; (* ASCII CAN *) - emcode = 25; (* ASCII EM *) - esccode = 27; (* ASCII ESC *) - fscode = 28; (* ASCII FS *) - gscode = 29; (* ASCII GS *) - uscode = 31; (* ASCII US *) - - maxsent = 20; (* # of co-ord pairs sent before handshake *) - - minx = 0; (* screen co-ords in mm. *) - maxx = 169; - miny = 0; - maxy = 129; - - absmaxx = 10000.0; (* absolute calculation limits *) - absmaxy = 10000.0; - - radian = 57.2958; (* degrees/radian *) - - - TYPE - astringtype = STRING[132]; - - aendtype = (noend, point, square, triangle, cross, ecks, diamond, - circle); - - alinetype = (noline, solid, dotted, dashed, dotdashed, - dotdotdashed); - - apointtype = RECORD (* absolute position in millimeters *) - x, - y: REAL; - END; - - byte = 0..255; - - (* units for 'serio' routines *) - unittype = (conunit, prunit, admunit, hpunit); - - - VAR - oldend: aendtype; (* last end symbol defined *) - - oldline: alinetype; (* last set line type *) - - oldpt, (* last point plotted *) - oldleft, (* existing window corners in mm.*) - oldright: apointtype; - - penlifted: BOOLEAN; (* last pen position *) - - numsent: INTEGER; (* co-ord counter for handshake *) - - oldesize, (* last set end symbol radius *) - oldrptlength: REAL; (* last set line pattern length *) - - - - EXTERNAL FUNCTION serin(unit: unittype): CHAR; - - EXTERNAL PROCEDURE serout(unit: unittype; ch: CHAR); - - - FUNCTION getadm: byte; - (*------------------------------------------------------------------*) - (* Gets a byte from the ADM 3A+ terminal port using 'serin'. *) - (*------------------------------------------------------------------*) - - BEGIN (* getadm *) - getadm := ORD(serin(admunit)) MOD 128; - END; (* getadm *) - - - - PROCEDURE putadm(outbyte: byte); - (*------------------------------------------------------------------*) - (* Puts out 'outbyte' to the ADM 3A+ terminal port using 'serout'. *) - (*------------------------------------------------------------------*) - - BEGIN (* putadm *) - serout(admunit, CHR(outbyte)); - END; (* putadm *) - - - - PROCEDURE handshake; - (*------------------------------------------------------------------*) - (* Handshakes with the ADM 3A+. *) - (*------------------------------------------------------------------*) - - BEGIN (* handshake *) - putadm(esccode); (* ask for response *) - putadm(enqcode); - WHILE getadm <> eotcode DO; (* sent when ready *) - END; (* handshake *) - - - - PROCEDURE penup; - (*------------------------------------------------------------------*) - (* Simply sets the 'penlifted' indicator as 'drawto' takes care of *) - (* the ADM 3A+ 'pen'. *) - (*------------------------------------------------------------------*) - - BEGIN (* penup *) - penlifted := TRUE; - END; (* penup *) - - - - PROCEDURE pendown; - (*------------------------------------------------------------------*) - (* Simply sets the 'penlifted' indicator as 'drawto' takes care of *) - (* the ADM 3A+ 'pen'. *) - (*------------------------------------------------------------------*) - - BEGIN (* pendown *) - penlifted := FALSE; - END; (* pendown *) - - - - FUNCTION isinwindow(pt: apointtype): BOOLEAN; - (*------------------------------------------------------------------*) - (* Returns TRUE if the 'pt' is within the window defined by *) - (* 'oldleft' and 'oldright'. *) - (*------------------------------------------------------------------*) - - BEGIN (* isinwindow *) - isinwindow := (pt.x <= oldright.x) AND (pt.y <= oldright.y) AND - (pt.x >= oldleft.x) AND (pt.y >= oldleft.y); - END; (* isinwindow *) - - - - PROCEDURE plot(dest: apointtype; - how: alinetype; - endsym: aendtype); - (*------------------------------------------------------------------*) - (* Plots a line from the present position to 'dest' using the *) - (* pattern in 'how' and the end symbol in 'endsym'. The line is *) - (* constrained to stay within the current window. *) - (*------------------------------------------------------------------*) - - VAR - previous, (* pattern endpoints *) - temp: apointtype; - - i, (* pattern loop counter *) - number: INTEGER; (* # of patterns in line *) - - dx, (* pattern repeat spacing *) - dy, - len: REAL; (* line length *) - - - - PROCEDURE drawto(dest: apointtype); - (*----------------------------------------------------------------*) - (* Moves the pen to 'dest' with the pen specified by 'penlifted'.*) - (*----------------------------------------------------------------*) - - VAR - temp: apointtype; (* window crossing points *) - - - PROCEDURE plotpoint(at: apointtype); - (*--------------------------------------------------------------*) - (* Moves the pen to 'at'. *) - (*--------------------------------------------------------------*) - - VAR - xint, (* integer plotting values, *) - yint: INTEGER; (* between 0 and 779 or 1023 *) - - - BEGIN (* plotpoint *) - xint := round(at.x * xfactor); - yint := round(at.y * yfactor); - - putadm(((yint DIV 32) MOD 32) + 32); (* ms 1/2 of y *) - putadm((yint MOD 32) + 96); (* ls 1/2 of y *) - putadm(((xint DIV 32) MOD 32) + 32); (* ms 1/2 of x *) - putadm((xint MOD 32) + 64); (* ls 1/2 of x *) - - numsent := numsent + 1; (* need to handshake? *) - IF numsent > maxsent - THEN - BEGIN - numsent := 0; - handshake; - putadm(gscode); (* re-draw to the point *) - putadm(((yint DIV 32) MOD 32) + 32); (* ms 1/2 of y *) - putadm((yint MOD 32) + 96); (* ls 1/2 of y *) - putadm(((xint DIV 32) MOD 32) + 32); (* ms 1/2 of x *) - putadm((xint MOD 32) + 64); (* ls 1/2 of x *) - END; (* IF numsent ... *) - END; (* plotpoint *) - - - PROCEDURE interpolate(inside, - outside: apointtype; - VAR crossing: apointtype); - (*--------------------------------------------------------------*) - (* Finds the window crossing point on the line between 'inside'*) - (* and 'outside'. The result is returned in 'crossing'. *) - (*--------------------------------------------------------------*) - - - - FUNCTION vertcross(left, - right: apointtype; - midx: REAL): REAL; - (*------------------------------------------------------------*) - (* Finds the vertical crossing point at 'midx' on the *) - (* line between 'left' and 'right'. *) - (*------------------------------------------------------------*) - - BEGIN (* vertcross *) - vertcross := left.y + (right.y - left.y) * - (midx - left.x) / (right.x - left.x); - END; (* vertcross *) - - - - FUNCTION horcross(bottom, - top: apointtype; - midy: REAL): REAL; - (*------------------------------------------------------------*) - (* Finds the horizontal crossing point at 'midy' on the *) - (* line between 'bottom' and 'top'. *) - (*------------------------------------------------------------*) - - BEGIN (* horcross *) - horcross := bottom.x + (top.x - bottom.x) * - (midy - bottom.y) / (top.y - bottom.y); - END; (* horcross *) - - - - BEGIN (* interpolate *) - crossing.x := -1; (* indicate crossing not found *) - crossing.y := -1; - - IF outside.x < oldleft.x (* is it to the left? *) - THEN - BEGIN - crossing.x := oldleft.x; - crossing.y := vertcross(outside, inside, - oldleft.x); - END (* IF outside ... *) - ELSE IF outside.x > oldright.x (* or to the right? *) - THEN - BEGIN - crossing.x := oldright.x; - crossing.y := vertcross(inside, outside, - oldright.x); - END; (* ELSE IF outside.x ... *) - - IF NOT isinwindow(crossing) (* did we not find it yet? *) - THEN - IF outside.y < oldleft.y (* is it below? *) - THEN - BEGIN - crossing.y := oldleft.y; - crossing.x := horcross(outside, inside, - oldleft.y); - END (* IF outside ... *) - ELSE IF outside.y > oldright.y (* or above? *) - THEN - BEGIN - crossing.y := oldright.y; - crossing.x := horcross(inside, outside, - oldright.y); - END; (* ELSE IF outside.y ... *) - END; (* interpolate *) - - - - BEGIN (* drawto *) - - IF penlifted - THEN - putadm(gscode); - - IF isinwindow(oldpt) - THEN - IF isinwindow(dest) - THEN - plotpoint(dest) - ELSE - BEGIN - interpolate(oldpt, dest, temp); - plotpoint(temp); - END (* ELSE *) - ELSE IF isinwindow(dest) - THEN - BEGIN - interpolate(dest, oldpt, temp); - putadm(gscode); - plotpoint(temp); - IF penlifted - THEN - putadm(gscode); - plotpoint(dest); - END; (* ELSE IF ... *) - oldpt := dest; - END; (* drawto *) - - - - PROCEDURE draw(what: aendtype); - (*----------------------------------------------------------------*) - (* Draws the endpoint symbol 'what' with size 'oldesize' *) - (* centered at the present position. *) - (*----------------------------------------------------------------*) - - VAR - origin, (* holds line endpoint *) - temp: apointtype; - - oldpenup: BOOLEAN; (* holds old penlifted *) - - - - PROCEDURE closed(initangle: REAL; - npoints: INTEGER); - (*--------------------------------------------------------------*) - (* Plots a polygon of size 'oldesize' with 'npoints' *) - (* corners starting at 'initangle' degrees clockwise from *) - (* vertical centered at 'origin'. *) - (*--------------------------------------------------------------*) - - VAR - i: INTEGER; (* corner counter *) - - angle: REAL; (* angle counter *) - - - BEGIN (* closed *) - FOR i := 0 to npoints DO - BEGIN - IF i = 0 - THEN - penup - ELSE IF penlifted - THEN - pendown; - angle := (initangle + i * (360.0 / npoints)) / radian; - temp.x := origin.x + oldesize * sin(angle); - temp.y := origin.y + oldesize * cos(angle); - drawto(temp); - END; (* FOR i ... *) - END; (* closed *) - - - - PROCEDURE open(initangle: REAL); - (*--------------------------------------------------------------*) - (* Plots a cross of size 'oldesize' with one axis at *) - (* 'initangle' clockwise from vertical centered at 'origin'. *) - (*--------------------------------------------------------------*) - - VAR - i, (* loop counters *) - j: INTEGER; - - angle, (* angle of a line segment *) - stangle: REAL; (* start angle of a line segment *) - - - BEGIN (* open *) - FOR j := 0 TO 1 DO - BEGIN - stangle := initangle + j * 90.0; - FOR i := 0 TO 1 DO - BEGIN - IF i = 0 - THEN - penup - ELSE - pendown; - angle := (stangle + i * 180.0) / radian; - temp.x := origin.x + oldesize * sin(angle); - temp.y := origin.y + oldesize * cos(angle); - drawto(temp); - END; (* FOR i ... *) - END; (* FOR j ... *) - END; (* open *) - - - - BEGIN (* draw *) - IF what <> noend - THEN - BEGIN - origin := oldpt; (* save endpoint *) - oldpenup := penlifted; (* and pen status *) - IF what IN [square, triangle, diamond, circle, cross, ecks] - THEN - CASE what OF - square: closed(45.0, 4); - triangle: closed(0.0, 3); - diamond: closed(0.0, 4); - circle: closed(0.0, 10); - cross: open(0.0); - ecks: open(45.0); - END (* CASE what *) - ELSE IF what = point - THEN - BEGIN - pendown; - putadm(fscode); (* go to point mode *) - drawto(origin); (* re-draw point *) - END; (* ELSE IF what ... *) - - IF NOT penlifted (* return to last endpoint *) - THEN - penup; - drawto(origin); (* also resets vector mode *) - IF NOT oldpenup - THEN - pendown; - END; (* IF what... *) - END; (* draw *) - - - - PROCEDURE pltpat(source, - dest: apointtype); - (*----------------------------------------------------------------*) - (* Plots the a line segment of the pattern 'how' from 'source' *) - (* to 'dest'. *) - (*----------------------------------------------------------------*) - - VAR - p1, (* pattern fraction endpoints *) - p2, - p3: apointtype; - - dx, (* pattern fraction increment *) - dy: REAL; - - - BEGIN (* pltpat *) - CASE how OF - dotted: BEGIN - IF NOT penlifted - THEN - penup; - drawto(dest); - draw(point); - END; (* dotted: *) - dashed: BEGIN - p1.x := (source.x + dest.x) / 2.0; - p1.y := (source.y + dest.y) / 2.0; - IF NOT penlifted - THEN - penup; - drawto(p1); - pendown; - drawto(dest); - END; (* dashed: *) - dotdashed: BEGIN - dx := (dest.x - source.x) / 3.0; - dy := (dest.y - source.y) / 3.0; - p1.x := source.x + dx; - p2.x := p1.x + dx; - p1.y := source.y + dy; - p2.y := p1.y + dy; - IF NOT penlifted - THEN - penup; - drawto(p1); - draw(point); - drawto(p2); - pendown; - drawto(dest); - END; (* dotdashed: *) - dotdotdashed: BEGIN - dx := (dest.x - source.x) / 4.0; - dy := (dest.y - source.y) / 4.0; - p1.x := source.x + dx; - p2.x := p1.x + dx; - p3.x := p2.x + dx; - p1.y := source.y + dy; - p2.y := p1.y + dy; - p3.y := p2.y + dy; - IF NOT penlifted - THEN - penup; - drawto(p1); - draw(point); - drawto(p2); - draw(point); - drawto(p3); - pendown; - drawto(dest); - END; (* dotdotdashed: *) - END; (* CASE how *) - END; (* pltpat *) - - - - BEGIN (* plot *) - IF dest.x > absmaxx - THEN - dest.x := absmaxx - ELSE IF dest.x < (0 - absmaxx) - THEN - dest.x := (0 - absmaxx); - IF dest.y > absmaxy - THEN - dest.y := absmaxy - ELSE IF dest.y < (0 - absmaxy) - THEN - dest.y := (0 - absmaxy); - - IF how IN [noline, solid] (* segmenting not needed *) - THEN - BEGIN - IF how = noline - THEN - penup - ELSE - pendown; - drawto(dest); - END (* IF how ... *) - ELSE - BEGIN - len := sqr(oldpt.x - dest.x) + sqr(oldpt.y - dest.y); - IF len > 0.25 (* make sure won't bomb on *) - THEN (* underflow *) - len := sqrt(len) - ELSE - len := 0; - number := 1 + trunc(len / oldrptlength); - dx := (dest.x - oldpt.x) / number; - dy := (dest.y - oldpt.y) / number; - previous := oldpt; - FOR i := 1 TO number DO - BEGIN - temp.x := previous.x + dx; - temp.y := previous.y + dy; - pltpat(previous, temp); - previous := temp; - END; (* FOR i ... *) - END; (* ELSE *) - - draw(endsym); - END; (* plot *) - - - - FUNCTION abadcall: BOOLEAN; - (*------------------------------------------------------------------*) - (* Returns TRUE if something is wrong with a procedure call. Not *) - (* implemented. *) - (*------------------------------------------------------------------*) - - BEGIN (* abadcall *) - abadcall := FALSE; - END; (* abadcall *) - - - - PROCEDURE adefault; - (*------------------------------------------------------------------*) - (* Sets all globals to their default values. *) - (*------------------------------------------------------------------*) - - BEGIN (* adefault *) - oldend := noend; (* simple line *) - oldesize := 3.0; - oldrptlength := 5.0; - oldline := noline; - oldleft.x := minx; (* window size to full screen *) - oldleft.y := miny; - oldright.x := maxx; - oldright.y := maxy; - END; (* adefault *) - - - - PROCEDURE agraph; - (*------------------------------------------------------------------*) - (* Sets the ADM 3A+ into the vector graphics mode and clears the *) - (* screen. *) - (*------------------------------------------------------------------*) - - BEGIN (* agraph *) - putadm(gscode); (* enter vector mode *) - putadm(emcode); (* clear the screen *) - handshake; - END; (* agraph *) - - - - PROCEDURE ainit; - (*------------------------------------------------------------------*) - (* Initializes the I/O to the ADM 3A+ terminal, the character set, *) - (* sets all paramters to their default values, and places the pen *) - (* in the lower left-hand corner. *) - (*------------------------------------------------------------------*) - - BEGIN (* ainit *) - adefault; - agraph; - oldpt.x := 0; - oldpt.y := 0; - numsent := 0; - plot(oldpt, noline, noend); - END; (* ainit *) - - - - PROCEDURE amakecopy; - (*------------------------------------------------------------------*) - (* Initiates a copy cycle from the ADM 3A+ to the Graphx printer *) - (* and waits for it to finish. *) - (*------------------------------------------------------------------*) - - BEGIN (* amakecopy *) - putadm(esccode); (* send copy command *) - putadm(etbcode); - handshake; - END; (* amakecopy *) - - - - PROCEDURE aplot(endpoint: apointtype); - (*------------------------------------------------------------------*) - (* Plots to 'endpoint' using line type 'oldline' and end type *) - (* 'oldend'. *) - (*------------------------------------------------------------------*) - - BEGIN (* aplot *) - plot(endpoint, oldline, oldend); - END; (* aplot *) - - - - PROCEDURE asetplot(line: alinetype; - repeatlength, - endsize: REAL; - endsymbol: aendtype); - (*------------------------------------------------------------------*) - (* Sets the characteristics of the line(s) to be plotted next. *) - (*------------------------------------------------------------------*) - - BEGIN (* asetplot *) - oldline := line; - oldrptlength := repeatlength; - oldesize := endsize; - oldend := endsymbol; - END; (* asetplot *) - - - - PROCEDURE asetstr(charheight, - charwidth, - charangle, - charspace, - strangle: REAL); - (*------------------------------------------------------------------*) - (* Sets the characteristics of the next string(s) to be plotted. *) - (*------------------------------------------------------------------*) - - BEGIN (* asetstr *) (* do nothing in this implementation *) - END; (* asetstr *) - - - - PROCEDURE asetwindow(lowerleft, - upperright: apointtype); - (*------------------------------------------------------------------*) - (* Sets the window size. Nothing will appear outside this window. *) - (*------------------------------------------------------------------*) - - BEGIN (* asetwindow *) - oldleft := lowerleft; - oldright := upperright; - IF lowerleft.x < minx - THEN - oldleft.x := minx; - IF lowerleft.y < miny - THEN - oldleft.y := miny; - IF upperright.x > maxx - THEN - upperright.x := maxx; - IF upperright.y > maxy - THEN - upperright.y := maxy; - END; (* asetwindow *) - - - - PROCEDURE asize(VAR size: apointtype); - (*------------------------------------------------------------------*) - (* Returns the size of the display in mm. *) - (*------------------------------------------------------------------*) - - BEGIN (* asize *) - size.x := maxx - minx; - size.y := maxy - miny; - END; (* asize *) - - - - PROCEDURE astr(str: astringtype); - (*------------------------------------------------------------------*) - (* Writes the null-terminated string 'str' on the screen starting *) - (* at the current location (taken as the lower left corner of the *) - (* first character) and proceeding at 'oldstrangle'. The *) - (* character angle, height, width and spacing is 'oldchangle', *) - (* 'oldchheight', 'oldchwidth' and 'oldchspace'. *) - (* *) - (* In this implementation, the 4010 mode of text writing is *) - (* used, so only one size of upper case characters at a horizontal *) - (* direction is possible; all the above variables are ignored. *) - (*------------------------------------------------------------------*) - - VAR - index: INTEGER; - - - BEGIN (* astr *) - handshake; - putadm(uscode); (* enter 4010 alpha mode *) - - index := 1; (* put out characters *) - WHILE ord(str[index]) <> nulcode DO - BEGIN - putadm(ord(str[index])); - index := index + 1; - END; (* WHILE str... *) - - putadm(gscode); (* re-enter vector mode *) - handshake; - END; (* astr *) - - - - PROCEDURE atext; - (*------------------------------------------------------------------*) - (* Sets the display to the text mode. *) - (*------------------------------------------------------------------*) - - BEGIN (* atext *) - putadm(uscode); (* enter 4010 alpha mode *) - putadm(cancode); (* and then to ADM 3A alpha mode *) - END; (* atext *) - - - - PROCEDURE awhere(VAR where: apointtype; - VAR inwindow: BOOLEAN); - (*------------------------------------------------------------------*) - (* Returns the current locatation and whether it's inside the *) - (* window. *) - (*------------------------------------------------------------------*) - - BEGIN (* awhere *) - where := oldpt; - inwindow := isinwindow(oldpt); - END; (* awhere *) -modend. - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/GRHP.SRC b/software/CPM/CPM19_MTPUG_07/GRHP.SRC deleted file mode 100644 index 059144d..0000000 --- a/software/CPM/CPM19_MTPUG_07/GRHP.SRC +++ /dev/null @@ -1,802 +0,0 @@ -module (output); - (*------------------------------------------------------------------*) - (* *) - (* Written Apr 26,'82 by Jack Gilmer *) - (* *) - (* This file of absolute graphic routines implements the standard *) - (* graphics package for the HP 7225A plotter. All positions are in *) - (* mm. on a 250 by 180 mm. page. All angles are in degrees up from *) - (* the x-axis. *) - (* *) - (*------------------------------------------------------------------*) - - - xfactor = 40.0; (* # of steps/mm on the HP 7225A *) - yfactor = 40.0; - - nulcode = 0; (* ASCII NUL *) - etxcode = 3; (* ASCII ETX *) - enqcode = 5; (* ASCII ENQ *) - ackcode = 6; (* ASCII ACK *) - esccode = 27; (* ASCII ESC *) - - maxsent = 136; (* # of words sent before handshake *) - - minx = 0; (* screen co-ords in mm. *) - maxx = 250; - miny = 0; - maxy = 180; - - percent = 0.32461; (* conversion factor from mm. to % of *) - (* diagonal of screen co-ordinates *) - - radian = 57.2958; (* degrees/radian *) - - maxhpstr = 10; (* short strings for commands, etc. *) - - absp1x = 328; (* position of lower left corner *) - absp1y = 279; (* in abs HP plotter units for window *) - - - TYPE - astringtype = PACKED ARRAY [1..132] OF CHAR; (* null-terminated *) - - aendtype = (noend, point, square, triangle, cross, ecks, diamond, - circle); - - alinetype = (noline, solid, dotted, dashed, dotdashed, - dotdotdashed); - - apointtype = RECORD (* absolute position in millimeters *) - x, - y: REAL; - END; - - cmdstrtype = PACKED ARRAY [1..2] OF CHAR; - hpstrtype = PACKED ARRAY [1..maxhpstr] OF CHAR; - - unittype = (conunit, prunit, admunit, hpunit); - - - VAR - oldend: aendtype; (* last end symbol defined *) - - oldline: alinetype; (* last set line type *) - - oldpt, (* last point plotted *) - oldleft, (* existing window corners in mm.*) - oldright: apointtype; - - oldpenlifted, (* last sent pen up/down instruction *) - penlifted: BOOLEAN; (* last pen position *) - - numsent: INTEGER; (* co-ord counter for handshake *) - - oldesize, (* last set end symbol radius *) - oldrptlength: REAL; (* last set line pattern length *) - - - - FUNCTION serin(unit: unittype): CHAR; EXTERNAL; - - PROCEDURE serout(unit: unittype; ch: CHAR); EXTERNAL; - - PROCEDURE exit(success: BOOLEAN); EXTERNAL; - - - FUNCTION gethp: CHAR; - (*------------------------------------------------------------------*) - (* Gets a character from the HP port using 'serin'. *) - (*------------------------------------------------------------------*) - - BEGIN (* gethp *) - gethp := serin(hpunit); - END; (* gethp *) - - - - PROCEDURE puthp(outchar: CHAR); - (*------------------------------------------------------------------*) - (* Puts out 'outchar' the port to the HP plotter. If the *) - (* system call fails, the program aborts with an error message. *) - (*------------------------------------------------------------------*) - - BEGIN (* puthp *) - serout(hpunit, outchar); - END; (* puthp *) - - - - PROCEDURE handshake(roomfor: INTEGER); - (*------------------------------------------------------------------*) - (* Makes sure there is room for 'roomfor' bytes in the HP 7225A *) - (* buffer. Performs the handshake sequence only when necessary. *) - (*------------------------------------------------------------------*) - - BEGIN (* handshake *) - numsent := numsent + roomfor; - IF numsent > maxsent - THEN - BEGIN - numsent := 0; - puthp(chr(enqcode)); - WHILE gethp <> chr(ackcode) DO; - END; (* IF numsent ... *) - END; (* handshake *) - - - - PROCEDURE puthpstr(str: hpstrtype); - (*------------------------------------------------------------------*) - (* Puts out 'str' using 'puthp' up to but not including the first *) - (* blank. *) - (*------------------------------------------------------------------*) - - VAR - index: 0..maxhpstr; - - BEGIN (* puthpstr *) - handshake(maxhpstr); - index := 0; - REPEAT - index := index + 1; - IF str[index] <> ' ' - THEN - puthp(str[index]); - UNTIL (index = maxhpstr) OR (str[index] = ' '); - END; (* puthpstr *) - - - - PROCEDURE putinum(i: INTEGER); - (*------------------------------------------------------------------*) - (* Sends the integer 'i' to the HP plotter in the form: iiiii or *) - (* -iiiii. Leading zeroes are suppressed. *) - (*------------------------------------------------------------------*) - - VAR - digit, (* single digit *) - factor: INTEGER; (* digit selector *) - - - BEGIN (* putinum *) - IF i < 0 (* send '-' if nec. *) - THEN - BEGIN - puthp('-'); - i := 0 - i; - END; (* IF i < 0 *) - factor := 10000; (* find 1st digit *) - WHILE ((i DIV factor) = 0) AND (factor > 1) DO - factor := factor DIV 10; - WHILE factor > 0 DO (* send digits *) - BEGIN - digit := i DIV factor; - puthp(chr(ord('0') + digit)); - i := i - (digit * factor); - factor := factor DIV 10; - END; (* WHILE factor ... *) - END; (* putinum *) - - - - PROCEDURE putdnum(d: REAL); - (*------------------------------------------------------------------*) - (* Sends the real number 'd' to the HP plotter in the form: *) - (* ddd.ddd or -ddd.ddd. Leading zeroes are suppressed. *) - (*------------------------------------------------------------------*) - - VAR - digit, (* individual digit *) - factor, (* counts order of digit sent *) - i: INTEGER; (* temporary value of d *) - - - BEGIN (* putdnum *) - i := trunc(d); (* put the integral part, *) - putinum(i); - - puthp('.'); (* the decimal point, *) - - i := trunc(1000.0 * abs((d - i))); (* then the fraction *) - factor := 100; - WHILE factor > 0 DO - BEGIN - digit := i DIV factor; (* get digit to send *) - puthp(chr(ord('0') + digit)); (* and send it *) - i := i - (digit * factor); - factor := factor DIV 10; - END; (* WHILE factor *) - END; (* putdnum *) - - - - PROCEDURE putddcmd(cmd: cmdstrtype; - d1, - d2: REAL); - (*------------------------------------------------------------------*) - (* Sends a command and two decimal parameters to the HP plotter. *) - (*------------------------------------------------------------------*) - - BEGIN (* putddcmd *) - handshake(20); - - puthp(cmd[1]); (* send command *) - puthp(cmd[2]); - - putdnum(d1); (* now the parameters *) - puthp(','); - putdnum(d2); - puthp(';'); - END; (* putddcmd *) - - - - PROCEDURE putidcmd(cmd: cmdstrtype; - i: INTEGER; - d: REAL); - (*------------------------------------------------------------------*) - (* Sends a command and an integer and a decimal parameter to the *) - (* HP plotter. *) - (*------------------------------------------------------------------*) - - BEGIN (* putidcmd *) - handshake(18); - - puthp(cmd[1]); (* send command *) - puthp(cmd[2]); - - putinum(i); (* now the parameters *) - puthp(','); - putdnum(d); - puthp(';'); - END; (* putidcmd *) - - - - PROCEDURE putiicmd(cmd: cmdstrtype; - i1, - i2: INTEGER); - (*------------------------------------------------------------------*) - (* Sends a command and two integer parameters to the HP plotter. *) - (*------------------------------------------------------------------*) - - BEGIN (* putiicmd *) - handshake(16); - - puthp(cmd[1]); (* send command *) - puthp(cmd[2]); - - putinum(i1); (* now the parameters *) - puthp(','); - putinum(i2); - puthp(';'); - END; (* putiicmd *) - - - - PROCEDURE putiiiicmd(cmd: cmdstrtype; - i1, - i2, - i3, - i4: INTEGER); - (*------------------------------------------------------------------*) - (* Sends a command and four integer parameters to the HP plotter. *) - (*------------------------------------------------------------------*) - - BEGIN (* putiiiicmd *) - handshake(30); - - puthp(cmd[1]); (* send command *) - puthp(cmd[2]); - - putinum(i1); (* now the parameters *) - puthp(','); - putinum(i2); - puthp(','); - putinum(i3); - puthp(','); - putinum(i4); - puthp(';'); - END; (* putiiiicmd *) - - - - PROCEDURE inithp; - (*------------------------------------------------------------------*) - (* Sets up the HP plotter software handshake mode and the scaling. *) - (*------------------------------------------------------------------*) - - BEGIN (* inithp *) - puthpstr('IN; '); (* init the plotter *) - - puthp(chr(esccode)); (* shut off hardware handshake *) - puthpstr('.@;0: '); - - puthp(chr(esccode)); (* software handshake mode 1 *) - puthpstr('.H '); - putinum(maxsent); - puthpstr(';5;6: '); (* decimal equiv of enq and ack *) - - putiiiicmd('SC', 0, 10000, 0, 7200); (* 40'ths of mm. *) - END; (* inithp *) - - - - PROCEDURE penup; - (*------------------------------------------------------------------*) - (* Sets the 'penlifted' indicator. The command is sent to the *) - (* plotter only if necessary by 'drawto'. *) - (*------------------------------------------------------------------*) - - BEGIN (* penup *) - penlifted := TRUE; - END; (* penup *) - - - - PROCEDURE pendown; - (*------------------------------------------------------------------*) - (* Sets the 'penlifted' indicator. The command is sent to the *) - (* plotter only if necessary by 'drawto'. *) - (*------------------------------------------------------------------*) - - BEGIN (* pendown *) - penlifted := FALSE; - END; (* pendown *) - - - - PROCEDURE sethpplot(l: alinetype; - rptlen: REAL; - endsym: aendtype); - (*------------------------------------------------------------------*) - (* Sends the 'line type' command and sets the penup and pendown. *) - (*------------------------------------------------------------------*) - - VAR - linetynum: INTEGER; - - - BEGIN (* sethpplot *) - IF ((l = noline) AND (endsym = point)) OR (l <> noline) - THEN - BEGIN - IF l = solid - THEN - puthpstr('LT; ') (* set solid line or *) - ELSE - BEGIN - CASE l OF (* set pattern number *) - noline: linetynum := 0; - dotted: linetynum := 1; - dashed: linetynum := 2; - dotdashed: linetynum := 4; - dotdotdashed: linetynum := 6; - END; (* CASE l *) - putidcmd('LT', linetynum, rptlen * percent); - END; (* ELSE *) - pendown; (* and lower pen *) - END (* IF ((l... *) - ELSE - penup; (* otherwise raise pen *) - END; (* sethpplot *) - - - - PROCEDURE sethpstr(height, - width, - angle: REAL); - (*------------------------------------------------------------------*) - (* Uses the 'SI' command to set the character size and the 'DI' *) - (* command to set the string angle. *) - (*------------------------------------------------------------------*) - - BEGIN (* sethpstr *) - putddcmd('SI', width / 10.0, (* convert to cm. *) - height / 10.0); - putddcmd('DI', 100.0 * cos(angle / radian), (* run *) - 100.0 * sin(angle / radian)); (* rise *) - END; (* sethpstr *) - - - - PROCEDURE sethpwindow(left, - right: apointtype); - (*------------------------------------------------------------------*) - (* Sends the window size to the HP plotter. This uses absolute *) - (* (not scaled) HP plotter units. *) - (*------------------------------------------------------------------*) - - BEGIN (* sethpwindow *) - putiiiicmd('IW', round((left.x * xfactor) + absp1x), (* send to *) - round((left.y * yfactor) + absp1y), (* plotter *) - round((right.x * xfactor) + absp1x), - round((right.y * yfactor) + absp1y)); - END; (* sethpwindow *) - - - - FUNCTION isinwindow(pt: apointtype): BOOLEAN; - (*------------------------------------------------------------------*) - (* Returns TRUE if the 'pt' is within the window defined by *) - (* 'oldleft' and 'oldright'. *) - (*------------------------------------------------------------------*) - - BEGIN (* isinwindow *) - isinwindow := (pt.x <= oldright.x) AND (pt.y <= oldright.y) AND - (pt.x >= oldleft.x) AND (pt.y >= oldleft.y); - END; (* isinwindow *) - - - - PROCEDURE plot(dest: apointtype); - (*------------------------------------------------------------------*) - (* Plots a line from the present position to 'dest'. *) - (*------------------------------------------------------------------*) - - - - PROCEDURE drawto(dest: apointtype); - (*----------------------------------------------------------------*) - (* Moves the pen to 'dest' with the pen specified by 'penlifted'.*) - (*----------------------------------------------------------------*) - - BEGIN (* drawto *) - IF penlifted AND (NOT oldpenlifted) - THEN - puthpstr('PU; ') - ELSE IF (NOT penlifted) AND oldpenlifted - THEN - puthpstr('PD; '); - oldpenlifted := penlifted; - - putiicmd('PA', round(dest.x * xfactor), - round(dest.y * yfactor)); - oldpt := dest; - END; (* drawto *) - - - - PROCEDURE draw(what: aendtype); - (*----------------------------------------------------------------*) - (* Draws the endpoint symbol 'what' with size 'oldesize' *) - (* centered at the present position. *) - (*----------------------------------------------------------------*) - - VAR - origin, (* holds line endpoint *) - temp: apointtype; - - oldpenup: BOOLEAN; (* holds old penlifted *) - - - - PROCEDURE closed(initangle: REAL; - npoints: INTEGER); - (*--------------------------------------------------------------*) - (* Plots a polygon of size 'oldesize' with 'npoints' *) - (* corners starting at 'initangle' degrees clockwise from *) - (* vertical centered at 'origin'. *) - (*--------------------------------------------------------------*) - - VAR - i: INTEGER; (* corner counter *) - - angle: REAL; (* angle counter *) - - - BEGIN (* closed *) - FOR i := 0 to npoints DO - BEGIN - IF i = 0 - THEN - penup - ELSE IF penlifted - THEN - pendown; - angle := (initangle + i * (360.0 / npoints)) / radian; - temp.x := origin.x + oldesize * sin(angle); - temp.y := origin.y + oldesize * cos(angle); - drawto(temp); - END; (* FOR i ... *) - END; (* closed *) - - - - PROCEDURE open(initangle: REAL); - (*--------------------------------------------------------------*) - (* Plots a cross of size 'oldesize' with one axis at *) - (* 'initangle' clockwise from vertical centered at 'origin'. *) - (*--------------------------------------------------------------*) - - VAR - i, (* loop counters *) - j: INTEGER; - - angle, (* angle of a line segment *) - stangle: REAL; (* start angle of a line segment *) - - - BEGIN (* open *) - FOR j := 0 TO 1 DO - BEGIN - stangle := initangle + j * 90.0; - FOR i := 0 TO 1 DO - BEGIN - IF i = 0 - THEN - penup - ELSE - pendown; - angle := (stangle + i * 180.0) / radian; - temp.x := origin.x + oldesize * sin(angle); - temp.y := origin.y + oldesize * cos(angle); - drawto(temp); - END; (* FOR i ... *) - END; (* FOR j ... *) - END; (* open *) - - - - BEGIN (* draw *) - IF what IN [square, triangle, diamond, circle, cross, ecks] - THEN - BEGIN - origin := oldpt; (* save endpoint *) - oldpenup := penlifted; (* and pen status *) - IF oldline <> solid (* set it to solid *) - THEN - sethpplot(solid, 0.0, noend); - CASE what OF - square: closed(45.0, 4); - triangle: closed(0.0, 3); - diamond: closed(0.0, 4); - circle: closed(0.0, 10); - cross: open(0.0); - ecks: open(45.0); - END; (* CASE what *) - - penup; (* return to endpoint *) - drawto(origin); - - IF oldline <> solid (* restore line charact's *) - THEN - sethpplot(oldline, oldrptlength, oldend); - END; (* IF what... *) - END; (* draw *) - - - - BEGIN (* plot *) - drawto(dest); - draw(oldend); - END; (* plot *) - - - - FUNCTION abadcall: BOOLEAN; - (*------------------------------------------------------------------*) - (* Returns TRUE if something is wrong with a procedure call. Not *) - (* implemented. *) - (*------------------------------------------------------------------*) - - BEGIN (* abadcall *) - abadcall := FALSE; - END; (* abadcall *) - - - - PROCEDURE adefault; - (*------------------------------------------------------------------*) - (* Sets all globals to their default values. *) - (*------------------------------------------------------------------*) - - BEGIN (* adefault *) - oldline := noline; (* simple line *) - oldrptlength := 5.0; - oldesize := 3.0; - oldend := noend; - sethpplot(oldline, oldrptlength, oldend); - - oldleft.x := minx; (* window size to full screen *) - oldleft.y := miny; - oldright.x := maxx; - oldright.y := maxy; - sethpwindow(oldleft, oldright); - - sethpstr(2.70, 1.875, 0.0); (* default character size *) - END; (* adefault *) - - - - PROCEDURE agraph; - (*------------------------------------------------------------------*) - (*------------------------------------------------------------------*) - - BEGIN (* agraph *) - END; (* agraph *) - - - - PROCEDURE ainit; - (*------------------------------------------------------------------*) - (* Initializes the I/O to the HP plotter, and *) - (* sets all parameters to their default values, and places the pen *) - (* in the lower left-hand corner. *) - (*------------------------------------------------------------------*) - - BEGIN (* ainit *) - inithp; - adefault; - agraph; - oldpenlifted := TRUE; - oldpt.x := minx; - oldpt.y := miny; - plot(oldpt); - numsent := 0; - END; (* ainit *) - - - - PROCEDURE amakecopy; - (*------------------------------------------------------------------*) - (* This is not implemented - it could be used to indicate for *) - (* the paper to be changed by sending out DP;, then OS;'s till bit *) - (* 2 returned was a 1, then a DC;. This would turn on the 'enter' *) - (* light on the plotter, wait until 'enter' was pushed (presumably *) - (* after the paper had been changed) by the operator, and then *) - (* extinguish the light and return. *) - (* See the HP plotter manual for more details. *) - (*------------------------------------------------------------------*) - - BEGIN (* amakecopy *) - END; (* amakecopy *) - - - - PROCEDURE aplot(endpoint: apointtype); - (*------------------------------------------------------------------*) - (* Plots to 'endpoint' using line type 'oldline' and end type *) - (* 'oldend'. *) - (*------------------------------------------------------------------*) - - BEGIN (* aplot *) - plot(endpoint); - END; (* aplot *) - - - - PROCEDURE asetplot(line: alinetype; - repeatlength, - endsize: REAL; - endsymbol: aendtype); - (*------------------------------------------------------------------*) - (* Sets the characteristics of the line(s) to be plotted next. *) - (*------------------------------------------------------------------*) - - BEGIN (* asetplot *) - sethpplot(line, repeatlength, endsymbol); - - oldline := line; (* save the values *) - oldrptlength := repeatlength; - oldesize := endsize; - oldend := endsymbol; - END; (* asetplot *) - - - - PROCEDURE asetstr(charheight, - charwidth, - charangle, - charspace, - strangle: REAL); - (*------------------------------------------------------------------*) - (* Sets the characteristics of the next string(s) to be plotted. *) - (* Doesn't implement the charspace or charangle settings since it *) - (* uses the standard plotter values. *) - (*------------------------------------------------------------------*) - - BEGIN (* asetstr *) - sethpstr(charheight, charwidth, strangle); - END; (* asetstr *) - - - - PROCEDURE asetwindow(lowerleft, - upperright: apointtype); - (*------------------------------------------------------------------*) - (* Sets the window size. Nothing will appear outside this window. *) - (*------------------------------------------------------------------*) - - BEGIN (* asetwindow *) - oldleft := lowerleft; (* save the window value *) - oldright := upperright; - IF lowerleft.x < minx (* make sure it's valid *) - THEN - oldleft.x := minx; - IF lowerleft.y < miny - THEN - oldleft.y := miny; - IF upperright.x > maxx - THEN - upperright.x := maxx; - IF upperright.y > maxy - THEN - upperright.y := maxy; - - sethpwindow(oldleft, oldright); - END; (* asetwindow *) - - - - PROCEDURE asize(VAR size: apointtype); - (*------------------------------------------------------------------*) - (* Returns the size of the display in mm. *) - (*------------------------------------------------------------------*) - - BEGIN (* asize *) - size.x := maxx - minx; - size.y := maxy - miny; - END; (* asize *) - - - - PROCEDURE astr(str: astringtype); - (*------------------------------------------------------------------*) - (* Writes the null-terminated string 'str' on the screen starting *) - (* at the current location (taken as the lower left corner of the *) - (* first character) and proceeding at 'strangle'. The *) - (* character angle, height, width and spacing is 'charangle', *) - (* 'charheight', 'charwidth' and 'charspace'. *) - (* *) - (* In this implementation, the HP 7225A mode of text writing is *) - (* used, so the standard spacing and character rotation (same as *) - (* line rotation) are used. *) - (*------------------------------------------------------------------*) - - VAR - index: INTEGER; - - - BEGIN (* astr *) - handshake(136); (* make sure there's enough room *) - puthp('L'); (* send start of LB command *) - puthp('B'); - - index := 1; (* put out characters *) - WHILE ord(str[index]) <> nulcode DO - BEGIN - puthp(str[index]); - index := index + 1; - END; (* WHILE str... *) - - puthp(chr(etxcode)); (* and end of string code *) - puthp(';'); - END; (* astr *) - - - - PROCEDURE atext; - (*------------------------------------------------------------------*) - (* Sets the display to the text mode. *) - (*------------------------------------------------------------------*) - - BEGIN (* atext *) - END; (* atext *) - - - - PROCEDURE awhere(VAR where: apointtype; - VAR inwindow: BOOLEAN); - (*------------------------------------------------------------------*) - (* Returns the current location and whether it's inside the *) - (* window. *) - (*------------------------------------------------------------------*) - - BEGIN (* awhere *) - where := oldpt; - inwindow := isinwindow(oldpt); - END; (* awhere *) -modend. - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/LOCK.PAS b/software/CPM/CPM19_MTPUG_07/LOCK.PAS deleted file mode 100644 index 2d7a92e..0000000 --- a/software/CPM/CPM19_MTPUG_07/LOCK.PAS +++ /dev/null @@ -1,76 +0,0 @@ -MODULE KCOL; -{********************************************************************* - * LOCK * - * Date Author * - * 13-October-82 Sue Arnold * - * * - * This routine will lock out other programs from using your record. * - * To use it, you must pass the file descriptor and the File_ID that * - * was returned by "SHARE" when you opened the file in unlock mode. * - * * - * An assembly routine (alock) will be called to actually lock out * - * the record after this routine moves the file_ID to the sector * - * buffer and sets the current DMA. * - * * - * This program requires that the rec# of the record to be locked be * - * in the FCB. To get it there, please access the record before * - * calling this routine via a "SEEKREAD". (or something similiar). * - *********************************************************************} - - - {**************************************************************** - * follows is the format for the Pascal MT+ file information * - * block (FIB). It was modified for Ver 5.5 to include file * - * option type "fauxio". * - ****************************************************************} -TYPE - opttype = (notopen,fwrite,frdwr,frandom,fconio,ftrmio,flstout,fauxio); - buftype = PACKED ARRAY [0..127] OF CHAR; - - FIB= - RECORD - fname : STRING[16]; { d:filename.ext } - FCB : PACKED ARRAY [0..34] OF CHAR; { CP/M FILE CONTROL BLOCK } - buflen : INTEGER; { size of fbuffer } - bufidx : INTEGER; { current index into fbuffer } - option : opttype; - IOsize : INTEGER; { size of next transfer } - feoln : BOOLEAN; { TRUE if text file at end-of-line } - feof : BOOLEAN; { TRUE if at end-of-file } - fbufadr: WORD; { pointer to fbuffer } - fsecinx: 0..128; { index into fsector <+1 for overflow> } - ftext : BOOLEAN; { TRUE if this is a text file! } - nosectrs:BOOLEAN; { TRUE if no more disk room available } - fsector: buftype; { 1 sector buffer for CP/M } - fbuffer: PACKED ARRAY [0..0 ] OF CHAR; - END; - - - {**************************************************************** - * Here are bunches of external procedure declarations. * - ****************************************************************} -EXTERNAL PROCEDURE setDMA (VAR sector_buffer: buftype); - -EXTERNAL PROCEDURE alock (VAR ufile: FIB; - VAR lck_err: INTEGER); - -{**************************************************************** - * Procedure LOCK starts here: * - ****************************************************************} - -PROCEDURE lock (VAR ufile : FIB; - file_ID : WORD; - VAR lck_err : INTEGER); - -BEGIN - {**************************************************************** - * First, put the file_ID number in the file sector buffer: * - * Then, call "alock" to lock the record. * - ****************************************************************} - MOVE (file_ID, ufile.fsector[0], 2); - setDMA( ufile.fsector ); - alock ( ufile, lck_err); - END; {procedure LOCK} - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/MYLIB.ERL b/software/CPM/CPM19_MTPUG_07/MYLIB.ERL deleted file mode 100644 index 5c3de0e..0000000 Binary files a/software/CPM/CPM19_MTPUG_07/MYLIB.ERL and /dev/null differ diff --git a/software/CPM/CPM19_MTPUG_07/PRETTY.COM b/software/CPM/CPM19_MTPUG_07/PRETTY.COM deleted file mode 100644 index 9cf0ea2..0000000 Binary files a/software/CPM/CPM19_MTPUG_07/PRETTY.COM and /dev/null differ diff --git a/software/CPM/CPM19_MTPUG_07/PRETTY.DOC b/software/CPM/CPM19_MTPUG_07/PRETTY.DOC deleted file mode 100644 index cdccacf..0000000 --- a/software/CPM/CPM19_MTPUG_07/PRETTY.DOC +++ /dev/null @@ -1,22 +0,0 @@ - PRETTY is a program for capitalizing reserved words in a pascal -source file. I normally type everthing in in lower case. - - I hope to eventually make this the basis of a complete -'pretty-printing' program which will indent properly etc. If anyone -has one, I would love to hear of it. - - My name and address are: - - J.A. Koehler - 2 Sullivan St. - Saskatoon, SK, S7H-3G8 - - Basically the program searches through the source file looking -for reserved words and capitalizing them. It writes them out to a file -with the same name but with a 'type' of TMP. Thus, to operate on a -Pascal MT+ source file called DUMMY.SRC, you would just type: - - PRETTY DUMMY - -The program would operate on DUMMY.SRC and would write DUMMY.TMP. - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/PRETTY.SRC b/software/CPM/CPM19_MTPUG_07/PRETTY.SRC deleted file mode 100644 index ff104aa..0000000 Binary files a/software/CPM/CPM19_MTPUG_07/PRETTY.SRC and /dev/null differ diff --git a/software/CPM/CPM19_MTPUG_07/PRMAC.COM b/software/CPM/CPM19_MTPUG_07/PRMAC.COM deleted file mode 100644 index 0037741..0000000 Binary files a/software/CPM/CPM19_MTPUG_07/PRMAC.COM and /dev/null differ diff --git a/software/CPM/CPM19_MTPUG_07/PRMAC.DOC b/software/CPM/CPM19_MTPUG_07/PRMAC.DOC deleted file mode 100644 index 0d4ef9b..0000000 --- a/software/CPM/CPM19_MTPUG_07/PRMAC.DOC +++ /dev/null @@ -1,22 +0,0 @@ - PRMAC is a program for typing out the .PRN and .SYM files -produced by Digital Research's MAC assembler. The only difference -between this and the one in the manual for MAC (other than the -fact that theirs is in assembly language) is that it paginates -the output etc. - - It is invoked by typing: - - PRMAC DUMMY LISTING - -where DUMMY is the basename of the file to be listed and -where LISTING is the name of the desired output file - usually this -is just the listing 'device' - LST: - -The program will then read through DUMMY.PRN, send it to the output -file, and then do the same for DUMMY.SYM. - -NOTE ******* - - After doing the above, the program will ERASE both the source -files! - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/PRMAC.SRC b/software/CPM/CPM19_MTPUG_07/PRMAC.SRC deleted file mode 100644 index 6ce1866..0000000 Binary files a/software/CPM/CPM19_MTPUG_07/PRMAC.SRC and /dev/null differ diff --git a/software/CPM/CPM19_MTPUG_07/SETDMA.Z80 b/software/CPM/CPM19_MTPUG_07/SETDMA.Z80 deleted file mode 100644 index 4319166..0000000 --- a/software/CPM/CPM19_MTPUG_07/SETDMA.Z80 +++ /dev/null @@ -1,40 +0,0 @@ -TITLE DMAset -; -; 9/22/82 Sue Arnold -; -; This is an assembly program that will set the current "DMA" to the -; "fsector" field in the FIB, so that the system may lockout a record. -; It expects "buftype" to be of the type: PACKED ARRAY [0..127] OF CHAR; -; -; CALLING PROCEDURE= -; -; setDMA (VAR sector_buffer: buftype); (pointer to the file FCB) -; -; This routine uses XDOS function number 1Ah for to set the DMA. -; - - .Z80 -; -BDOSJP EQU 5 ; Use this to call XDOS -; -; - PUBLIC setDMA - CSEG -; -; -setDMA: - POP HL ; HL = Pascal Return Address - EX (SP), HL ; HL = The addr of the CP/M sector buffer - ; (top of stack now has the Pascal rtn addr) - EX DE, HL ; DE = The addr of the CP/M sector buffer - ; HL = Garbage - LD C, 1AH ; C = Set DMA BDOS function number - PUSH DE ; Save the addr of the CP/M sector buffer - PUSH HL ; Save the error code addr - CALL BDOSJP ; Set the current DMA - POP HL ; Restore garbage - POP DE ; Restore the addr of the CP/M sector buffer - RET ; Else, Return to calling routine - - END setDMA - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/SHARE.PAS b/software/CPM/CPM19_MTPUG_07/SHARE.PAS deleted file mode 100644 index 91976c8..0000000 --- a/software/CPM/CPM19_MTPUG_07/SHARE.PAS +++ /dev/null @@ -1,50 +0,0 @@ -MODULE erahs; -{********************************************************************* - * SHARE * - * Date Author * - * 04-October-82 Sue Arnold * - * * - * This is a super-duper procedure that will open the file of your * - * choice in UNLOCKED mode! Just send it the file descriptor, the * - * file name, and it will open the file and return the file ID * - * number that you need to have in order to lock and unlock * - * records. * - *********************************************************************} - - - {**************************************************************** - * follows is the format for the Pascal MT+ file information * - * block (FIB). It was modified for Ver 5.5 to include file * - * option type "fauxio". * - ****************************************************************} -TYPE - string15 = STRING[15]; - - dum_rec = - RECORD - dumb : BYTE; - END; - dum_type = FILE OF dum_rec; - -VAR - bufsize : INTEGER; {default value = 1} - -EXTERNAL PROCEDURE uset (VAR ufile: dum_type; - bufsize: INTEGER; - VAR file_ID: INTEGER); - -{**************************************************************** - * Procedure SHARE starts here: * - ****************************************************************} - -PROCEDURE share (VAR ufile : dum_type; - VAR filename : string15; - VAR file_ID : INTEGER); - -BEGIN - ASSIGN(ufile, filename); - uset (ufile, bufsize, file_ID); -END; { procedure share } - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/SHAREFIL.DOC b/software/CPM/CPM19_MTPUG_07/SHAREFIL.DOC deleted file mode 100644 index 6172c97..0000000 --- a/software/CPM/CPM19_MTPUG_07/SHAREFIL.DOC +++ /dev/null @@ -1,190 +0,0 @@ - - - -     PASCAL/MT«   INTERFACÅ   TÏ  MP/Í II'Ó   -     FILÅ  SHARINÇ   FUNCTIONS - - - - -     Thå  abilitù  tï updatå shareä datá while maintaiîing  -    data integrity is a unique feature of MP/M II. - -     The current version of Pascal/MT+, having been designed -    foò á singlå-useò environment¬  lackó thå facilitieó tï  takå -    advantagå  oæ  thå filå integritù mechanisimó requireä  iî  á -    multi-user environment. - -     SHAREFIÌ  ió  aî applicatioî prograí usinç  á  Pascaì -    interfacå  tï  assemblù modules provideä bù  Suå  Arnolä  oæ -    Centauruó  Software®  Theså  moduleó  togetheò  providå  filå -    sharinç   anä   recorä   locking/unlockinç   capabilitù   foò -    Pascal/Mt+ ver. 5.5 running under MP/M II. - -     Thå firsô useò oæ SHAREFIÌ shoulä creatå á smalì  texô -    filå  oæ nameó anä addresses®  Subsequenô useró caî opeî  thå -    samå  filå anä attempô accesó oæ thå samå recordó foò reaä oò -    write®  Iæ  thå  recorä haó beeî lockeä bù á  previouó  writå -    requesô thå currenô writå requesô wilì bå denieä anä aî erroò -    codå displayed. - -     Onå  drawbacë  oæ extendinç á filå openeä iî  unlockeä -    modå  - aó  occuró iî thió examplå - ió  thaô  thå  operatinç -    systeí  musô allocatå á fulì blocë oæ disë spacå aô thå firsô -    writå  tï aî unallocateä record®  Thå effecô ió, á reaä tï  á -    recorä  withiî  the  blocë, thaô haó noô beeî  writteî, wilì -    successfullù returî uninitializeä data®  Aî applicatioî thaô -    useó  thió schemå shoulä maintaiî á headeò tï thå  filå  thaô -    keepó tracë oæ valiä records. - -     Linkinç  SHAREFIÌ  ió acomplisheä witè  thå  followinç -    command. - -    0A>LINKMT SHAREFIL,SHARELIB,RANDOMIO,PASLIB/S - - -    Digitaì   Researcè   disclaimó  anù  expresseä   oò   implieä -    responsibilitù  foò  thå  effectó oæ thió  softwarå  oî  youò -    application®  Thå  externaì moduleó useä iî thió  applicatioî -    arå  madå  availablå  tï DRÉ anä ouò customeró  bù  Centauruó -    Software®  Iô ió thå intenô oæ thå authoò thaô theså  moduleó -    be regarded as public domain. - - - -    Daniel Erickson/Dick Lovelace Digital Research 11/11/82 Š - - - - (1) - - - - - - - - MODULE LIST - =========== - - -SHARE.PAS -========= -   Thió ió thå Pascaì procedurå thaô ió useä bù thå callinç routinå tï opeî -   a file in the shared access mode. The calling procedure is: - -    SHARE (VAR ufile: file_descriptor; -    uname: string15; -    VAR file_ID: INTEGER); - -   All parameters are passed except file_ID. - - -USET.PAS (called by SHARE) -======== -   Thió ió mù versioî oæ "RESET"®  Iô ió basicallù á documenteä versioî oæ -   reseô witè thå followinç exceptionsº  (1© Iæ filå optioî ½ FWRITE¬  theî -   thå f5§ biô ió seô beforå closinç thå file» (2© Thå f5§ attributå biô ió -   seô  beforå  thå filå ió opened»  (3© "@BDOS¢ functioî waó  replaceä  bù -   assemblù routinå "UOPEN"® - -    USET (VAR ufile: FIB; -    bufsize: INTEGER; -    VAR file_ID: INTEGER); - -   É don'ô kno÷ whetheò oò noô É neeä bufsizå aó thå seconä parameter¬  buô -   that'ó thå waù thå originaì reseô looks®  Eventually¬ file_IÄ shoulä bå -   type "WORD", and not "INTEGER". - - -UOPEN.PAS (called by USET) -======== -   Thió  ió  jusô aî assemblù routinå thaô actuallù calló thå BDOÓ tï  opeî -   the file. - -    uopen (VAR ufile: FIB; -    VAR result: INTEGER); - - -LOCK.PAS Š======== -   Thió ió thå Pascaì procedurå thaô ió useä bù thå callinç routinå tï locë -   á recorä foò á filå thaô haó beeî openeä iî shareä accesó mode®  Pleaså -   seå thå prograí headeò foò furtheò documentation. - -    LOCK (VAR ufile: FIB; -    file_ID: WORD; -   VAR lck_err: INTEGER); - -   The file_ID is the same one as that returned by "SHARE". - - - - - - (2) - - - - - - - - - -ALOCK.Z80 (called by LOCK) -========= -   Thió  ió jusô aî assemblù routinå thaô actuallù calló thå BDOÓ tï  locë -   thå  recorä thå file¬  iô assumeó thaô thå currenô DMÁ haó alreadù  beeî -   set. - -    alock (VAR ufile: FIB; -    VAR lck_err: INTEGER); - - -SETDMA.Z80 (called by LOCK and UNLOCK) -=========== -   Thió  ió  yeô  anotheò assemblù routinå thaô calló thå BDOÓ tï  seô  thå -   current DMA (which is passed). - -    setdma (VAR sector_buffer: buftype); - -   Whereº  buftypå ½ PACKEÄ ARRAÙ [0..127Ý OÆ CHAR¬  anä thå sector_buffeò -   is the "fsector" field of the FIB. - - -UNLOCK.PAS -========== -   Thió  ió  thå Pascaì procedurå thaô ió useä bù thå  callinç  routinå  tï -   unlocë á recorä thaô haó beeî writteî tï iî lockeä mode®  Pleaså seå thå -   prograí headeò foò furtheò documentation. - -    UNLOCK (VAR ufile: FIB; -    file_ID: WORD; -   VAR lck_err: INTEGER); Š -   The file_ID is the same one as that returned by "SHARE". - - -AUNLCK.Z80 (called by UNLOCK) -========== -   Thió ió jusô aî assemblù routinå thaô actuallù calló thå BDOÓ tï unlocë -   thå  recorä thå file¬  iô assumeó thaô thå currenô DMÁ haó alreadù  beeî -   set. - -    áunlck (VAÒ ufileº FIB; -    VAR lck_err: INTEGER); - - - SHARELIB.ERL  - ===========½ - Iî  ordeò  tï  makå iô easieò tï linë togetheò, wå havå  provideä  thió - library module containing all of the other modules listed above. - - - - - - - - (3) - -      \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/SHAREFIL.TST b/software/CPM/CPM19_MTPUG_07/SHAREFIL.TST deleted file mode 100644 index 341e57f..0000000 --- a/software/CPM/CPM19_MTPUG_07/SHAREFIL.TST +++ /dev/null @@ -1,163 +0,0 @@ - - - - -PROGRAM SHAREFIL; - -TYPE - PERSON = RECORD - NAME : STRING; - ADDRESS : STRING; - END; - FYLE = FILE OF PERSON; - -VAR - BF : FYLE; - S,NAME : STRING; - BUFFSIZE,ID,RN,ERR_CD : INTEGER; - CREATE,REED : BOOLEAN; - CH : CHAR; - FID : WORD; - - - EXTERNAL PROCEDURE SHARE(VAR UFILE : FYLE; UNAME : STRING; - VAR FILE_ID : INTEGER); - EXTERNAL PROCEDURE @HLT; - EXTERNAL PROCEDURE USET (VAR UFILE : FYLE; BUFFSIZE : INTEGER; - VAR FILE_ID : INTEGER); - EXTERNAL PROCEDURE LOCK (VAR UFILE : FYLE; FILE_ID : WORD; - VAR LCK_ERR : INTEGER); - EXTERNAL PROCEDURE UNLOCK (VAR UFILE : FYLE; FILE_ID : WORD; - VAR ERR_CD : INTEGER); - - -PROCEDURE HALT; -BEGIN - CLOSE(BF,FID); - @HLT -END; - - -PROCEDURE ERR_CHK (VAR ERR_CD : INTEGER); -VAR IORSLT : INTEGER; -BEGIN - IORSLT := IORESULT; - IF ERR_CD <> 0 - THEN - BEGIN - WRITELN ('UNSUCCESSFUL LOCK/UNLOCK, ERROR CODE = ',ERR_CD); - ERR_CD := 0; - ACCESS_RECS; - EXIT - END; - IF IORSLT <> 0 - THEN - BEGIN - WRITELN ('UNSUCCESSFUL FILE I/O, IORESULT = ',IORSLT); - O_C_FILE; - EXIT - END; -END; - - -PROCEDURE READ_RECS; -BEGIN - WRITE('RECORD NUMBER ? '); - READLN(RN); - SEEKREAD(BF,RN); - IF REED - THEN BEGIN - ERR_CHK (ERR_CD); - WRITELN (BF^.NAME,'/',BF^.ADDRESS) - END; -END; - - -PROCEDURE WRITE_RECS; -BEGIN - READ_RECS; - FID := WRD(ID); - IF CREATE = FALSE - THEN BEGIN - LOCK (BF,FID,ERR_CD); - ERR_CHK (ERR_CD) - END; - WRITE('NAME?'); - READLN(S); - BF^.NAME := S; - WRITE('ADDRESS?'); - READLN(S); - BF^.ADDRESS := S; - SEEKWRITE(BF,RN); - UNLOCK (BF,FID,ERR_CD); - ERR_CHK (ERR_CD) -END; - - -PROCEDURE ACCESS_RECS; -BEGIN - REPEAT - WRITE ('R)EAD,W)RITE OR Q)UIT? '); - READ(CH); - WRITELN; - CASE CH OF - 'R','r' : BEGIN - REED := TRUE; - READ_RECS - END; - 'W','w' : BEGIN - REED := FALSE; - WRITE_RECS - END; - 'Q','q' : HALT - - ELSE WRITELN('ENTER R, W OR Q ONLY') - END; - UNTIL FALSE; -END; - - -PROCEDURE OPEN_FILE; -BEGIN - WRITE ('FILE NAME? '); - READLN (NAME); - SHARE (BF,NAME,ID); - ERR_CHK (ERR_CD); -END; - - -PROCEDURE CREATE_FILE; -BEGIN - WRITE ('FILE NAME? '); - READLN (NAME); - ASSIGN (BF,NAME); - REWRITE (BF); - CLOSE (BF,FID); - SHARE (BF,NAME,ID); - ERR_CHK (ERR_CD); - CREATE := TRUE -END; - -PROCEDURE O_C_FILE; -BEGIN - CREATE := FALSE; - REPEAT - WRITE ('C)REATE OR O)PEN? '); - READLN (CH); - WRITELN; - IF CH = 'O' - THEN OPEN_FILE - ELSE IF CH = 'C' - THEN CREATE_FILE - ELSE WRITELN ('TYPE "C" OR "O" ONLY') - UNTIL (CH = 'O') OR (CH = 'C'); - ACCESS_RECS -END; - - -BEGIN (* MAINLINE *) - ERR_CD := 0; - O_C_FILE -END. - - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/SHARELIB.ERL b/software/CPM/CPM19_MTPUG_07/SHARELIB.ERL deleted file mode 100644 index b8597ed..0000000 Binary files a/software/CPM/CPM19_MTPUG_07/SHARELIB.ERL and /dev/null differ diff --git a/software/CPM/CPM19_MTPUG_07/TYPESET.DOC b/software/CPM/CPM19_MTPUG_07/TYPESET.DOC deleted file mode 100644 index a281b5d..0000000 --- a/software/CPM/CPM19_MTPUG_07/TYPESET.DOC +++ /dev/null @@ -1,184 +0,0 @@ -.lh 10 -PROGRAM TYPESET - CONVERSION OF WORDSTAR TEXT TO OTHER FORMATS - -PER STANGELAND -4230 SAND -NORWAY -1982/11/27 - -Prograí  TYPESET‚ convertó á texô writteî bù WORDSTAÒ tï á  formaô -acceptable to type setting equipment. - - -Operating instructions - -TYPESET.SRC is the program code -TYPESET.COM is the version you run -TYPESET.PRM contains the parameter list. - -Any CP/M system with at least one disk drive can be used. -TYPESET.COM and TYPESET.PRM must be on the same disk. -Write TYPESET, and press RETURN -Thå  prograí  askó  foò  youò texô file®  Assurå  thaô  therå  ió -sufficienô  spacå oî thaô disë foò thå ne÷ version¬  anä givå  iô -the drive prefix and file name. - -Thå filå texô ió displayeä oî youò terminaì aó iô ió  read®  Non- -printable characters are substituted with ? - -Thå  prograí stopó executioî aô undefineó doô commands¬  sï  thaô -you may give a suitable number code at this point. - -Youò  ne÷  filå ió writteî iî chunkó oæ 4K®  Iô ió  calleä  .SET - - -WHAT DOES THE PROGRAM DO? - -Youò  WORDSTAÒ  texô ió read¬  characteò  bù  character®  Speciaì -wordstaò  featureó arå exchangeä witè speciaì symbols.Alì symboló -tï  bå  entereä  iî  thå  ne÷  texô  arå  reaä  froí  á  separatå -file:TYPESET.PRM®  Theså  parameteró caî bå changeä aô  will¬  tï -suiô  differenô typesetteò equipment®  Equippeä witè thå  correcô -parameters¬  thió  prograí  maù  alsï bå  usefuì  foò  convertinç -WORDSTAÒ textó tï á formaô accepteä bù otheò texô editors. - ŠThå olä filå ió lefô unchanged® Thå ne÷ filå witè suffiø .SEÔ haó -the following characteristics: - -*Onlù  onå blanë (oò otheò worä delimiteò oæ youò choice© betweeî - eacè word -*Additionaì whitespacå - blanë lineó anä characters¬  linå shiftó - withiî paragraphs- arå removed -*A special symbol marks end of every paragraph -*Headings¬  subtitleó  anä quotationó arå markeä aô beginninç anä - end -*Other features in the WORDSTAR text are standardized to ASCII. - -Thå  distributeä  versioî  oæ TYPESET.COÍ requireó á  filå  nameä -TYPESET.PRÍ  witè 2± parameteró iî it®  Theså parameteró arå  puô -intï thå ne÷ filå insteaä oæ thå correspondinç WORDSTAÒ symboì iî -thió list: - -.cp 10 -CONVERSION CODES FROM WS TO TYPESETTER SYMBOLS - -No  Doô commandó én WS- fiìe TYPESET.PRM - for LINOTRON 202N - --  .cð ø (conditional page shift© on-linå choice -1  .pá (new page) Bell c1> -2  .lè 1° (line height 1 1/2) ON: Bell c2> - OFF: Bell c5> -3  .lè ¸ (narrow lines) Bell c3> -´ .lè 1² (double spaced lines) Belì c4> -    After .lh 8: Bell c5> -________________________________________________________________ -.cp 20 Š   ASCII-code -No Heø dec. Function: TYPESET.PRM -    --  0¸ 0¸ BÓ Backspacå removed - -8  0² 0² Boldface ^Ð Â ON: Bell c¸> -9   OFF: Bell c9> - -10 1³ 1¹ underline on/off ^Ð Ó ON: Bell c10¾ -11 OFF: Bell c11> - -12 1´ 2° superscript on/off ^Ð T ON: 0· 3ã 75 32 hex -13 OFF: Bell c13> - -14 22 34 " quote symbol ON: 02 hex -15 OFF: 01 hex - -1· 1Å 3° sofô hypheî (noô printeä bù WS© À (means:removed© -17 1Æ 3± soft hyphen at end-of-line @ (means:removed) -    -18 0F 1µ non- breaë spacå ON: Bell c 15> - OFF:Bell c 15> - -19 8D SOFTLINÅ line shift within if only delimiter -    a paragraph between two words: 20 hex -    Else:removed. - -20 0D 1³ CÒ - new paragraph 1¶ 0³ 5E hex -    --  0á 1° LÆ (line feed -follows CR) removed -    -2± 0¹ 0¹  TAB 20 hex -______________________________________________________________________ -"Belì"  in this table means the character 07 hex. -________________________________________________________________ - -Thå  parameteró  giveî  iî  thió tablå  arå  thå  oneó  founä  iî -TYPESET.PRÍ  oî  thå  distributioî disk®  Theù  suiô  mù  printeò -contacô  anä  hió  LINOTROÎ 202Î prettù well®  Buô  theù  maù  bå -changeä  tï  anù  otheò symbol¬  oò  sequencå  oæ  symbols®  Eacè -sequencå oæ symboló iî TYPESET.PRÍ ió terminateä bù á CR-LF® Thió -meanó thaô thå CR-LÆ symboì itselæ caî noô bå á parameter®  Iô ió -representeä  bù  thå  symboì '$§  (2´  hex)¬  whicè  thå  prograí -interpretó aó á standarä end-of-paragrapè symbol(0ä 0á hex) Š -Thå  sigî  '@§  (4°  hex© iî TYPESET.PRÍ meanó  removaì  oæ  thaô -Wordstar feature. - -Parameteò  no®  6,·  anä  1¶ arå aô  disposaì  wheî  runninç  thå -program®  Doô  commandó thaô maù havå differenô meaninç accordinç -tï thå context¬  havå nï pre-determineä conversioî code® Exampleº -Iô thå prograí findó á '.cð 10§ symboì iî thå WORDSTAÒ  file¬  iô -wilì givå á BELÌ sigî tï thå terminal¬  anä requesô á numbeò froí -thå user® ° meanó thaô thió doô commanä shoulä bå ignored® Iæ thå -"conditionaì  page"- commanä  aô  thió spoô meanó  thaô  á  tablå -startó here¬  thå useò maù enteò symboì 6¬  anä telì thå typeset -tinç firí thaô symboì ¶ meanó starô oæ tables. - -PROGRAM CHANGES - -Iæ  you'ä  likå  tï adä tï thå lisô oæ Wordstaò  featureó  tï  bå -converted¬  you'ä  havå  tï compilå á ne÷ versioî oæ thå  TYPESEÔ -program® Exampleº You'ä likå tï changå alì {,ü anä ý tï somethinç -else® Iô requireó thå followinç changes: - -in the sequence CASE ord(ch) OF (*in procedure convert- line 257 *) - -you add: - -'{': Enter(22); -'|': Enter(23); -'}': Enter(24); - -CONSÔ no_of_codeó ½ 21» (Line 4© is changed to - -CONST no_of_codes = 24; (*three extra codes for {,|,}*) - -anä  thå  filå  TYPESET.PRÍ  ió  giveî  threå  additionaì  lines¬ -containing the symbols you'd like to have instead of {,| and }. - - -IS THE FINAL TEXT READY FOR PRINT? - -Somå finaì editinç bù thå typesettinç firí wilì bå necessary® Thå -codeó giveî bù thió prograí arå intermediate¬ anä arå switcheä tï -codeó  whicè  indicatå  characteò  fonts®   Pagå  sizå  anä  pagå -numberinç ió noô carrieä oveò froí thå WORDSTAÒ text® Theså finaì -toucheó  concerninç  lay-ouô  arå betteò lefô tï  thå  typesetteò Šprofessionals®  If¬ however¬ thå uså oæ underlininç anä differenô -linå  heightó  iî youò texô ió inconsistent¬  you'ä havå  tï  paù -extra foò re-editing® Somå advice: - -Agreå  witè youò typesetteò contacô firsô oî suitablå parameters® -Make sure that he can read your disk or cassette format. - -Start the text with a .lh 10 - this is interpreted as ordinary -line height - -use .lh 8 for quotations -use .pa for new chapters -Use underlining and boldface for sub-headings - -NON-COPYRIGHT NOTICE - -Thió  prograí ió aô disposaì foò non-commerciaì uså  bù  writers® -Your comments are welcome. - -Anù  publisheò oò printeò firí thaô consideró takinç thå  prograí -intï regulaò uså ió requesteä tï contacô må aô thå addresó above® -É mighô selì theí aî updateä oò custom-builô version® -  \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/TYPESET.PRM b/software/CPM/CPM19_MTPUG_07/TYPESET.PRM deleted file mode 100644 index 82d8d04..0000000 Binary files a/software/CPM/CPM19_MTPUG_07/TYPESET.PRM and /dev/null differ diff --git a/software/CPM/CPM19_MTPUG_07/TYPESET.SRC b/software/CPM/CPM19_MTPUG_07/TYPESET.SRC deleted file mode 100644 index 84e6baa..0000000 --- a/software/CPM/CPM19_MTPUG_07/TYPESET.SRC +++ /dev/null @@ -1,348 +0,0 @@ -PROGRAM TYPESET; -(*$R+*) -(* Version 4.10 1982 Per Stangeland*) -(* Translated into English Nov. 27th, 1982 - Per Stangeland *) -CONST - no_of_codes = 21; - - VAR - inn,(*WS- text*) - ut, (*Output file*) - par, (*parameter file*) - skjerm (*dvs. vanlig output, m} defineres for prosedyre ASCII*) : text; - ior, - i : integer; - tegn : char; - navn : string; - symbol : ARRAY [1..no_of_codes] OF string; - - EXTERNAL PROCEDURE @HLT; - - PROCEDURE ASCII(VAR print : text; ch : char); - - BEGIN - IF ord(ch) = 255 THEN - ch := '?'; - clrbit(ch,7); - IF ord(ch) < 32 THEN - ch := '?'; - write(print,ch); - END; (*ASCII*) - - PROCEDURE convert(VAR s,d : text); -(* S = input file, D = output file. The S file is read, character by - character, by the CASE statement- line 258. - Special printer symbols are put into the buffer through procedure enter. - Ordinarù ASCIÉ characteró arå puô intï thå buffeò througè thå - IÆ statemenô in line 280. Symboì foò EOLÎ/enä oæ paragrapè are entered - bù thå nexô IF® Checë foò doô commands are done at the beginning of a - file and after each EOLN. Other symbols found in file S will be disregarded. - The D- file is written in 4 K blocks whenever the buffer is full.*) - - CONST -(*ASCII symbols used by Wordstar. Decimal notation.*) - SKIP = 0; (* characters that should not be transferred are set to 0 hex*) - fat = 2; (*backspace and double print*) - bel = 7; (*bell*) - bs = 8; (*back space ?*) - tab = 9; - lf = 10; - softline = 13; (*A "true" chr 13 will be trapped by the EOLN - check. Softline is an 8D hex after clrbit.*) - ns = 15; - underline = 19; - halfup = 20; - softhy = 30; - hy = 31; - space = 32; - quote = 34; - max = 4080; - bufsize = 4095; (*count may exceed max when - a long printer symbol is entered into the file. The buffer - size is therefore set to max+15 to prevent overflow.*) - - VAR - LAST_SYMBOL, - idx, - count, (*counts characters put into the buffer*) - i : integer; - buff :ARRAY [0..bufsize] OF char; (* 1..bufsize gives overflow. Why?*) - ch : char; - normaltext,fat_test,under_test,quote_test,half_test: boolean; - (*Set to FALSE in Switch, when printing in special typesets is in effect*) - dotcommand : string; - - PROCEDURE Dot; - (*DOT is called at every end- of line encountered in the S - file. - It detects dot commands. No action is taken if the first symbol - on a new line is not a '.' *) - - PROCEDURE lineheight; - (* Used by procedure dot to interpret line height symbols in the - WS file. '.LH 10' or 'LH 12' (1 1/2 and double spaced lines) - start a normal text sequence. '.LH 8' (narrow lines) is assumed - to indicate a quotation sequence. This sequence is marked by - symbol 3 (start) and symbol 5 (end) in the output file. Symbol - 2 and 4 should be alternate character sets. *) - - VAR - Digit, - L, - i, - NO : integer; - - BEGIN - NO := 0; - delete(dotcommand,1,3); (*remove the .lh *) - L := length(dotcommand); - IF (L = 0) THEN - undefined; - FOR i := 1 TO L DO - BEGIN (*transform string characters to integers*) - (*works OK in the 0 to 32767 range - no warning given - for larger numbers. Non-integer values are - ignored.*) - Digit := ord(dotcommand[i]) - 48; - IF digit in [0..9] THEN NO := NO * 10 + digit; - END; - CASE NO OF - 8 : switch(3,0,normaltext); (*normaltext is never false when a - .lh 8 is encountered. Enter 3 is - assumed to give a special typeset - for quotations. Is is terminated - when the text contains a .lh 10, - with enter 5.. - Normal printing is indicated by - Enter 2 - at the beginning of a - text and after quotations. *) - - 10 : BEGIN if normaltext then enter(2) - ELSE BEGIN - enter(5); - enter(2); - normaltext:=true; - END; - END; - 12 : BEGIN if normaltext then enter(4) - ELSE BEGIN - enter(5); - enter(4); - normaltext:=true; - END; - END;(*.lh 12*) - ELSE undefined; - END; (*CASE*) - END; (*lineheight*) - -(******************** DOT ***********************) - - BEGIN - IF EOF(S) THEN exit; - ch := S^; - WHILE ch = '.' DO - BEGIN - readln(s,dotcommand); - CASE dotcommand[2] OF - 'l','L' : - lineheight; - 'p','P' : - enter(1); - ELSE undefined; - END; (*CASE*) - ch := s^; - END; (*WHILE*) - END; (*DOT*) - -(**************** UNDEFINED ******************************) -(* Called by DOT at a command that requires operator intervention. - Also called by ENTER if 'normaltext' is FALSE at a '.LH 8' state- - ment. (E.G. two .lh 8 in a row. *) - - PROCEDURE undefined; - Var i: integer; - BEGIN - write(chr(BEL)); - writeln; - writeln('udefined dot command: ',dotcommand); - writeln('write a parameter number and press RETURN'); - writeln('write a 0 if this command should be disregarded'); - readln(i); - IF (I in [1..no_of_codes]) THEN - enter(i); - END; - -(******************* ENTER **********************************) - PROCEDURE enter(code : integer); - - VAR - i : integer; - this_symbol : string; - SUBSTITUTE: CHAR; - - BEGIN - If code in [1..no_of_codes] then This_symbol := symbol[code] - ELSE BEGIN undefined; exit; END; - SUBSTITUTE:=this_SYMBOL[1]; - - CASE SUBSTITUTE OF - '$': (*A '$' symbol means a standard ASCII end of line. These symbols - cannot be present in the parameter file, since end of line - is used as separator between symbols.*) - BEGIN - Buff[count]:=chr(13); - Buff[count+1]:=chr(10); - count:=count+2; - END; - '@':EXIT; (*A chr(64) in the FOTOSATS.PRM means that no action is taken - at the corresponding ENTER number. Example: A '@' at line 11 - in FOTOSATS.PRM means that soft hyphens are omitted in the - output text.*) -ELSE - BEGIN - FOR i := 1 TO length(this_symbol) DO - BEGIN - buff[count] := this_symbol[i]; - count := count + 1; - END;(*FOR*) - END; (*ELSE*) - END; (*CASE*) - LAST_SYMBOL:=CODE; -END; (*enter*) - - PROCEDURE Switch(start,stop : integer; VAR normal: Boolean); - - (* Determines if a special symbol marks the start or the end of a - sequence. Calls enter to write the correct symbol to the output - buffer. *) - - BEGIN - IF normal THEN (* TRUE switch to special print symbol*) - BEGIN - normal := false; - enter(start); - END - ELSE (* FALSE End of special text - switch back to normal print*) - BEGIN - Normal := true; - Enter(stop); - END; - END; (*Switch*) - -(***************** CONVERT *******************************) - - BEGIN - normaltext := true; - fat_test:=true; - under_test :=true;; - half_test :=true;; - quote_test :=true; - count := 1; - dot; - WHILE not eof(s) DO - BEGIN - WHILE (not eof(s)) and (count < max) DO - BEGIN - WHILE (not eoln(s)) and (count < max) DO - BEGIN - ch := S^; - ASCII(skjerm,ch); - get(s); - clrbit(ch,7); - CASE ord(ch) OF - space :IF (BUFF[COUNT-1] =' ') OR (LASTSYMBOL=20) - THEN CH:=CHR(SKIP); - (*First space character is kept. Additional - space is skipped. No space after hard eoln.*) - fat: switch(8,9,fat_test); - underline:switch(10,11,under_test); - halfup: switch(12,13,half_test); - quote: BEGIN switch(14,15,quote_test); ch:=chr(skip);END; - hy: enter(17); - softhy: enter(17); - ns: enter(18); - softline: IF (buff[count-1] =' ') OR (lastsymbol = 17) then - ch:=chr(skip) ELSE enter(19); - (*soft line shifts are removed when the last - character on that line was a space character or - a soft hyphen. Symbol 19 - usually a space - character - is entered when line shift - is the only delimiter between two words in - the text.*) - tab: enter(21); - END; (*Case*) - - IF ch in [' '..'~'] THEN (*Enter ordinary ASCII symbols*) - BEGIN - buff[count] := ch; - count := count + 1; - last_symbol:=0; - END; (*IF*) - END; (*while not eoln*) - IF (eoln(s)) AND (not eof(s))THEN (*Enter end-of-line symbol*) - BEGIN - Readln(s); - IF lastsymbol <> 20 THEN Enter(20); - (*The first RETURN is kept,following ones are removed*) - Dot; (* check for dot commands*) - END; (*IF*) - IF (count <1) OR (count>max) then writeln(count); - END; (*while not EOF and count < max *) - -(****************** WRITE PHASE ***************************) - Writeln; - WRITELN(' File ',navn,' is written - please wait'); - FOR idx := 1 TO count - 1 DO - BEGIN - d^ := buff[idx]; - put(d); - END; (*FOR*) - Count:=1; (*start a new buffer*) - END; (*while not eof*) - END; (*procedure convert*) - - (********************************************************** - MAIN PROGRAM **) - - BEGIN - REPEAT - write('Name of Wordstar- file: '); - readln(navn); - open(inn,navn,ior); - IF ior = 255 THEN - writeln('Cannot find ',navn); - UNTIL ior < 255; - I:=Pos('.',navn); - IF I>0 THEN delete(navn,I,length(navn)-I+1); - navn:=concat(navn,'.SET'); - open(ut,navn,ior); - IF ior <> 255 THEN - BEGIN - write('the file ',navn,' already exists. Should it be removed? (Y/N)'); - read(tegn); - readln; - IF not (tegn in ['Y','y']) THEN - @hlt; - END; - rewrite(ut); - assign(skjerm,'CON:'); - rewrite(skjerm); - open(par,'TYPESET.PRM',I); - IF i = 255 THEN - BEGIN - writeln('Cannot find "TYPESET.PRM" '); - @hlt; - END; - FOR i := 1 TO no_of_codes DO - BEGIN - IF eof(par) then writeln('not enough symbols in "TYPESET.PRM"') - ELSE readln(par,symbol[i]); - END; - writeln('Files are opened- conversion starts'); - IF not eof(inn) THEN - convert(inn,ut); - close(ut,ior); - IF ior < 255 THEN - writeln('file ',navn,' is written.'); - END. (*TYPESET*) - - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/UNLOCK.PAS b/software/CPM/CPM19_MTPUG_07/UNLOCK.PAS deleted file mode 100644 index c93a33d..0000000 --- a/software/CPM/CPM19_MTPUG_07/UNLOCK.PAS +++ /dev/null @@ -1,76 +0,0 @@ -MODULE KCOLNU; -{********************************************************************* - * UNLOCK * - * Date Author * - * 14-October-82 Sue Arnold * - * * - * This routine will unlock the record that you have locked so that * - * other programs may access the record that you have just locked * - * and written data to. * - * * - * An assembly routine (aunlck) will be called to actually unlock * - * the record after this routine moves the file_ID to the sector * - * buffer and sets the current DMA. * - * * - * This program requires that the rec# of the record to be locked be * - * in the FCB. To get it there, please access the record before * - * calling this routine via a "SEEKWRITE". (or something similiar). * - *********************************************************************} - - - {**************************************************************** - * follows is the format for the Pascal MT+ file information * - * block (FIB). It was modified for Ver 5.5 to include file * - * option type "fauxio". * - ****************************************************************} -TYPE - opttype = (notopen,fwrite,frdwr,frandom,fconio,ftrmio,flstout,fauxio); - buftype = PACKED ARRAY [0..127] OF CHAR; - - FIB= - RECORD - fname : STRING[16]; { d:filename.ext } - FCB : PACKED ARRAY [0..34] OF CHAR; { CP/M FILE CONTROL BLOCK } - buflen : INTEGER; { size of fbuffer } - bufidx : INTEGER; { current index into fbuffer } - option : opttype; - IOsize : INTEGER; { size of next transfer } - feoln : BOOLEAN; { TRUE if text file at end-of-line } - feof : BOOLEAN; { TRUE if at end-of-file } - fbufadr: WORD; { pointer to fbuffer } - fsecinx: 0..128; { index into fsector <+1 for overflow> } - ftext : BOOLEAN; { TRUE if this is a text file! } - nosectrs:BOOLEAN; { TRUE if no more disk room available } - fsector: buftype; { 1 sector buffer for CP/M } - fbuffer: PACKED ARRAY [0..0 ] OF CHAR; - END; - - - {**************************************************************** - * Here are bunches of external procedure declarations. * - ****************************************************************} -EXTERNAL PROCEDURE setDMA (VAR sector_buffer: buftype); - -EXTERNAL PROCEDURE aunlck (VAR ufile: FIB; - VAR lck_err: INTEGER); - -{**************************************************************** - * Procedure LOCK starts here: * - ****************************************************************} - -PROCEDURE unlock (VAR ufile : FIB; - file_ID : WORD; - VAR lck_err : INTEGER); - -BEGIN - {**************************************************************** - * First, put the file_ID number in the file sector buffer: * - * Then, call "alock" to lock the record. * - ****************************************************************} - MOVE (file_ID, ufile.fsector[0], 2); - setDMA( ufile.fsector ); - aunlck ( ufile, lck_err); - END; {procedure LOCK} - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/UOPEN.Z80 b/software/CPM/CPM19_MTPUG_07/UOPEN.Z80 deleted file mode 100644 index b334c17..0000000 --- a/software/CPM/CPM19_MTPUG_07/UOPEN.Z80 +++ /dev/null @@ -1,47 +0,0 @@ -TITLE NEPOU -; -; 9/22/82 Sue Arnold -; -; This is an assembly program that will create a file that may later be -; opened in UNLOCK mode. -; -; CALLING PROCEDURE= -; -; MAKE (VAR FCB.addr: file_descriptor; (ptr to the file FIB) -; VAR result: INTEGER); (ptr to err code variable) -; -; This routine uses XDOS function number 16h. -; - - PAGE - .Z80 -; -BDOSJP EQU 5 ; Use this to call XDOS -; -; - PAGE - PUBLIC UOPEN - CSEG -; -; -UOPEN: - POP HL ; HL = Pascal Return Address - POP DE ; DE = The addr of the error code variable - EX (SP), HL ; HL = The addr of the file descriptor - ; (top of stack now has the Pascal rtn addr) - EX DE, HL ; DE = The addr of the descriptor - ; HL = The addr of the err code variable - LD C,0FH ; OPEN function number - PUSH DE ; Save the addr of the descriptor - PUSH HL ; Save the error code addr - LD HL, 11H ; Add 17 to the address - ADD HL,DE ; To get the addr of the FCB within - EX DE,HL ; The file descriptor block - CALL BDOSJP ; Open the file - POP HL ; Restore error code addr - POP DE ; Restore file descriptor address - LD (HL), A ; Put error code in err code variable - RET ; Else, Return to calling routine -; - END UOPEN - \ No newline at end of file diff --git a/software/CPM/CPM19_MTPUG_07/USET.PAS b/software/CPM/CPM19_MTPUG_07/USET.PAS deleted file mode 100644 index a752824..0000000 --- a/software/CPM/CPM19_MTPUG_07/USET.PAS +++ /dev/null @@ -1,203 +0,0 @@ -MODULE SUERESET; -{********************************************************************* - * USET * - * Date Author * - * 04-October-82 Sue Arnold * - * * - * This is a modified version of Digital Research's Pascal MT+ * - * "RESET" procedure. It sets the "open in unlocked mode" attribute * - * bit (f5') in the FCB before calling "UOPEN" - an assembly * - * routine that replaces the @BDOS call that is normally used. * - * * - * Please note that after the OPEN the attribute bit will be reset * - * by the operating system. * - *********************************************************************} - - - {**************************************************************** - * follows is the format for the Pascal MT+ file information * - * block (FIB). It was modified for Ver 5.5 to include file * - * option type "fauxio". * - ****************************************************************} -TYPE - opttype = (notopen,fwrite,frdwr,frandom,fconio,ftrmio,flstout,fauxio); - - FIB= - RECORD - fname : STRING[16]; { d:filename.ext } - FCB : PACKED ARRAY [0..34] OF CHAR; { CP/M FILE CONTROL BLOCK } - buflen : INTEGER; { size of fbuffer } - bufidx : INTEGER; { current index into fbuffer } - option : opttype; - IOsize : INTEGER; { size of next transfer } - feoln : BOOLEAN; { TRUE if text file at end-of-line } - feof : BOOLEAN; { TRUE if at end-of-file } - fbufadr: WORD; { pointer to fbuffer } - fsecinx: 0..128; { index into fsector <+1 for overflow> } - ftext : BOOLEAN; { TRUE if this is a text file! } - nosectrs:BOOLEAN; { TRUE if no more disk room available } - fsector: PACKED ARRAY [0..127] OF CHAR; { 1 sector buffer for CP/M } - fbuffer: PACKED ARRAY [0..0 ] OF CHAR; - END; - -VAR - resultio : EXTERNAL INTEGER; - @LFB : EXTERNAL ^FIB; - - {**************************************************************** - * Here are bunches of external procedure declarations. * - ****************************************************************} -EXTERNAL PROCEDURE @DFLT; { to set Default DMA addr} -EXTERNAL FUNCTION @SPN(VAR ufile:FIB):BOOLEAN; -EXTERNAL FUNCTION @NOK(S :STRING):BOOLEAN; {parses file name} -EXTERNAL PROCEDURE @RNB; -EXTERNAL PROCEDURE CLOSE(VAR ufile:FIB; SZ:INTEGER;VAR result:INTEGER); -EXTERNAL PROCEDURE @HLT; {to abort task} -EXTERNAL PROCEDURE GET(VAR ufile:FIB; SZ:INTEGER); -EXTERNAL PROCEDURE uopen (VAR ufile: FIB; VAR result: INTEGER); - -{**************************************************************** - * Procedure USET starts here: * - ****************************************************************} - -PROCEDURE uset (VAR ufile : FIB; - bufsize : INTEGER; - VAR file_ID : INTEGER); - -VAR - result : INTEGER; - -BEGIN - @DFLT; { Set DMA Address } - {**************************************************************** - * Set the f5' attribute bit before we do anything else: * - ****************************************************************} - SETBIT (ufile.FCB[5], 7); {that's all there is to it} - {**************************************************************** - * If file write option set, then close the file first: * - ****************************************************************} - IF ufile.option = fwrite THEN - BEGIN { file write option } - CLOSE(ufile,bufsize,result); - IF result = 255 THEN - {************************************************* - * Do error handling required for bad file close:* - *************************************************} - BEGIN { can't close the file} - WRITELN; - WRITELN('UNABLE TO AUTOMATICALLY CLOSE: ',ufile.fname,' IN RESET'); - WRITELN; - WRITELN('PROGRAM ABORTED'); - @HLT {abort via @HLT} - END; { can' close the file} - END; { file write option } - - {**************************************************************** - * Put zeros in FCB entries 12-34 and set BUFLEN to zero: * - ****************************************************************} - FILLCHAR(ufile.FCB[12],25,CHR(0)); { PREPARE FOR OPEN } - {**************************************************************** - * Set the file option to indicate that it's not open: * - ****************************************************************} - ufile.option := NOTOPEN; - - {**************************************************************** - * If TEXT file, then indicate this in the FIB: * - ****************************************************************} - IF bufsize = -1 THEN { text file } - BEGIN { text file } - bufsize := -bufsize; - ufile.ftext := TRUE - END { TEXT FILE } - {**************************************************************** - * If not a text file, just set the text file boolean to FALSE * - ****************************************************************} - ELSE - ufile.ftext := FALSE; - - {**************************************************************** - * The following section of code sets up the default values for * - * the data in the file information block as follows: * - * * - * end-of-file = FALSE end-of-line = FALSE * - * FCB record count = 0 fsector index = 128 * - * there is room on disk file option = read/write * - * IOsize = bufsize (1?) buffer length = bufsize (1?) * - * fbufadr points to fbuffer * - * * - ****************************************************************} - ufile.feof := FALSE; - ufile.feoln := FALSE; { default these to FALSE } - ufile.FCB[32] := CHR(0); { set up next record field in FCB } - @LFB := ADDR(ufile); - ufile.fsecinx:= 128; { To force initial reads } - ufile.nosectrs := FALSE; { Initially sectors available } - ufile.option := FRDWR; { READ / WRITE } - ufile.IOsize := bufsize; - ufile.buflen := bufsize; - ufile.fbufadr := WRD(ADDR(ufile.fbuffer)); - - {**************************************************************** - * Now check the file name.. to see if there is one and if it * - * has the correct format: * - ****************************************************************} - IF (LENGTH(ufile.fname) = 0) OR NOT(@NOK(ufile.fname)) THEN - BEGIN { bad file name } - resultio := 255; - END { bad file name } - {**************************************************************** - * If the file name is OK then call XDOS to open the file IF it * - * is on a disk device after setting f5' * - ****************************************************************} - ELSE - BEGIN { see where the file is } - IF @SPN(ufile) THEN {=TRUE if CON:, LST:, KBD:, TRM: } - BEGIN { not on disk } - EXIT; {so we're done already} - END { not on disk } - ELSE - BEGIN { on disk } - SETBIT(ufile.FCB[5], 7); {mark the attribute bit} - uopen (ufile, resultio); - MOVE (ufile.FCB[33], file_ID, 2); {get file ID} - END { on disk } - END; { see where the file is } - - {**************************************************************** - * Add finishing touches to the FIB if we survived this far. * - ****************************************************************} - IF resultio <> 255 THEN { continue processing } - BEGIN - resultio := 0; - ufile.feof := FALSE; - ufile.feoln := FALSE; - ufile.buflen := bufsize; - {***************************************** - * Do an "initial GET" of who knows what:* - *****************************************} - IF bufsize <> 0 THEN { do an initial get } - BEGIN { buffer size not zero } - ufile.bufidx := 0; - IF ufile.ftext THEN - BEGIN { text file } - GET(@LFB^,@LFB^.buflen); - END { text file } - ELSE - BEGIN { not text file } - @RNB; - END; { not text file } - END { buffer size not zero } - END - {**************************************************************** - * We didn't make it... mark end-of-file in the FIB. * - * * - ****************************************************************} - ELSE - BEGIN {bad file name or unable to open} - ufile.feof := TRUE; - ufile.feoln := TRUE - END {bad file name or unable to open} -END; { newset } - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM20_MTPUG_08/-MTPUG.008 b/software/CPM/CPM20_MTPUG_08/-MTPUG.008 deleted file mode 100644 index e69de29..0000000 diff --git a/software/CPM/CPM20_MTPUG_08/-MTPUG.DOC b/software/CPM/CPM20_MTPUG_08/-MTPUG.DOC deleted file mode 100644 index b8f35e9..0000000 --- a/software/CPM/CPM20_MTPUG_08/-MTPUG.DOC +++ /dev/null @@ -1,65 +0,0 @@ -*** MTPUG.008 February 24, 1983 *** - - Multi-tasking under MP/M-86 using Pascal MT+86 - - Written and submitted by - Steve Clamage, - Ocean Technology, Inc. - 8755 Aero Drive Suite 310 - San Diego, CA 92123 - -Here is a package of information on how I have implemented real- -time multi-tasking under MP/M-86 using Pascal MT+86. I am not in -a position to provide detailed tutorials free to anyone who asks, -nor to field general questions from users. But I am glad to -share this with the MT Plus User's Group. The package consists -of the following: - -MPMUTIL.DOC Documentation -MPMUTIL.I86 Source code for use with the ASMT86 assembler -MPMUTIL.R86 Assembled version of the above -MPMTTIME.SRC Pascal source code illustrating the added - timing function -MPMTEST.SRC Pascal source code illustrating the use of - multi-tasking with the MPMUTIL package -MPMTESTQ.SRC Pascal source code illustrating the use of - MP/M message queues to synchronize tasks - -PASMAT.DOC A Wordstar format user's manual for Pasmat. - .CMD CP/M-86 Version - .COM CP/M-80 Version. Either version works on - MT+80 or MT+86 source code. -PMTEST.TST A scrambled Pascal program which tests MT+ features. -PMXREF.TST A Pascal program which kills the MT+ XREF program. - -*************************************************************** - - A set of graphic modules using MT+ - Written and submitted by: - J.A. Koehler - 2 Sullivan St. - Saskatoon, SK, S7H-3G8 - -DMP.SRC The graphical module -SERIO.SRC The I/O module which communicates with the - plotter. -CHROFF.DAT Data needed to plot the character set -CHRVE.DAT So far, upper case only. -TESTGR.SRC A test program to exercise the plotter. -WRDATA.SRC The program used to generate the .DAT files above. - -**************************************************************** - -ELEVATOR.PAS An elevator simulation program written by someone - .DOC in school taking a computer course. Program shows - .DAT how to get around a MT+ Bug involving calls to the - floating point routines with explicit reference to - the predeclared input files INPUT and OUTPUT. - There are three elevators in a 15 story building, - and this program simulates the pushing of the buttons - in the cars or on the floors. Submitted by - Larry D. Adkins - 56 Camille Lane - E. Patchogue, NY 11772 - - \ No newline at end of file diff --git a/software/CPM/CPM20_MTPUG_08/CHROFF.DAT b/software/CPM/CPM20_MTPUG_08/CHROFF.DAT deleted file mode 100644 index bb770cc..0000000 Binary files a/software/CPM/CPM20_MTPUG_08/CHROFF.DAT and /dev/null differ diff --git a/software/CPM/CPM20_MTPUG_08/CHRVEC.DAT b/software/CPM/CPM20_MTPUG_08/CHRVEC.DAT deleted file mode 100644 index 8dd8ac3..0000000 Binary files a/software/CPM/CPM20_MTPUG_08/CHRVEC.DAT and /dev/null differ diff --git a/software/CPM/CPM20_MTPUG_08/DMP.SRC b/software/CPM/CPM20_MTPUG_08/DMP.SRC deleted file mode 100644 index b60579b..0000000 --- a/software/CPM/CPM20_MTPUG_08/DMP.SRC +++ /dev/null @@ -1,909 +0,0 @@ -MODULE DMP ; - - (*------------------------------------------------------------------------*) - (* *) - (* All the procedures needed for the machine dependent aspects *) - (* of the GRAPHical procedures developed by Jack and myself. *) - (* *) - (* These particular ones are for the Houston Inst. DMP-2 *) - (* *) - (* Final corrections completed for MT+ Version 5.5 on 11 Jan, 1983 *) - (* *) - (* J.A. Koehler, Saskatoon *) - (* *) - (*------------------------------------------------------------------------*) - -(*$E-*) - CONST - xfactor = 7.8740; (* # of steps/mm on the Houston Instruments *) - yfactor = 7.8740; (* DMP-2 plotter *) - - minx = 0.0; (* screen co-ords in mm. *) - maxx = 254.0; - miny = 0.0; - maxy = 177.0; (* corresponding to 7" x 10" *) - - absmaxx = 10000.0; (* absolute calculation limits *) - absmaxy = 10000.0; - - radian = 57.2958; (* degrees/radian *) -(*$E+*) - - - TYPE - astringtype = string[132]; - - aendtype = (noend, point, square, triangle, cross, ecks, diamond, - circle); - - alinetype = (noline, solid, dotted, dashed, dotdashed, - dotdotdashed); - - apointtype = RECORD (* absolute position in millimeters *) - x, - y: REAL; - END; - -(*$E-*) - vector = -512..511; - - posn = -128..127; - - roff = PACKED ARRAY[1..64] of vector; - - vec = PACKED ARRAY[1..393] of posn; - - VAR - oldend: aendtype; (* last end symbol defined *) - - oldline: alinetype; (* last set line type *) - - lastpt, (* last point called for *) - oldpt, (* last point actually plotted *) - oldleft, (* existing window corners in mm.*) - oldright: apointtype; - - penlifted: BOOLEAN; (* last pen position *) - - oldesize, (* last set end symbol diameter *) - oldrptlength, (* last set line pattern length *) - oldchrheight, (* in mm *) - oldchrspace, - oldchrwidth, - oldchrangle, (* 0 is upright *) - oldstringangle: REAL; - - chroff: roff; - chrvec: vec; - - EXTERNAL PROCEDURE serout( ch: CHAR); - - EXTERNAL PROCEDURE @hlt; - - EXTERNAL PROCEDURE initac; (* initializes serial output port to plot *) - - - - PROCEDURE penup; - - (*------------------------------------------------------------------*) - (* Sets 'penlifted' to true and sends the appropriate char. *) - (* to the plotter and also sends a 50 msec delay for the action *) - (*------------------------------------------------------------------*) - VAR i:integer; - - BEGIN (* penup *) - penlifted := TRUE; - serout('y'); - for i:=1 to 22 do serout(' '); (* delay for 50 msec at 4800 baud *) - END; (* penup *) - - - - PROCEDURE pendown; - (*------------------------------------------------------------------*) - (* Sets the 'penlifted' variable and lowers the pen of the DMP-2 *) - (* and puts in a delay *) - (*------------------------------------------------------------------*) - - VAR i:integer; - - BEGIN (* pendown *) - penlifted := FALSE; - serout('z'); - for i:=1 to 22 do serout(' '); - END; (* pendown *) - - - - FUNCTION isinwindow(pt: apointtype): BOOLEAN; - (*------------------------------------------------------------------*) - (* Returns TRUE if the 'pt' is within the window defined by *) - (* 'oldleft' and 'oldright'. *) - (*------------------------------------------------------------------*) - - BEGIN (* isinwindow *) - isinwindow := (pt.x <= oldright.x) AND (pt.y <= oldright.y) AND - (pt.x >= oldleft.x) AND (pt.y >= oldleft.y); - END; (* isinwindow *) - - - - PROCEDURE plot(dest: apointtype; - how: alinetype; - endsym: aendtype); - (*------------------------------------------------------------------*) - (* Plots a line from the present position to 'dest' using the *) - (* pattern in 'how' and the end symbol in 'endsym'. The line is *) - (* constrained to stay within the current window. *) - (*------------------------------------------------------------------*) - - VAR - previous, (* pattern endpoints *) - temp: apointtype; - - i, (* pattern loop counter *) - number: INTEGER; (* # of patterns in line *) - - dx, (* pattern repeat spacing *) - dy, - len: REAL; (* line length *) - - - - PROCEDURE drawto(dest: apointtype); - (*----------------------------------------------------------------*) - (* Moves the pen to 'dest' with the pen specified by 'penlifted'.*) - (*----------------------------------------------------------------*) - - VAR - temp: apointtype; (* window crossing points *) - oldpen: BOOLEAN; - - - PROCEDURE plotpoint(at: apointtype); - (*--------------------------------------------------------------*) - (* Moves the pen to 'at'. *) - (*--------------------------------------------------------------*) - - VAR - xint, (* integer plotting values, *) - yint: INTEGER; (* between 0 and 779 or 1023 *) - - - PROCEDURE sendit(x,y:integer); - (* - Procedure to draw a line of dimensions (x,y) on the - DMP-2 plotter - *) - - var val:string; - j,z,e,t,i,d,f: integer; - - BEGIN - val:='pqrqrststuvuvwpw'; - f:=abs(x)+abs(y); - IF f<> 0 - THEN - BEGIN - d:=abs(y)-abs(x); - i:=0; - IF y > 0 THEN i :=2; - t := x+y; - IF t >= 0 THEN i := i+2; - t := y-x; - IF t >= 0 THEN i := i+2; - IF x < 0 - THEN i := i+10 - ELSE i := 8-i; - IF d >= 0 - THEN - BEGIN - t := abs(x); - d := -d; - END - ELSE t := abs(y); - e := 0; - REPEAT - z := t+d+e+e; - IF z >= 0 - THEN - BEGIN - e := e+d; - f := f-2; - serout(val[i]); - END - ELSE - BEGIN - e := e+t; - f := f-1; - serout(val[i-1]); - END; - UNTIL f <= 0; - END; - END; (* sendit *) - - - BEGIN (* plotpoint *) - xint := round((at.x-oldpt.x)* xfactor); - yint := round((at.y-oldpt.y)* yfactor); - sendit(xint,yint); - oldpt := at; - END; (* plotpoint *) - - - PROCEDURE interpolate(inside, - outside: apointtype; - VAR crossing: apointtype); - (*--------------------------------------------------------------*) - (* Finds the window crossing point on the line between 'inside'*) - (* and 'outside'. The result is returned in 'crossing'. *) - (*--------------------------------------------------------------*) - - - - FUNCTION vertcross(left, - right: apointtype; - midx: REAL): REAL; - (*------------------------------------------------------------*) - (* Finds the vertical crossing point at 'midx' on the *) - (* line between 'left' and 'right'. *) - (*------------------------------------------------------------*) - - BEGIN (* vertcross *) - vertcross := left.y + (right.y - left.y) * - (midx - left.x) / (right.x - left.x); - END; (* vertcross *) - - - - FUNCTION horcross(bottom, - top: apointtype; - midy: REAL): REAL; - (*------------------------------------------------------------*) - (* Finds the horizontal crossing point at 'midy' on the *) - (* line between 'bottom' and 'top'. *) - (*------------------------------------------------------------*) - - BEGIN (* horcross *) - horcross := bottom.x + (top.x - bottom.x) * - (midy - bottom.y) / (top.y - bottom.y); - END; (* horcross *) - - - - BEGIN (* interpolate *) - crossing.x := -1; (* indicate crossing not found *) - crossing.y := -1; - - IF outside.x < oldleft.x (* is it to the left? *) - THEN - BEGIN - crossing.x := oldleft.x; - crossing.y := vertcross(outside, inside, - oldleft.x); - END (* IF outside ... *) - ELSE IF outside.x > oldright.x (* or to the right? *) - THEN - BEGIN - crossing.x := oldright.x; - crossing.y := vertcross(inside, outside, - oldright.x); - END; (* ELSE IF outside.x ... *) - - IF NOT isinwindow(crossing) (* did we not find it yet? *) - THEN - IF outside.y < oldleft.y (* is it below? *) - THEN - BEGIN - crossing.y := oldleft.y; - crossing.x := horcross(outside, inside, - oldleft.y); - END (* IF outside ... *) - ELSE IF outside.y > oldright.y (* or above? *) - THEN - BEGIN - crossing.y := oldright.y; - crossing.x := horcross(inside, outside, - oldright.y); - END; (* ELSE IF outside.y ... *) - END; (* interpolate *) - - - - BEGIN (* drawto *) - - oldpen := penlifted; - IF isinwindow(lastpt) - THEN - IF isinwindow(dest) - THEN - plotpoint(dest) - ELSE - BEGIN - interpolate(oldpt, dest, temp); - plotpoint(temp); - END (* ELSE *) - ELSE { was not inside the window before } - IF isinwindow(dest) - - THEN - - IF oldpen THEN plotpoint(dest) ELSE - - BEGIN - interpolate(dest, lastpt, temp); - penup; - plotpoint(temp); - pendown; - plotpoint(dest); - END; - lastpt:=dest; - END; (* drawto *) - - - - PROCEDURE draw(what: aendtype); - (*----------------------------------------------------------------*) - (* Draws the endpoint symbol 'what' with size 'oldesize' *) - (* centered at the present position. *) - (*----------------------------------------------------------------*) - - VAR - origin, (* holds line endpoint *) - temp: apointtype; - - oldpenup: BOOLEAN; (* holds old penlifted *) - - - - PROCEDURE closed(initangle: REAL; - npoints: INTEGER); - (*--------------------------------------------------------------*) - (* Plots a polygon of size 'oldesize' with 'npoints' *) - (* corners starting at 'initangle' degrees clockwise from *) - (* vertical centered at 'origin'. *) - (*--------------------------------------------------------------*) - - VAR - i: INTEGER; (* corner counter *) - - angle: REAL; (* angle counter *) - - - BEGIN (* closed *) - FOR i := 0 to npoints DO - BEGIN - IF i = 0 - THEN - penup - ELSE IF penlifted - THEN - pendown; - angle := (initangle + i * (360.0 / npoints)) / radian; - temp.x := origin.x + ( oldesize * sin(angle)) / 2.0; - temp.y := origin.y + ( oldesize * cos(angle)) / 2.0; - drawto(temp); - END; (* FOR i ... *) - END; (* closed *) - - - - PROCEDURE open(initangle: REAL); - (*--------------------------------------------------------------*) - (* Plots a cross of size 'oldesize' with one axis at *) - (* 'initangle' clockwise from vertical centered at 'origin'. *) - (*--------------------------------------------------------------*) - - VAR - i, (* loop counters *) - j: INTEGER; - - angle, (* angle of a line segment *) - stangle: REAL; (* start angle of a line segment *) - - - BEGIN (* open *) - FOR j := 0 TO 1 DO - BEGIN - stangle := initangle + j * 90.0; - FOR i := 0 TO 1 DO - BEGIN - IF i = 0 - THEN - penup - ELSE - pendown; - angle := (stangle + i * 180.0) / radian; - temp.x := origin.x + ( oldesize * sin(angle)) / 2.0; - temp.y := origin.y + ( oldesize * cos(angle)) / 2.0; - drawto(temp); - END; (* FOR i ... *) - END; (* FOR j ... *) - END; (* open *) - - - - BEGIN (* draw *) - IF what <> noend - THEN - BEGIN - origin := oldpt; (* save endpoint *) - oldpenup := penlifted; (* and pen status *) - IF what IN [square, triangle, diamond, circle, cross, ecks] - THEN - CASE what OF - square: closed(45.0, 4); - triangle: closed(0.0, 3); - diamond: closed(0.0, 4); - circle: closed(0.0, 10); - cross: open(0.0); - ecks: open(45.0); - END (* CASE what *) - ELSE IF what = point - THEN - pendown; (* make a mark *) - - IF NOT penlifted (* return to last endpoint *) - THEN - penup; - drawto(origin); (* also resets vector mode *) - IF NOT oldpenup - THEN - pendown - ELSE - penup; - END; (* IF what... *) - END; (* draw *) - - - - PROCEDURE pltpat(source, - dest: apointtype); - (*----------------------------------------------------------------*) - (* Plots the a line segment of the pattern 'how' from 'source' *) - (* to 'dest'. *) - (*----------------------------------------------------------------*) - - VAR - p1, (* pattern fraction endpoints *) - p2, - p3: apointtype; - - dx, (* pattern fraction increment *) - dy: REAL; - - - BEGIN (* pltpat *) - CASE how OF - dotted: BEGIN - IF NOT penlifted - THEN - penup; - drawto(dest); - draw(point); - END; (* dotted: *) - dashed: BEGIN - p1.x := (source.x + dest.x) / 2.0; - p1.y := (source.y + dest.y) / 2.0; - IF NOT penlifted - THEN - penup; - drawto(p1); - pendown; - drawto(dest); - END; (* dashed: *) - dotdashed: BEGIN - dx := (dest.x - source.x) / 3.0; - dy := (dest.y - source.y) / 3.0; - p1.x := source.x + dx; - p2.x := p1.x + dx; - p1.y := source.y + dy; - p2.y := p1.y + dy; - IF NOT penlifted - THEN - penup; - drawto(p1); - draw(point); - drawto(p2); - pendown; - drawto(dest); - END; (* dotdashed: *) - dotdotdashed: BEGIN - dx := (dest.x - source.x) / 4.0; - dy := (dest.y - source.y) / 4.0; - p1.x := source.x + dx; - p2.x := p1.x + dx; - p3.x := p2.x + dx; - p1.y := source.y + dy; - p2.y := p1.y + dy; - p3.y := p2.y + dy; - IF NOT penlifted - THEN - penup; - drawto(p1); - draw(point); - drawto(p2); - draw(point); - drawto(p3); - pendown; - drawto(dest); - END; (* dotdotdashed: *) - END; (* CASE how *) - END; (* pltpat *) - - - - BEGIN (* plot *) - IF dest.x > absmaxx - THEN - dest.x := absmaxx - ELSE IF dest.x < (0 - absmaxx) - THEN - dest.x := (0 - absmaxx); - IF dest.y > absmaxy - THEN - dest.y := absmaxy - ELSE IF dest.y < (0 - absmaxy) - THEN - dest.y := (0 - absmaxy); - - IF how IN [noline, solid] (* segmenting not needed *) - THEN - BEGIN - IF how = noline - THEN - penup - ELSE - pendown; - drawto(dest); - END (* IF how ... *) - ELSE - BEGIN - len := sqr(oldpt.x - dest.x) + sqr(oldpt.y - dest.y); - IF len > 0.25 (* make sure won't bomb on *) - THEN (* underflow *) - len := sqrt(len) - ELSE - len := 0; - number := 1 + trunc(len / oldrptlength); - dx := (dest.x - oldpt.x) / number; - dy := (dest.y - oldpt.y) / number; - previous := oldpt; - FOR i := 1 TO number DO - BEGIN - temp.x := previous.x + dx; - temp.y := previous.y + dy; - pltpat(previous, temp); - previous := temp; - END; (* FOR i ... *) - END; (* ELSE *) - - draw(endsym); - END; (* plot *) -(*$E+*) - - FUNCTION abadcall: BOOLEAN; - (*------------------------------------------------------------------*) - (* Returns TRUE if something is wrong with a procedure call. Not *) - (* implemented. *) - (*------------------------------------------------------------------*) - - BEGIN (* abadcall *) - abadcall := FALSE; - END; (* abadcall *) - - - PROCEDURE adefault; - (*------------------------------------------------------------------*) - (* Sets all globals to their default values. *) - (*------------------------------------------------------------------*) - - BEGIN (* adefault *) - oldchrspace:=3.0; - oldchrheight:=3.5; - oldchrwidth:=3.0; - oldchrangle:=0.0; - oldstringangle:=0.0; - oldend := noend; (* simple line *) - oldesize := 3.0; - oldrptlength := 5.0; - oldline := noline; - oldleft.x := minx; (* window size to full screen *) - oldleft.y := miny; - oldright.x := maxx; - oldright.y := maxy; - END; (* adefault *) - - - - PROCEDURE agraph; - (*------------------------------------------------------------------*) - (* Does nothing *) - (*------------------------------------------------------------------*) - - BEGIN (* agraph *) - END; (* agraph *) - - - - PROCEDURE ainit; - (*------------------------------------------------------------------*) - (* Initializes the I/O to the DMP-2 plotter, the character set, *) - (* sets all paramters to their default values, and places the pen *) - (* in the lower left-hand corner. *) - (*------------------------------------------------------------------*) - - - VAR ch: CHAR; - - result: INTEGER; - - x: FILE OF roff; - y: FILE OF vec; - - BEGIN (* ainit *) - assign(x,'A:CHROFF.DAT'); - reset(x); - IF ioresult = 255 - THEN - BEGIN - assign(x,'B:CHROFF.DAT'); - reset(x); - IF ioresult = 255 - THEN - BEGIN - writeln('Cannot find CHROFF.DAT'); - @hlt; - END; - END; - chroff:=x^; - close(x,result); - assign(y,'A:CHRVEC.DAT'); - reset(y); - IF ioresult = 255 - THEN - BEGIN - assign(y,'B:CHRVEC.DAT'); - reset(y); - IF ioresult = 255 - THEN - BEGIN - writeln('Cannot find CHRVEC.DAT'); - @hlt; - END; - END; - chrvec:=y^; - close(y,result); - initac; - penup; - adefault; - agraph; - oldpt.x:=0.0; - oldpt.y :=0.0; - lastpt:=oldpt; - writeln('Set plotter to lower left corner, type anything when ready'); - read(ch); - END; (* ainit *) - - - - PROCEDURE amakecopy; - (*------------------------------------------------------------------*) - (* Does nothing *) - (*------------------------------------------------------------------*) - - BEGIN (* amakecopy *) - END; (* amakecopy *) - - - - PROCEDURE aplot(endpoint: apointtype); - (*------------------------------------------------------------------*) - (* Plots to 'endpoint' using line type 'oldline' and end type *) - (* 'oldend'. *) - (*------------------------------------------------------------------*) - - BEGIN (* aplot *) - plot(endpoint, oldline, oldend); - END; (* aplot *) - - - - PROCEDURE asetplot(line: alinetype; - repeatlength, - endsize: REAL; - endsymbol: aendtype); - (*------------------------------------------------------------------*) - (* Sets the characteristics of the line(s) to be plotted next. *) - (*------------------------------------------------------------------*) - - BEGIN (* asetplot *) - oldline := line; - oldrptlength := repeatlength; - oldesize := endsize; - oldend := endsymbol; - END; (* asetplot *) - - - - PROCEDURE asetstr(charheight, - charwidth, - charangle, - charspace, - strangle: REAL); - (*------------------------------------------------------------------*) - (* Sets the characteristics of the next string(s) to be plotted. *) - (*------------------------------------------------------------------*) - - BEGIN (* asetstr *) - oldchrheight:=charheight; - oldchrwidth:=charwidth; - oldchrangle:=charangle; - oldchrspace:=charspace; - oldstringangle:=strangle; - END; (* asetstr *) - - - - PROCEDURE asetwindow(lowerleft, - upperright: apointtype); - (*------------------------------------------------------------------*) - (* Sets the window size. Nothing will appear outside this window. *) - (*------------------------------------------------------------------*) - - BEGIN (* asetwindow *) - oldleft := lowerleft; - oldright := upperright; - IF lowerleft.x < minx - THEN - oldleft.x := minx; - IF lowerleft.y < miny - THEN - oldleft.y := miny; - IF upperright.x > maxx - THEN - upperright.x := maxx; - IF upperright.y > maxy - THEN - upperright.y := maxy; - END; (* asetwindow *) - - - - PROCEDURE asize(VAR size: apointtype); - (*------------------------------------------------------------------*) - (* Returns the size of the display in mm. *) - (*------------------------------------------------------------------*) - - BEGIN (* asize *) - size.x := maxx - minx; - size.y := maxy - miny; - END; (* asize *) - - - - PROCEDURE astr(str: astringtype); - (*------------------------------------------------------------------*) - (* writes the string 'str' out to plotter *) - (*------------------------------------------------------------------*) - - TYPE - - pen = (down,up); - - moves = RECORD - number:integer; - x,y: ARRAY [1..15] of REAL; - how: ARRAY [1..15] of pen; - END; (* record *) - - - VAR i,j,nchr: integer; - init,temp: apointtype; - co_ord: moves; - - PROCEDURE rotandmake(ch:CHAR;height,width,angle:REAL;VAR co_ord:moves - ); - (* makes up a set of moves in order to plot the character *) - - VAR sine,cosine,tempx,tempy: REAL; - i: INTEGER; - - PROCEDURE getch(ch:char;var vals:moves); - - VAR n,i,j,beg,last,val: INTEGER; - - BEGIN - val := ord(ch)-32; - while val>63 do val:=val-32; { remove lower case char. } - if (val>0) and (val<64) - THEN - BEGIN - beg:=chroff[val]; - if beg < 0 then beg := 0-beg; - last := chroff[val+1]; - if last < 0 then last := 0 - last; - last := last - 1; - FOR i :=beg to last do - BEGIN - j:=i+1-beg; - n := chrvec[i]; - if n < 0 then n := (-1)*n; - vals.x[j]:=n div 10; - vals.y[j]:=n mod 10; - if chroff[val] < 0 then vals.y[j]:=vals.y[j]-4.0; - if (i=beg) or (chrvec[i]<0) - THEN vals.how[j]:=up - ELSE vals.how[j]:=down; - END; - vals.number := last+1-beg; - END; - END; (* getch *) - - BEGIN - sine:=sin(angle/radian); - cosine:=cos(angle/radian); - getch(ch,co_ord); - FOR i := 1 TO co_ord.number - DO - BEGIN - tempx:=co_ord.x[i]*width/10.0; - tempy:=co_ord.y[i]*height/10.0; - co_ord.x[i]:=tempx*cosine-tempy*sine; - co_ord.y[i]:=tempy*cosine+tempx*sine; - END; - END; - - BEGIN (* astr *) - nchr:=length(str); - FOR i := 1 to nchr - DO - BEGIN - init:=oldpt; - if str[i]<>' ' - THEN - BEGIN - rotandmake(str[i],oldchrheight,oldchrwidth, - oldchrangle,co_ord); - FOR j:=1 TO co_ord.number - DO - BEGIN - temp.x:=init.x+co_ord.x[j]; - temp.y:=init.y+co_ord.y[j]; - IF co_ord.how[j]=up - THEN plot(temp,noline,noend) - ELSE plot(temp,solid,noend); - END; - END; - temp.x:=init.x+oldchrspace*cos(oldstringangle/radian); - temp.y:=init.y+oldchrspace*sin(oldstringangle/radian); - plot(temp,noline,noend); - END; - END; (* astr *) - - - - PROCEDURE atext; - (*------------------------------------------------------------------*) - (* Does nothing in this implementation *) - (*------------------------------------------------------------------*) - - BEGIN (* atext *) - END; (* atext *) - - - - PROCEDURE awhere(VAR where: apointtype; - VAR inwindow: BOOLEAN); - (*------------------------------------------------------------------*) - (* Returns the current locatation and whether it's inside the *) - (* window. *) - (*------------------------------------------------------------------*) - - BEGIN (* awhere *) - where := oldpt; - inwindow := isinwindow(oldpt); - END; (* awhere *) -modend. - \ No newline at end of file diff --git a/software/CPM/CPM20_MTPUG_08/ELEVATOR.CMD b/software/CPM/CPM20_MTPUG_08/ELEVATOR.CMD deleted file mode 100644 index 3be4cc5..0000000 --- a/software/CPM/CPM20_MTPUG_08/ELEVATOR.CMD +++ /dev/null @@ -1 +0,0 @@ -b:elevator,b:fpreals/s,paslib/s \ No newline at end of file diff --git a/software/CPM/CPM20_MTPUG_08/ELEVATOR.DAT b/software/CPM/CPM20_MTPUG_08/ELEVATOR.DAT deleted file mode 100644 index e31d95f..0000000 --- a/software/CPM/CPM20_MTPUG_08/ELEVATOR.DAT +++ /dev/null @@ -1,8 +0,0 @@ -2 8 13 -0.105 0.0 0.2 0.01 0.018 0.018 0.018 0.018 0.018 0.018 -0.019 0.011 0.01 0.01 0.03 0.02 0.01 0.02 0.011 0.010 -0.012 0.021 0.02 0.03 0.04 0.05 0.06 0.07 0.0 0.255555 -0.1 0.3 0.1 0.1 0.1 0.1 0.1 0.1 0.1 0.1 0.1 0.1 0.1 0.25 0.3 -40 -20000 - \ No newline at end of file diff --git a/software/CPM/CPM20_MTPUG_08/ELEVATOR.PAS b/software/CPM/CPM20_MTPUG_08/ELEVATOR.PAS deleted file mode 100644 index a39d645..0000000 --- a/software/CPM/CPM20_MTPUG_08/ELEVATOR.PAS +++ /dev/null @@ -1,773 +0,0 @@ -{############################################################################# -#### File name: ELEVATOR.PAS -#### Module name: MSC-elevator. -#### Support modules reqd: . -#### Run time environment: Digital Research's CP/M -#### 8080 CPU. -#### Compile time environment: Digital Research's Pascal/MT+ 5.2 -#### Copyright (c) 1981 by Lawrence Adkins. -#### Program development history: -#### 29-Apr-82 Program created. -#### 1-May-82 Changes made to allow scheduling of non-busy elevators, and -#### to idle those that are both non_busy and not scheduled. -#### 3-May-82 More improvements to the scheduling algorithms. -#### (Last update on: 03-May-82) -##############################################################################} - -{############################################################################## -#### This program simulates a system of several elevators all in operation -#### within a high-rise building. The program cannot do any special I/O, -#### and is therefore unable to replace the conventional relay networks -#### presently controlling most elevators. The program runs in batch mode. -#### 1-May changes: Any passengerless, unassigned elevator -#### (during each time interval) will be assigned any most extreme floor -#### (should one exist) where a floor call has been made which originated -#### at a floor in the direction of the elevator, but which indicated that the -#### direction had to be reverse. I.e, curr_floor = 6, direction = down, call -#### from floor 2 to to go up. Passengerless elevators which see -#### no floor calls originating and indicating the current direction (i.e., -#### curr_floor = 6, direction = down, call from 3 to go down), did not prev- -#### iously assign themselves, nor cannot currently assign themselves a floor -#### would be required to cease motion. Once any elevator opens its doors at -#### a floor, and both button lights go out, that floor's assigned elevator -#### field must be reset to zero. -##############################################################################} - - - -PROGRAM elevator_system (* VAR input, output: text *); - -CONST - bottom_floor = 1; { lowest floor elevator goes to } - top_floor = 15; { highest floor elevator goes to } - max_elevators = 3; { number of elevators in the system } - -TYPE - motion = (down, up); { the only two ways an elevator moves } - action = (door_open, in_motion); { ... and the only two states... } - t_elevator_info = RECORD - curr_floor : bottom_floor..top_floor; - fire_exit : bottom_floor..top_floor; - direction : motion; - status : action; - button_bank: ARRAY [bottom_floor..top_floor] OF boolean; - END; - t_floor_info = RECORD - up_button : boolean; - down_button: boolean; - prob_up_button_pushed: real; - prob_down_button_pushed: real; - prob_this_floor_is_destination: real; - nb_elev_serving_this_request: 0..max_elevators; - END; - - -VAR - elev_cars : ARRAY [1..max_elevators] OF t_elevator_info; - { our three elevator cars and associated shafts } - elev_foyers: ARRAY [bottom_floor..top_floor] OF t_floor_info; - { our foyers on fifteen stories each with - three elevator entrances and a pair of buttons } - clock: integer; { measures intervals of (lets say) five seconds } - bldg_on_fire: boolean; { at this point always false, but if there - was a sensor, would bring elevators to exit floor } - max_time: integer; { our elevator cannnot run forever- it must cease to - to function when clock exceeds this value } - shaft: integer; { a temporary holding an elevator/shaft number } - seed_for_random_number_generator: real; - infil: text; - outfil: text; - -{############################################################################## -#### Assumed structure of input text data file... -#### The first three inputs are integers indicating the floor where each -#### elevator will be initially positioned. (Preferably fire exit floors.) -#### The next fifteen pairs of inputs are real floating point numbers -#### representing the probabilities of the 'UP' and 'DOWN' buttons in -#### that order) being pushed for the respective floors 1..15. -#### The next fifteen inputs are real floating point numbers representing -#### the probabilities of the buttons in the elevators, for floors 1 thru -#### 15, respectively, whenever passengers enter the elevator. -#### The next input is an integer representing the number of time units for -#### which to run the simulation. -#### The last expected input is an integer between 1 and 65256 to be used -#### as an initial seed for the random number generator. -##############################################################################} - - - - -PROCEDURE initialize (VAR input, output: text); FORWARD; - PROCEDURE init_elev_cars (VAR input, output: text); FORWARD; - PROCEDURE print_legend (VAR output: text); FORWARD; - PROCEDURE init_up_down_probabilities (VAR input, output: text); FORWARD; - PROCEDURE init_floor_selection_probabilities (VAR input,output:text);FORWARD; -PROCEDURE print_status_board (VAR output: text); FORWARD; - PROCEDURE print_elev_car_status (VAR output: text); FORWARD; -PROCEDURE h1andle_requests_for_elevator_usage (VAR output: text); FORWARD; - FUNCTION random_num (VAR seed: real): real; FORWARD; -PROCEDURE perform_a_single_operation (shaft: integer; VAR output:text);FORWARD; - FUNCTION listed_in_floor_table (shaft: integer; VAR floor: integer) - : boolean; FORWARD; - FUNCTION must_continue_in_same_direction (shaft: integer): boolean; FORWARD; - FUNCTION against_stops (shaft: integer): boolean; FORWARD; - FUNCTION no_passengers (shaft: integer): boolean; FORWARD; - FUNCTION reason_to_open_door (shaft: integer): boolean; FORWARD; - FUNCTION other_floor_calls (shaft: integer): boolean; FORWARD; - PROCEDURE h2andle_an_emergency (shaft: integer; VAR output: text); FORWARD; - PROCEDURE open_elevator_door (shaft: integer; VAR output: text); FORWARD; - PROCEDURE pick_destination_floors (shaft: integer;VAR output:text);FORWARD; - FUNCTION could_provide_service (shaft: integer): boolean; FORWARD; - - - - - - - -{############################################################################## -#### Initialize probabilities by reading from data file. -#### Data file is read from only at initialization time. -#### Range checking is done on most read-in values, with errors -#### generating messages and replacing with arbitrary permissable values. -#### Initialize elevator system data structures. -##############################################################################} -PROCEDURE initialize (* VAR input, output: text *); - - BEGIN - writeln (output, ' ---- SIMULATION OF AN ELEVATOR SYSTEM. ---- '); - writeln (output); - print_legend (output); - writeln (output); - init_elev_cars (input, output); - writeln (output); - init_up_down_probabilities (input, output); - writeln (output); - init_floor_selection_probabilities (input, output); - writeln (output); - read (input, max_time); - IF (max_time < 0) OR (max_time > 1000) - THEN BEGIN - writeln (output, 'Data error. Illegal MAX_TIME of ', max_time:6); - max_time := 5 - END; - writeln (output, 'MAX_TIME is ', max_time:6); - read (input, seed_for_random_number_generator); - IF (seed_for_random_number_generator < 1.0) - OR (seed_for_random_number_gernerator > 65256.0) - THEN BEGIN - writeln (output, 'Data error. Illegal SEED of ', - seed_for_random_number_generator:15); - seed_for_random_number_generator := 127.0 - END; - writeln (output, 'Random number generator SEED is ', - seed_for_random_number_generator:15); - bldg_on_fire := false - END; - - - -PROCEDURE print_legend (* VAR output: text *); - - BEGIN - writeln (output, 'In the maps which follow the following legend applies:'); - writeln (output, ' Given this sample output,'); - writeln (output, - '1 floor 1 2 3 4 5 6 7 8 9 10...'); - writeln (output, '2'); - writeln (output, - '3 up calls > . . . . > . . . .'); - writeln (output, '4'); - writeln (output, - '5 car 1 -> . 1 . . . . . . . +'); - writeln (output, - '6 car 2 -> . . . . . . . 2 + .'); - writeln (output, - '7 car 3 <- + . . < . . . . . .'); - writeln (output,'8'); - writeln (output, - '9 down calls . . . < . . . . . .'); - writeln (output); - writeln (output,'where, in lines 3 and 9 the arrows represent calls, and'); - writeln (output,'dots represent no calls. In lines 5 thru 7, plusses'); - writeln (output,'represent buttons pushed within the elevator, digits'); - writeln (output,'represent elevators which have opened their doors, while'); - writeln (output,'arrows here represent elevators passing by a floor w/o'); - writeln (output,'stopping. Dots here indicate no elevators or buttons '); - writeln (output,'not pushed from within the elevator.'); - END; - - -{############################################################################## -#### Initialization of the elev_cars array. Probabilities read from input -#### file, other fields initialized with predetermined values. -##############################################################################} -PROCEDURE init_elev_cars (* VAR input, output: text *); - - VAR shaft, floor, pres_floor: integer; - BEGIN - writeln (output, 'Initial elevator floor assignments. '); - writeln (output, 'elevator':10, 'floor':10); - FOR shaft := 1 TO max_elevators - DO WITH elev_cars [shaft] - DO BEGIN - read (input, pres_floor); - IF (pres_floor < bottom_floor) OR (pres_floor > top_floor) - THEN BEGIN - writeln (output, 'Data error. Illegal initial floor # ', - pres_floor:3, ' for elevator ', shaft:2); - pres_floor := bottom_floor - END; - curr_floor := pres_floor; - writeln (output, shaft:10, curr_floor:10); - direction := up; - status := door_open; - fire_exit := curr_floor; - FOR floor := bottom_floor TO top_floor - DO button_bank [floor] := false - END - END; - - - -{############################################################################## -#### Initialize most portions of the elev_foyer array, with probabilities -#### read from the input file, and other fields assigned predetermined values. -##############################################################################} -PROCEDURE init_up_down_probabilities (* VAR input, output: text *); - - VAR floor: integer; - BEGIN - writeln (output, 'Initial elevator foyer up-down button probability', - ' assignments.'); - writeln (output, 'floor':10, 'up':15, 'down':15); - FOR floor := bottom_floor TO top_floor - DO WITH elev_foyers [floor] - DO BEGIN - up_button := false; - down_button := false; - nb_elev_serving_this_request := 0; - read (input, prob_up_button_pushed, prob_down_button_pushed); - IF (prob_up_button_pushed < 0.0) OR (prob_up_button_pushed > 1.0) - THEN BEGIN - writeln (output, 'Data error. Illegal UP selection probability', - ' of ', prob_up_button_pushed:15, ' for floor ', floor:3); - prob_up_button_pushed := 0.0 - END; - IF (prob_down_button_pushed < 0.0) OR (prob_down_button_pushed > 1.0) - THEN BEGIN - writeln (output, 'Data error. Illegal DOWN selection', - ' probability of ', prob_down_button_pushed:15, ' for floor ', - floor:3); - prob_down_button_pushed := 0.0 - END; - writeln (output, floor:10, prob_up_button_pushed:15, - prob_down_button_pushed:15) - END - END; - - - -{############################################################################## -#### Read one more set of probabilities from the input text file. -##############################################################################} -PROCEDURE init_floor_selection_probabilities (* VAR input, output: text *); - - VAR floor: integer; - BEGIN - writeln (output, 'Initial floor selection probability assignments. '); - writeln (output, 'floor':10, 'selection':15); - FOR floor := bottom_floor TO top_floor - DO WITH elev_foyers [floor] - DO BEGIN - read (input, prob_this_floor_is_destination); - IF (prob_this_floor_is_destination < 0.0) - OR (prob_this_floor_is_destination > 1.0) - THEN BEGIN - writeln (output, 'Data error. Illegal FLOOR selection ', - 'probability of ', prob_this_floor_is_destination:15, - ' for floor ', floor:3); - prob_this_floor_is_destination := 0.0 - END; - writeln (output, floor:10, prob_this_floor_is_destination:15) - END - END; - - - - -{############################################################################## -#### Give a sort of pictorial view of the status of the elevator system, -#### showing present positions, floors where buttons were pushed, etc. -#### Given this sample output, -###1 floor 1 2 3 4 5 6 7 8 9 10... -###2 -###3 up calls > . . . . > . . . . -###4 -###5 car 1 -> . 1 . . . . . . . + -###6 car 2 -> . . . . . . . 2 + . -###7 car 3 <- . . . < . . . . . . -###8 -###9 down calls . . . < . . . . . . -#### -#### where, in lines 3 and 9 the arrows represent calls, and dots represent -#### no calls. In lines 5 thru 7, plusses represent buttons pushed within -#### the elevator, digits represent elevators which have opened their doors, -#### while arrows here represent elevators passing by a floor w/o stopping. -##############################################################################} -PROCEDURE print_status_board (* VAR output: text *); - - CONST s = 3; { so that board fits on 80 column screen. } - VAR floor: integer; - BEGIN - writeln (output); writeln (output); - write (output, 'floor':15); - FOR floor := bottom_floor TO top_floor - DO write (output, floor:4); - writeln (output); writeln (output); - - write (output, 'up calls':15); - FOR floor := bottom_floor TO top_floor - DO WITH elev_foyers [floor] - DO IF up_button - THEN write (output, '>':s) - ELSE write (output, '.':s); - writeln (output); writeln (output); - - print_elev_car_status (output); - - write (output, 'down calls':15); - FOR floor := bottom_floor TO top_floor - DO WITH elev_foyers [floor] - DO IF down_button - THEN write (output, '<':s) - ELSE write (output, '.':s); - writeln (output); writeln (output); writeln (output) - END; - - - -{############################################################################## -#### Print a line pertaining to the status of a single elevator car. -##############################################################################} -PROCEDURE print_elev_car_status (* VAR output: text *); - - CONST s = 3; { so that board fits in 80 cols on screen } - VAR shaft, floor: integer; - BEGIN - FOR shaft := 1 TO max_elevators - DO WITH elev_cars [shaft] - DO BEGIN - write (output, 'car ':8, shaft:2); - IF direction = up - THEN write (output, '->':5) - ELSE write (output, '<-':5); - FOR floor := bottom_floor TO top_floor - DO IF (curr_floor = floor) - THEN IF status = door_open - THEN write (output, shaft:4) - ELSE IF direction = up - THEN write (output, '>':s) - ELSE write (output, '<':s) - ELSE IF button_bank [floor] - THEN write (output, '+':s) - ELSE write (output, '.':s); - writeln (output) - END; - writeln (output) - END; - - - -{############################################################################## -#### Figure out which buttons were pressed in every foyer (what I call the -#### hall space the elevators open into). -##############################################################################} -PROCEDURE h1andle_requests_for_elevator_usage (* VAR output: text *); - - VAR floor,shaft: integer; - r: real; - b: boolean; - BEGIN - FOR floor := bottom_floor TO top_floor - DO WITH elev_foyers [floor] - DO BEGIN - r := random_num (seed_for_random_number_generator); - IF r < prob_up_button_pushed - THEN BEGIN - up_button := true; - writeln (output, 'Up call on floor ', floor:4) - END; - r := random_num (seed_for_random_number_generator); - IF r < prob_down_button_pushed - THEN BEGIN - down_button := true; - writeln (output, 'Down call on floor ', floor:4) - END - END; - FOR shaft := 1 TO max_elevators - DO b:= could_provide_service (shaft) - END; - - - -{############################################################################## -#### Generate the pseudo random number such that 0 <= random_num <= 1 -##############################################################################} -FUNCTION random_num (* VAR seed: real): real *); - - CONST modulus = 65536.0; - multiplier = 25173.0; - increment = 13849.0; - VAR temp: real; - BEGIN - temp := ((multiplier * seed) + increment); { MOD modulus } - temp := temp / modulus; - seed := (temp - trunc (temp)) * modulus; - random_num := seed / modulus - END; - - - -{############################################################################## -#### Do what is considered a legal operation for an elevator within the -#### time interval assumed (say, 5 secs.) -##############################################################################} -PROCEDURE perform_a_single_operation (* shaft: integer; VAR output: text *); - - VAR i, floor1: integer; - busy : boolean; - BEGIN - busy := true; i := 0; - REPEAT - i := i + 1; - WITH elev_cars [shaft] - DO IF bldg_on_fire - THEN h2andle_an_emergency (shaft, output) - ELSE IF reason_to_open_door (shaft) - THEN open_elevator_door (shaft, output) - ELSE IF must_continue_in_same_direction (shaft) - OR (no_passengers (shaft) - AND NOT against_stops (shaft) - AND listed_in_floor_table (shaft, floor1)) - THEN BEGIN { move a floor up or down } - status := in_motion; - IF direction = down - THEN curr_floor := curr_floor - 1 - ELSE curr_floor := curr_floor + 1 - END - ELSE IF busy - THEN BEGIN { turn around, but dont move } - busy := false; - status := in_motion; - IF direction = down - THEN direction := up - ELSE direction := down - END - UNTIL busy OR (i = 2) - END; - - - -{############################################################################## -#### Return true if elevator (shaft) scheduled to stop at any floor along its -#### path -##############################################################################} -FUNCTION listed_in_floor_table (* shaft:integer; VAR floor:integer):boolean *); - - VAR b: boolean; - BEGIN - floor := bottom_floor - 1; - REPEAT - floor := floor + 1; - b := elev_foyers [floor].nb_elev_serving_this_request = shaft - UNTIL (floor >= top_floor) OR b; - listed_in_floor_table := b; - END; - - - -{############################################################################## -#### Determine if we must travel further before turning direction. -#### Normally, when the elevator is busy, we return true only if there are -#### people in the foyers of the floors in the elevator's current direction -#### waiting to travel further on in the same direction. -##############################################################################} -FUNCTION must_continue_in_same_direction (* shaft: integer) : boolean *); - - VAR b: boolean; - floor: integer; - BEGIN - b:= false; - IF NOT against_stops (shaft) - THEN WITH elev_cars[shaft] - DO IF direction = up - THEN FOR floor := curr_floor+1 TO top_floor - DO b := b OR button_bank [floor] - OR elev_foyers [floor].up_button - ELSE FOR floor := curr_floor-1 DOWNTO bottom_floor - DO b := b OR button_bank [floor] - OR elev_foyers [floor].down_button; - must_continue_in_same_direction := b; - END; - - - - -{############################################################################## -#### Determine if the elevator cannot go any further in the same direction. -##############################################################################} -FUNCTION against_stops (* shaft: integer): boolean *); - - BEGIN - WITH elev_cars [shaft] - DO against_stops := ((curr_floor = bottom_floor) AND (direction = down)) - OR ((curr_floor = top_floor ) AND (direction = up)) - END; - - - -{############################################################################## -#### Return true if NO buttons remain lit (unserviced) within the elevator car -##############################################################################} -FUNCTION no_passengers (* shaft: integer): boolean *); - - VAR floor: integer; - b: boolean; - BEGIN - b := false; - WITH elev_cars [shaft] - DO FOR floor := bottom_floor TO top_floor - DO b := b OR button_bank [floor]; - no_passengers := NOT b; - END; - - - -{############################################################################## -#### Return true if there stands good reason why the door should be opened. -#### Either a passenger wants to get out, or people outside want a ride along -#### the current direction. -##############################################################################} -FUNCTION reason_to_open_door (* shaft: integer): boolean *); - - BEGIN - WITH elev_cars [shaft] - DO reason_to_open_door := button_bank [curr_floor] - OR ((direction = up) AND elev_foyers [curr_floor]. up_button) - OR ((direction = down) AND elev_foyers [curr_floor]. down_button) - END; - - - -{############################################################################## -#### Return true if floor calls are pending that could not be detected by the -#### must_continue_in_same_direction function. -#### The calls examined are those originating in the current direction of the -#### elevator, but whose direction indicate that the people want to travel -#### in the reverse direction. -##############################################################################} -FUNCTION other_floor_calls (* shaft: integer): boolean *); - - VAR b: boolean; - floor: integer; - BEGIN - b:= false; - IF NOT against_stops (shaft) - THEN WITH elev_cars[shaft] - DO IF direction = up - THEN FOR floor := curr_floor+1 TO top_floor - DO b := b OR elev_foyers [floor].down_button - ELSE FOR floor := curr_floor-1 DOWNTO bottom_floor - DO b := b OR elev_foyers [floor].up_button; - other_floor_calls := b; - END; - - - -{############################################################################## -#### Routine executed whenever a building emergency occurs. -##############################################################################} -PROCEDURE h2andle_an_emergency (* shaft: integer; VAR output: text *); - - BEGIN - WITH elev_cars [shaft] - DO BEGIN - button_bank [fire_exit] := true; - IF curr_floor = fire_exit - THEN BEGIN - open_elevator_door (shaft, output); - writeln (output, '*** Elevator # ',shaft:3, ' out of service. ***') - END - ELSE IF curr_floor > fire_exit - THEN BEGIN - status := in_motion; - direction := down; - curr_floor := curr_floor - 1 - END - ELSE BEGIN - status := in_motion; - direction := up; - curr_floor := curr_floor + 1 - END - END - END; - - -{############################################################################## -#### Open the doors on the elevator and simulate the actions of the new -#### passengers pushing floor buttons. -##############################################################################} -PROCEDURE open_elevator_door (* shaft: integer; VAR output: text *); - - VAR current_floor: integer; - BEGIN - WITH elev_cars [shaft] - DO BEGIN - status := door_open; - current_floor := curr_floor - END; - WITH elev_foyers [current_floor] - DO BEGIN - IF up_button OR down_button - THEN pick_destination_floors (shaft, output); - IF elev_cars [shaft]. direction = up - THEN up_button := false - ELSE down_button := false; - IF NOT (up_button OR down_button) - THEN BEGIN - nb_elev_serving_this_request := 0; - END - END; - WITH elev_cars [shaft] - DO BEGIN - IF button_bank [curr_floor] - THEN BEGIN - button_bank [curr_floor] := false; - writeln ('Passengers let off elevator ',shaft:2, ' on floor ', - curr_floor:4) - END - END - END; - - - -{############################################################################## -#### Routine to simulate the action of passengers selecting the floors where -#### they want to go. If this were my elevator, Any floor selection would -#### be recognized (but perhaps not untilany of those in the path of the -#### present direction were visited first.) -##############################################################################} -PROCEDURE pick_destination_floors (* shaft: integer; VAR output: text *); - - CONST this_was_my_elevator = false; - VAR floor : integer; - PROCEDURE push_floor_selection_button; - VAR r: real; - BEGIN - WITH elev_cars [shaft] - DO BEGIN - r := random_num (seed_for_random_number_generator); - IF r < elev_foyers [floor]. prob_this_floor_is_destination - THEN BEGIN - button_bank [floor] := true; - write (output, floor:3, ' , ') - END - END - END; - - BEGIN - WITH elev_cars [shaft] - DO BEGIN - write (output, 'Passengers picked up by elevator ',shaft:2, ' at floor ', - curr_floor:4,' to go to floors '); - IF this_was_my_elevator - THEN FOR floor := bottom_floor TO top_floor - DO push_floor_selection_button - ELSE IF NOT against_stops (shaft) - THEN IF direction = up - THEN FOR floor := curr_floor + 1 TO top_floor - DO push_floor_selection_button - ELSE FOR floor := curr_floor - 1 DOWNTO bottom_floor - DO push_floor_selection_button; - writeln (output) - END - END; - - - -{########################################################################## -#### Figure out if the elevator has no passengers, whether there is a floor -#### call from in your direction to go in the reverse direction, and then -#### assign the closest elevator that meets these qualifications to the -#### floor call closest to either the top or bottom of the shaft. -##########################################################################} -FUNCTION could_provide_service (* shaft: integer): boolean *); - - VAR b, b1: boolean; floor: integer; - FUNCTION find_floor_unassigned_to_elevator (scale: integer): boolean; - VAR b: boolean; elev_assigned_previously: boolean; - BEGIN - REPEAT - floor := floor + scale; - WITH elev_foyers [floor] - DO BEGIN - elev_assigned_previously := NOT no_passengers (shaft) - OR ((nb_elev_serving_this_request > 0) - AND (abs (elev_cars [nb_elev_serving_this_request]. curr_floor - - floor) - < abs (elev_cars [shaft]. curr_floor - floor))); - IF NOT elev_assigned_previously - AND (((elev_cars [shaft].direction = up) AND (down_button)) - OR ((elev_cars [shaft].direction = down) AND (up_button))) - THEN nb_elev_serving_this_request := shaft; - b := (nb_elev_serving_this_request = shaft) - END - UNTIL b OR elev_assigned_previously - OR (floor = elev_cars [shaft]. curr_floor); - find_floor_unassigned_to_elevator := b - END; - - BEGIN - b := (NOT listed_in_floor_table (shaft, floor)) - AND other_floor_calls (shaft); - IF b - THEN IF elev_cars [shaft]. direction = up - THEN BEGIN - floor := top_floor + 1; - b1 := find_floor_unassigned_to_elevator (-1) - END - ELSE BEGIN - floor := bottom_floor - 1; - b1 := find_floor_unassigned_to_elevator (+1) - END; - could_provide_service := b AND b1; - END; - - - - -BEGIN { main program } -assign (infil, 'b:elevator.dat'); -reset (infil); -assign (outfil, 'CON:'); -rewrite (outfil); -initialize (infil, outfil); {init probability and other stuff } -clock := 1; -print_status_board (outfil); -REPEAT { for each time interval,...} - writeln (outfil); - writeln (outfil, ' ':30, 'Time Interval: ', clock:4); - h1andle_requests_for_elevator_usage (outfil); - FOR shaft := 1 TO max_elevators - DO perform_a_single_operation (shaft, outfil); - clock := clock + 1; - print_status_board (outfil); -UNTIL clock > max_time; { sorry, even computerized els go out of order } -writeln (outfil, 'Simulation complete. ') -END. - - - - - \ No newline at end of file diff --git a/software/CPM/CPM20_MTPUG_08/MPMTEST.SRC b/software/CPM/CPM20_MTPUG_08/MPMTEST.SRC deleted file mode 100644 index 8cfe1b9..0000000 --- a/software/CPM/CPM20_MTPUG_08/MPMTEST.SRC +++ /dev/null @@ -1,180 +0,0 @@ -program test; -{ Test multi-tasking under MP/M with Pascal MT+86 - Uses simple booleans for task exclusion - ABORT used for subtask termination } - - const - pd_max = 61; {max byte address in process descriptor table} - uda_max = 255; {max byte address in user data area table} - def_prior = 201; {default process priority} - - type - name_type = packed array [1..8] of char; - - pd_size = 0..pd_max; {Process Descriptor} - pd_type = - record - case boolean of - true: - (z1: packed array [1..5] of byte; - prior: byte; - flag: word; - name: name_type; - uda: word; - user, disk: byte; - z2: packed array [1..12] of byte; - cns: byte; - z3: packed array [1..3] of byte; - list: byte; - z4: packed array [1..15] of byte; - cns2: byte; - z5: byte; - name2: name_type); - false: - (ray: array [pd_size] of byte); - end; - - uda_size = 0..uda_max; {User Data Area for Process} - uda_type = array [uda_size] of byte; - - ptr = ^integer; - pdp = ^pd_type; - udap = ^uda_type; - - ptrtype = (ptrp, pdpp, udapp, offseg); - pointer = - record {kludge to allow any type of pointer reference} - case ptrtype of - ptrp: - (pptr: ptr); - pdpp: - (ppdp: pdp); - udapp: - (puda: udap); - offseg: - (off: word; - seg: word) - end; - - var - uda_b, uda_a: uda_type; {user data area for sub-processes} - pd_b, pd_a: pd_type; {process descriptor for sub-processes} - count_b, count_a: integer; - flag_b, flag_a: boolean; - done_b, done_a: boolean; - - external procedure init_mpm_util(size: integer); - external procedure fix_stack(taskp: ptr; - var uda: uda_type; - size: integer); - external procedure delay(ticks: integer); - external procedure dispatch; - external procedure abort(var pd: pd_type); - external function create_process(var pd: pd_type): boolean; - external function set_priority(priority: byte): boolean; - -{ ********************************************************** } - - - procedure startup(var pd: pd_type; - var uda: uda_type; - task: ptr; - name: string; - priority: integer; - size: integer); - - var - i: integer; - p: pointer; - - begin - for i := 0 to pd_max do - pd.ray[i] := 0; - for i := 0 to uda_max do - uda[i] := 0; - - pd.prior := priority; - for i := 1 to 8 do - begin - pd.name[i] := name[i]; - pd.name2[i] := name[i] - end; - p.puda := addr(uda); - pd.uda := shr(p.off, 4); {make into paragraph address} - fix_stack(task, uda, size); - - if create_process(pd) then - writeln('Starting ', name) - else - writeln('Startup of ', name, ' failed'); - end; - - - procedure task_a; - - begin - while true do - begin - while flag_a do - delay(40); {wait for flag to be cleared} - count_a := count_a + 1; - flag_a := true; - end; - end; - - - procedure task_b; - - begin - while true do - begin - while flag_b do - delay(50); {wait for flag to be cleared} - count_b := count_b + 1; - flag_b := true; - end; - end; - - - begin {main program} - writeln('Entered MAIN'); - if not set_priority(def_prior) then - begin - writeln('Unable to set main program priority'); - exit - end; - count_a := 0; count_b := 0; - flag_a := false; flag_b := false; - done_a := false; done_b := false; - init_mpm_util(6000); - startup(pd_a, uda_a, addr(task_a), 'TASK_A ', def_prior, 900); - startup(pd_b, uda_b, addr(task_b), 'TASK_B ', def_prior, 900); - - repeat - dispatch; - if flag_a then - begin - writeln('loop A count = ', count_a); - flag_a := false - end; - if (count_a >= 10) and (not done_a) then - begin - abort(pd_a); - writeln('Task A complete'); - done_a := true; - end; - if flag_b then - begin - writeln('loop B count = ', count_b); - flag_b := false - end; - if (count_b >= 10) and (not done_b) then - begin - abort(pd_b); - writeln('Task B complete'); - done_b := true; - end; - until done_a and done_b; - - end. - \ No newline at end of file diff --git a/software/CPM/CPM20_MTPUG_08/MPMTESTQ.SRC b/software/CPM/CPM20_MTPUG_08/MPMTESTQ.SRC deleted file mode 100644 index 884feac..0000000 --- a/software/CPM/CPM20_MTPUG_08/MPMTESTQ.SRC +++ /dev/null @@ -1,335 +0,0 @@ -program testq; -{ Test multi-tasking under MP/M with Pascal MT+86 - Queues used for synchronization - TERMINATE used for subtask termination } - - const - pd_max = 61; {max byte address in process descriptor table} - uda_max = 255; {max byte address in user data area table} - def_prior = 201; {default process priority} - qd_nmsgs = 5; {max messages in queue} - q_open = 135; - q_delete = 136; - q_read = 137; - q_cond_read = 138; - q_write = 139; - q_cond_write = 140; - - type - name_type = packed array [1..8] of char; - - pd_size = 0..pd_max; {Process Descriptor} - pd_type = - record - case boolean of - true: - (z1: packed array [1..5] of byte; - prior: byte; - flag: word; - name: name_type; - uda: word; - user, disk: byte; - z2: packed array [1..12] of byte; - cns: byte; - z3: packed array [1..3] of byte; - list: byte; - z4: packed array [1..15] of byte; - cns2: byte; - z5: byte; - name2: name_type); - false: - (ray: array [pd_size] of byte); - end; - - uda_size = 0..uda_max; {User Data Area for Process} - uda_type = array [uda_size] of byte; - - ptr = ^integer; - pdp = ^pd_type; - udap = ^uda_type; - qdp = ^qd_type; - qpbp = ^qpb_type; - qdmp = ^qd_msg; - - ptrtype = (ptrp, pdpp, udapp, qdpp, qpbpp, qdmpp, offseg); - pointer = - record {kludge to allow any type of pointer reference} - case ptrtype of - ptrp: - (pptr: ptr); - pdpp: - (pdpp: pdp); - udapp: - (puda: udap); - qdpp: - (pqdp: qdp); - qpbpp: - (pqpb: qpbp); - qdmpp: - (pqdm: qdmp); - offseg: - (off: word; - seg: word) - end; - - qd_msg = - record {actual Queue Message for this example} - name: name_type; - count: integer - end; - - qd_type = - record {Queue Descriptor block} - z1: longint; - flags: word; - name: name_type; - msglen: integer; - nmsgs: integer; - z3, z2: longint; - z4: word; - end; - - qpb_type = - record {Queue Parameter Block} - z: word; - qid: word; - nmsgs: integer; - buffer: word; - name: name_type; - end; - - var - uda_c, uda_b, uda_a: uda_type; {user data area for sub-process} - pd_c, pd_b, pd_a: pd_type; {process descriptor for sub-process} - qd: qd_type; {queue descriptor block} - qpb: qpb_type; {queue parameter block} - qmsg: qd_msg; {queue message} - done_c, done_b, done_a: boolean; {communication flags} - writ_c, writ_b, writ_a: boolean; - - external procedure init_mpm_util(size: integer); - external procedure fix_stack(taskp: ptr; - var uda: uda_type; - size: integer); - external procedure delay(ticks: integer); - external procedure dispatch; - external procedure terminate; - external function create_process(var pd: pd_type): boolean; - external function set_priority(priority: byte): boolean; - external function queue_make(var qd: qd_type): boolean; - external function queue_oper(op: byte; - var qpb: qpb_type): boolean; -{ - *********************************************************** -} - procedure startup(var pd: pd_type; - var uda: uda_type; - task: ptr; - name: string; - priority: integer; - size: integer); - var - i: integer; - p: pointer; - - begin - for i := 0 to pd_max do - pd.ray[i] := 0; - for i := 0 to uda_max do - uda[i] := 0; - - pd.prior := priority; - for i := 1 to 8 do - begin - pd.name[i] := name[i]; - pd.name2[i] := name[i] - end; - p.puda := addr(uda); - pd.uda := shr(p.off, 4); {make into paragraph address} - fix_stack(task, uda, size); - - if create_process(pd) then - writeln('Starting ', name) - else - writeln('Startup of ', name, ' failed'); - end; - - - function makeq(var qd: qd_type; {queue descriptor address} - var qpb: qpb_type; {queue parm block address} - name: name_type; {name of queue} - msglen: integer; {length of message in bytes} - nmsgs: integer) {max messages in queue} - : boolean; - - begin {make and open the main message queue} - qd.z1 := #0; {initialize queue descriptor} - qd.flags := 0; - qd.name := name; - qd.msglen := msglen; - qd.nmsgs := nmsgs; - qd.z2 := #0; - qd.z3 := #0; - qd.z4 := 0; - - if not queue_make(qd) then - begin - writeln('Unable to make queue'); - makeq := false - end - else - begin - qpb.z := 0; {initialize queue parameter block} - qpb.name := name; - if not queue_oper(q_open, qpb) then - begin - writeln('Unable to open queue'); - makeq := false - end - else - makeq := true; - end - end; - - - function read_msg(rm_qpb: qpb_type; {local copy of the q parm block} - var msgp: qd_msg) {where to send the message} - : boolean; - - var - p: pointer; - rm_msg: qd_msg; {local copy of message read} - - begin {read a message from a queue} - rm_qpb.nmsgs := 1; - p.pqdm := addr(rm_msg); - rm_qpb.buffer := p.off; {put offset of msg into qpb} - read_msg := queue_oper(q_read, rm_qpb); - msgp := rm_msg; {copy message to output} - end; - - - function write_msg(wm_qpb: qpb_type; {local copy of the q parm block} - wm_msg: qd_msg) {local copy of the message} - : boolean; - - var - p: pointer; - - begin {write a message to a queue} - wm_qpb.nmsgs := 1; - p.pqdm := addr(wm_msg); - wm_qpb.buffer := p.off; {put offset of msg into qpb} - write_msg := queue_oper(q_write, wm_qpb); - end; - - - procedure task_a; - - var - msg_a: qd_msg; - - begin - msg_a.count := 0; - msg_a.name := 'A-msg '; - - repeat - delay(31); - msg_a.count := msg_a.count + 1; - if not write_msg(qpb, msg_a) then - msg_a.count := 999; - until msg_a.count >= 9; - done_a := true; - terminate; - end; - - - procedure task_b; - - var - msg_b: qd_msg; - - begin - msg_b.count := 0; - msg_b.name := ' B-msg '; - - repeat - delay(19); - msg_b.count := msg_b.count + 1; - if not write_msg(qpb, msg_b) then - msg_b.count := 999; - until msg_b.count >= 9; - done_b := true; - terminate; - end; - - - procedure task_c; - - var - msg_c: qd_msg; - - begin - msg_c.count := 0; - msg_c.name := ' C-msg '; - - repeat - delay(25); - msg_c.count := msg_c.count + 1; - if not write_msg(qpb, msg_c) then - msg_c.count := 999; - until msg_c.count >= 9; - done_c := true; - terminate; - end; - - - begin {main program} - if not makeq(qd, qpb, 'MAIN QQQ', sizeof(qmsg), qd_nmsgs) then - exit; - if not set_priority(def_prior) then - begin - writeln('Unable to set main program priority'); - exit - end; - - done_a := false; done_b := false; done_c := false; - writ_a := false; writ_b := false; writ_c := false; - init_mpm_util(1500); - startup(pd_a, uda_a, addr(task_a), 'TASK_A ', def_prior, 1500); - startup(pd_b, uda_b, addr(task_b), 'TASK_B ', def_prior, 1500); - startup(pd_c, uda_c, addr(task_c), 'TASK_C ', def_prior, 1500); - delay(1); - - repeat - if not readmsg(qpb, qmsg) then - begin - writeln('Error trying to read queue'); - exit; - end; - writeln(qmsg.name, ' loop count = ', qmsg.count); - if done_a then - begin - writeln('TASK A completed'); - writ_a := true; - done_a := false; - end; - if done_b then - begin - writeln('TASK B completed'); - writ_b := true; - done_b := false; - end; - if done_c then - begin - writeln('TASK C completed'); - writ_c := true; - done_c := false; - end; - until writ_a and writ_b and writ_c; - - if not queue_oper(q_delete, qpb) then - writeln('Unable to delete queue'); - - end. - \ No newline at end of file diff --git a/software/CPM/CPM20_MTPUG_08/MPMTTIME.SRC b/software/CPM/CPM20_MTPUG_08/MPMTTIME.SRC deleted file mode 100644 index 7fb4331..0000000 --- a/software/CPM/CPM20_MTPUG_08/MPMTTIME.SRC +++ /dev/null @@ -1,54 +0,0 @@ -program ttime; {test new XIOS timing function, and GET_TOD} - - const - period = 90; {period in clock ticks - 1.5 seconds} - stack_size = $1000; {main program stack size} - - type - tod_type = - record - day: integer; - hour: byte; - min: byte; - sec: byte - end; - - var - t_entry: longint; - i: integer; - tod: tod_type; - - external procedure delay(ticks: integer); - external function x_time: longint; - external procedure get_tod(var tod: tod_type); - external procedure init_mpm_util(size: integer); - - begin - init_mpm_util(stack_size); - - repeat {do forever, ^C to stop} - t_entry := x_time; - writeln('x_time = ', t_entry); - - get_tod(tod); - with tod do - begin - write('day = ', day, ' time = '); - if hour < 10 then - write('0'); - write(hour, ':'); - if min < 10 then - write('0'); - write(min, ':'); - if sec < 10 then - write('0'); - writeln(sec); - end; - {other processing could go here} - - delay(period - short(x_time - t_entry)); - - until false; - - end. - \ No newline at end of file diff --git a/software/CPM/CPM20_MTPUG_08/MPMUTIL.DOC b/software/CPM/CPM20_MTPUG_08/MPMUTIL.DOC deleted file mode 100644 index 38bc2e7..0000000 --- a/software/CPM/CPM20_MTPUG_08/MPMUTIL.DOC +++ /dev/null @@ -1,533 +0,0 @@ -.FOMPMUTIL page # of 9 17 Jan 83 - MP/M UTILITY INTERFACE TO PASCAL MT+86 - - -MPMUTIÌ ió á packagå oæ interfacå routineó tï MP/M-8¶ froí Pascaì -MT+8¶  whicè allo÷ systeí timing¬  subtasë (subprocess©  control¬ -and MP/M queue operations. Its use is described in this memo. - - -1. Initialization - - external procedure init_mpm_util(size: integer); - -Iî  thå  maiî  program¬   therå  musô  bå  exactlù  onå  calì  tï -init_mpm_utiì beforå anù calló tï anù oæ thå otheò procedureó anä -functionó iî MPMUTIL®  Thå parameteò SIZÅ ió thå numbeò oæ byteó -tï  reservå foò stacë spacå iî thå maiî task®  Eacè subtasë  (iæ -any©  wilì  havå  itó owî amounô oæ stacë spacå tï  bå  reserved¬ -independenô oæ thå maiî tasë stack®  Init_mpm_utiì performó  alì -initialization needed by all of the other utilities. - - -2. Timing - - external function x_time: longint; - external procedure delay(ticks: integer); - -MP/Í  provideó severaì systeí calló tï geô thå timå oæ daù tï thå -nearesô  second®  Theså  twï procedureó providå  timinç  tï  thå -nearest clock tick (1/60 second). - -X_TIMÅ  returnó  thå currenô timå iî clocë tickó sincå  MP/Í  waó -lasô booteä in® Iô takeó faò lesó thaî ± mó tï calì XTIME¬ sincå -nï MP/Í calì ió involved®  Bù makinç á standarä MP/Í time-of-daù -call¬  thå  longinô returneä bù X_TIMÅ caî bå relateä tï timå  oæ -daù iæ needed® Itó maiî uså ió iî computinç elapseä timå betweeî -twï events®  Iæ thió elapseä timå ió lesó thaî 9.± minutes¬  thå -timå  iî  tickó wilì fiô iî á 16-biô integeò withouô settinç  thå -sigî  bit®  (Thå  Pascaì  MT« "short¢ functioî must bå  useä  tï -convert the longint difference of two calls to X_TIME.) - -DELAÙ  ió  calleä witè aî integeò representinç desireä  delaù  iî -clocë ticks®  Iæ TICKÓ ió lesó thaî oò equaì tï zero¬ therå wilì -bå nï delay®  Iæ 3276· ¼ TICKÓ ¼ 65536¬ thió lookó negative¬ anä -agaiî therå wilì bå nï delay®  3276· tickó ió abouô 9.± minutes® -Iæ ± <½ TICKÓ <½ 32767¬  aî MP/Í calì wilì bå madå requestinç thå -delay®  MP/Í wilì noô returî untiì aô leasô thaô manù tickó havå -occurred®  Iô  maù bå longer¬  dependinç oî prioritieó wheî  thå -requesteä timå haó elapsed® Tï geô delayó longeò thaî ¹ minutes¬ -makå consecutivå calló tï DELAY. - - -.cp23 Š3. Subtask control - - type - name_type = packed array[1..8] of char; - pd_type = - record - case boolean of - true: - (z1: packed array [1..5] of byte; - prior: byte; - flag: word; - name: name_type; - uda: word; - user, disk: byte; - z2: packed array [1..12] of byte; - cns: byte; - z3: packed array [1..3] of byte; - list: byte; - z4: packed array[1.15] of byte; - cns2: byte; - z5: byte; - name2: name_type); - false: - (ray: array [0..61] of byte) - end; {pd_type} - uda_type = array[0..255] of byte; - - external procedure fix_stack(taskp: ^integer; {kludge} - var uda: uda_type; - size: integer); - external function create_process(var pd: pd_type): boolean; - external function set_priority(prioritry: byte): boolean; - external procedure dispatch; - external procedure terminate; - external procedure abort(var pd: pd_type); - -Each subtask requires: - a Process Descriptor table (62 bytes) - a User Data Area table (256 bytes) for use by MP/M only - an execution priority - a name of 8 characters - some stack space - a starting address - -Thå  Procesó  Descriptoò anä Useò Datá Areá musô botè bå  iî  thå -globaì datá area¬ noô locaì procedurå data® Thå examplå programó -(seå especiallù TEST© sho÷ procedurå STARTUÐ aó á waù tï starô uð -á  task®  Thå  PÄ  showî herå ió largeò thaî showî  iî  thå  MPÍ -Programmer'ó  Guide»  iô haó 1´ extrá byteó foò uså bù thå  ABORÔ -procedure. - -.CP2 -Thå UDÁ foò eacè tasë must“ residå oî á paragrapè (16-byte©  boun -dary®  Thå  waù tï achievå thió ió tï declarå alì UDA'ó togetheò -aô  thå  beginninç oæ thå globaì datá areá oæ  thå  maiî  prograí -module¬ aó iî thå examples. Š -.CP2 -FIX_STACË   musô  bå  calleä  beforå  thå  tasë  ió  starteä   bù -CREATE_PROCESS® FIX_STACË reserveó stacë spacå foò thå task® Iô -ió calleä witè thå addresó oæ thå tasë entrù poinô (whicè wilì bå -á  procedure)¬  thå  Useò Datá Areá foò thå tasë (eacè tasë  musô -havå itó own)¬  anä thå amounô oæ stacë spacå tï reservå foò  thå -task. - -CREATE_PROCESÓ musô bå calleä immediatelù afteò FIX_STACK® Iô ió -passeä  thå Procesó Descriptoò tablå foò thå tasë (eacè tasë  haó -itó own)®  Thå PÄ ió firsô seô tï alì zeroes¬  anä theî initial -izeä aó follows: - - PRIOR is set to the desired initial task priority. - FLAG will normally be zero, but see MP/M call 144. - NAME  ió  seô tï thå 8-characteò tasë name®  Alì ¸ bitó  oæ -          each byte are significant. - UDA  ió  seô  tï thå offseô oæ thå UDÁ divideä  bù  1¶  (seå -          example). - USER, DISK¬  CNS¬  LISÔ  arå seô tï thå desireä defaulô useò -          number¬  disë  drive¬  consolå number¬  anä LSÔ  devicå -          number¬ iæ anù arå needed. (Normally 0.) - NAME2 is set to the same name as NAME. Used only by ABORT. - CNS2 is set to the same value as CNS. Used only by ABORT. - -FALSÅ  ió returneä iæ thå procesó coulä noô bå createä aó  speci -fied¬  whicè coulä bå duå tï toï manù processeó alreadù  created¬ -oò  á duplicatå procesó name¬  foò example®  TRUÅ ió returneä iæ -thå  procesó  waó successfullù  created®  Creatinç  thå  procesó -causeó iô tï begiî executioî accordinç tï itó priority. - -SET_PRIORITÙ  maù bå calleä aô anù timå bù anù tasë tï alteò  itó -owî priority®  Iô ió calleä witè thå desireä ne÷ prioritù level® -Seå thå discussioî oæ schedulinç anä prioritù below®  Iô returnó -FALSE if the priority could not be set, and TRUE otherwise. - -DISPATCÈ  ió  similaò tï DELAY(1)¬  iî thaô thå tasë  callinç  iô -giveó  uð thå CPÕ untiì itó nexô turî tï  execute¬  whereupoî  iô -continueó  executioî  aô thå instructioî followinç  thå  DISPATCÈ -call®  DELAY(1©  guaranteeó  thaô aô leasô onå clocë  ticë  wilì -occuò  beforå  thå  tasë  continues»   dependinç  oî  priorities¬ -DISPATCÈ maù returî controì immediately. - -TERMINATÅ  causeó  thå callinç tasë tï bå removeä froí  alì  MP/Í -lists¬  anä executioî oæ thaô tasë wilì stop®  Thaô is¬ therå ió -nï returî froí thå TERMINATÅ call® Nï tasë caî TERMINATÅ anotheò -(buô seå ABORT)¬  anä alì taskó musô bå terminateä  somehow®  Iî -particular¬  iæ á maiî tasë startó uð severaì subtasks¬  anä theî -terminateó  onlù itself¬  thå subtaskó wilì continuå tï exisô  iî -memorù  anä executå untiì explicitù terminated®  Re-bootinç MP/Í -wilì oæ courså terminatå everything. - -.CP2 -ABORÔ  ió similaò tï TERMINATE¬  excepô thaô á specifieä tasë  ió -terminated¬  whicè wilì usuallù noô bå thå callinç task®  Thå PÄ -oæ  thå tasë tï bå terminateä ió passeä tï ABORT®  Thå NAME² anä ŠCNS² fieldó musô bå seô tï matcè thå NAMÅ anä CNÓ fields¬  oò thå -procesó wilì noô bå aborteä -- althougè somå otheò procesó  mighô -be¡ ABORÔ allowó á maiî task¬ foò example¬ tï terminatå itó sub- -tasks when processing is complete. - - -.CP6 -4. Scheduling and Priority - -Therå  arå  25¶ possiblå prioritù leveló iî  MP/M®  Thå  highesô -("best"©  prioritù ió 0¬  anä thå lowesô ("worst"© ió  255®  Thå -followinç  ió á guidelinå foò establishinç prioritieó whicè  wilì -not conflict with MP/M usage: - -.CP3 - 002 - 031 Interrupt handlers - 200 Task initialization - 201 - 254 User tasks - -Everù tasë ió eitheò running¬  readù tï run¬  oò waitinç foò somå -event®  Onlù  onå tasë caî ruî aô anù onå time¬  sincå therå  ió -onlù onå CPU®  Taskó whicè arå ablå tï run¬ anä arå waitinç onlù -foò thå CPÕ arå "ready"®  "Waiting¢ taskó mighô bå waitinç foò á -systeí flag¬  foò á timå delaù tï elapse¬ oò foò á resourcå (con -sole¬ printer¬ disk© tï becomå available. - -Thå  MP/Í scheduleò ió calleä aô everù clocë tick¬  anä aô  everù -interrupt®  Thå  highest-prioritù "ready¢ tasë ió theî  resumed® -Iæ morå thaî onå tasë haó thå samå priority¬ theù arå executeä oî -á round-robiî basis. - -Exampleº  Taskó A¬  B¬  à arå aô prioritù 210¬  anä tasë Ø ió aô -prioritù 250» alì arå "ready"¬ anä tasë Á ió currentlù executing® -Aô  thå nexô tick¬  tasë Á wilì bå placeä aô thå enä oæ thå readù -lisô foò prioritù 210¬  anä tasë  wilì bå resumed®  Aô thå nexô -tick¬  tasë  Ã wilì bå resumed®  Theî tasë Á again¬  anä sï  on® -Tasë Ø wilì bå lockeä ouô untiì A¬  B¬  anä à arå alì waitinç foò -somethinç tï happen¬ sucè aó á delaù tï expire¬ oò á characteò tï -bå typeä aô thå console®  Notå thaô A¬  B¬  anä à caî interleavå -theiò  executioî  iæ  anù takeó morå thaî 1· mó  tï  executå  onå -cycle®  Iæ  interleavinç ió undesireable¬  thå runninç tasë  caî -raiså  itó  prioritù upoî entry¬  anä decreaså iô tï itó  nominaì -leveì aô thå enä oæ itó cycle®  Thió wilì guaranteå thaô Á  wilì -completå beforå  oò à geô executeä (unlesó Á goeó intï á waitinç -statå foò somå reason). - - -5. Stack Space - -Pascaì  MT+8¶  programó uså thå stacë foò passinç  parameteró  tï -procedureó anä functionó (includinç run-timå procedureó invisiblå -tï thå programmer)¬ foò temporarù storagå durinç compleø calcula -tions¬  anä  foò  storagå oæ locaì  variableó  (includinç  formaì -parameters© oæ procedureó anä functions. - -.CP2 -Iô  ió difficulô tï estimatå ho÷ mucè stacë spacå á prograí  wilì -need¬  aó  iô dependó oî thå (dynamic© deptè oæ procedurå nestinç Šaô ruî timå aó welì aó oî thå (static© factoró listeä above® Thå -linkeò  bù  defaulô assignó 8Ë byteó ($20° paragraphs©  oæ  stacë -spacå tï á program¬ unlesó thå /Ú switcè ió used® Unfortunately¬ -therå  ió  nï  reliablå  waù tï  telì  wheî  stacë  overflo÷  haó -occurred®  Thå  prograí  maù exhibiô bizarrå behaviour¬  oò  thå -systeí maù crasè entirely» thå computeò haó nï memorù protection. - -Iî anù event¬  afteò aî amounô oæ stacë spacå haó beeî decideä oî -foò  thå  maiî prograí anä eacè task¬  aó showî iî thå  calló  tï -init_mpm_utiì anä create_process¬  adä uð alì theså valueó tï geô -thå minimuí amounô oæ stacë spacå needed®  Converô thå totaì  tï -hexadecimal¬  droð thå finaì digiô (i.e.¬  dividå bù 16)¬ anä adä -± (foò round-up)®  Uså thió (oò á largeò value© aó thå numbeò oî -the linker /Z switch. - -Examplå 1º Prograí PROGÔ reserveó 150° byteó oæ stacë foò itselæ -anä  eacè oæ twï subtasks¬  foò á totaì oæ 4500®  Thió ió  $119´ -(hex)®  dividinç  bù  1¶ anä addinç ± giveó $120®  Thå  defaulô -linkeò  valuå oæ $20° ió biç enough¬  sï nï linkeò /Ú  switcè  ió -needed. - -.CP4 -Examplå 2º Á hypotheticaì prograí reserveó 1Ë byteó foò thå maiî -program¬  anä 3Ë byteó foò eacè oæ ¸ subtasks® Thió ió 25Ë deci -mal¬  oò $6400®  Thió ió biggeò thaî thå linkeò default¬  sï thå -linkeò commanä linå woulä looë something likå this: - -linkmô main,task1,task2,task3,...,task8,fpreals,paslib/s/z:640 - - -.CP14 -6. MP/M Message Queues - - type - name_type = packed array[1..8] of char; - qd_type = - record - z1: longint; - flags: word; - name: name_type; - msglen: integer; - nmsgs: integer; - z3, z2: longint; - z4: word - end; -.CP8 - qpb_type = - record - z: word; - qid: word; - nmsgs: integer; - buffer: word; - nameº name_type - end; - -.CP3 - external function queue_make(var qd: qd_type): boolean; - external function queue_oper(op: byte; - var qpb: qpb_type): boolean; Š -.CP2 -MP/Í  allowó anù reasonablå numbeò oæ messagå queueó oæ anù reas -onablå  sizå  tï bå dynamicallù createä anä  used®  Thå  maximuí -numbeò  oæ queueó activå aô onå time¬  anä thå  maximuí  combineä -sizå  oæ  alì  queueó activå aô onå timå ió seô  aô  MP/Í  systeí -generatioî time®  (Thió ió becauså thå queueó exisô iî MP/Í datá -space, not in program data space.) - -Á messagå queuå ió createä bù specifyinç itó name¬  thå sizå oæ á -message¬ anä thå capacitù oæ thå queuå iî messages® Anù tasë caî -writå  messageó  tï oò reaä messageó froí thå queuå  oncå  iô  ió -createä  anä opened®  (Á queuå needó á separatå "open¢ operatioî -performeä afteò iô ió created.© Messageó arå handleä strictlù oî -á first-in¬ first-ouô (FIFO© basis® Wheî writinç tï á queue¬ thå -tasë caî elecô tï waiô foò aî emptù messagå sloô tï becomå avail -able¬  oò havå thå writå requesô returî witè aî erroò indication® -Similarly¬ wheî readinç á queue¬ thå tasë caî elecô tï waiô foò á -messagå tï bå writteî intï thå queuå iæ iô ió empty¬  oò havå thå -reaä  requesô returî iî aî erroò condition®  Thå  queuå  handleò -knowó onlù abouô messagå size»  thå interpretatioî oæ messageó ió -lefô strictlù uð tï taskó whicè reaä anä writå thå messages. - -See example TESTQ for sample queue usage. - -.CP2 -QUEUE_MAKÅ  musô bå calleä oncå foò eacè queuå tï creatå it®  Iô -ió calleä witè á Queuå Descriptoò table®  Thå QÄ ió  initializeä -bù settinç thå "z¢ fieldó tï zero¬ FLAGÓ tï zerï (excepô seå MP/Í -manuaì  foò discussioî oæ Mutuaì Exclusioî Queues)¬  NAMÅ tï  thå -namå  oæ  thå queuå (alì ¸ bitó oæ alì ¸ byteó arå  significant)¬ -MSGLEÎ tï thå sizå oæ á messagå iî byteó (alì messageó iî á giveî -queuå  arå  thå samå size)¬  anä NMSGÓ tï thå queuå  capacitù  iî -messages® TRUÅ ió returneä iæ alì ió succesful¬ anä FALSÅ iæ thå -queuå namå ió duplicated¬  oò iæ therå ió noô enougè spacå iî thå -systeí datá areá tï creatå thå queue®  Thå queuå musô bå  openeä -viá  á calì tï QUEUE_OPEÒ beforå anù otheò operatioî caî bå  per -formeä oî it. - -QUEUE_OPEÒ  ió  á  general-purposå routinå tï perforí  alì  queuå -functionó otheò thaî makinç á queue® Iô ió calleä witè thå queuå -operatioî numbeò anä á Queuå Parameteò Block®  Thå queuå  opera -tioî numberó arå aó follows: - - 135 open queue - 136 delete queue - 137 read queue - 138 conditional read queue - 139 write queue - 140 conditional write queue - -.CP3 -TRUÅ ió returneä iæ thå requesteä operatioî ió successful® FALSÅ -ió  returneä iæ unsuccessful¬  oò iæ aî operatioî numbeò  outsidå -the above range is used. The operations are discussed below. - -.CP2 -OPEΠ QUEUÅ  ió  requireä oncå afteò thå queuå  ió  created¬  anä -beforå anù otheò operatioî ió performed®  Á QP musô bå initialŠizeä bù settinç Ú tï zerï anä NAMÅ tï thå namå oæ thå queue® Alì -¸  bitó oæ alì ¸ byteó oæ NAMÅ musô matcè thå NAMÅ fielä  iî  thå -Queuå Descriptoò useä tï creatå thå queue® Thå QIÄ fielä wilì bå -filleä  iî witè á queuå identifieò needeä foò furtheò operations® -Thå  QP musô bå preserveä foò uså iî furtheò  queuå  operations¬ -and so should probably be a global rather than local data item. - -DELETÅ QUEUÅ shoulä bå donå prioò tï terminatioî oæ thå lasô tasë -tï  uså thå queue®  Iæ alì taskó terminatå anä thå queuå ió  noô -deleted¬  succeedinç attemptó tï creatå thå queuå wilì fail¬  anä -MP/Í maù havå tï bå re-booteä tï cleaò ouô thå queue®  Á copù oæ -thå QP useä tï opeî thå queuå shoulä bå passeä tï QUEUE_OPER. - -REAÄ  QUEUÅ  musô  bå passeä á copù oæ thå QP useä tï  opeî  thå -queue®  NMSGÓ  iî  thå  QP copù musô bå seô tï  thå  numbeò  oæ -messageó  tï bå reaä froí thå queue®  BUFFEÒ musô bå seô tï  thå -addresó  oæ á datá iteí biç enougè tï holä NMSGÓ messageó (iæ  iô -ió toï small¬  adjacenô datá wilì bå over-written)® Iî addition¬ -thå  QP copù anä thå buffeò musô botè bå iî thå samå datá  area® -Thaô  is¬  botè musô bå globaì oò botè musô bå locaì datá oæ  thå -samå procedure®  Seå READ_MSÇ iî examplå TESTQ¬  wherå botè  arå -locaì  tï thå samå procedure®  TRUÅ ió returneä afteò NMSGÓ havå -beeî  reaä  froí thå queue®  Iæ noô enougè messageó arå  iî  thå -queuå aô thå timå oæ thå call¬  thå callinç tasë wilì bå puô iî á -"waiting¢  statå untiì enougè additionaì messageó arå writteî  tï -thå queue®  FALSÅ ió returneä iæ thå queuå ió noô opeî oò iæ  iô -haó beeî deleted. - -CONDITIONAÌ  REAÄ  QUEUÅ ió thå samå aó REAÄ  QUEUÅ  excepô  thaô -FALSÅ ió returneä iæ therå arå noô enougè messageó alreadù iî thå -queue» thaô is¬ iô doeó noô waiô foò thå messages. - -WRITÅ  QUEUÅ  musô bå passeä á copù oæ thå QP useä tï  opeî  thå -queue®  NMSGÓ  iî  thå  QP copù musô bå seô tï  thå  numbeò  oæ -messageó  tï  writå  tï thå queue®  BUFFEÒ musô bå  seô  tï  thå -addresó  oæ á datá iteí containinç NMSGÓ messages®  Iî addition¬ -thå  QP copù anä thå buffeò musô botè bå iî thå samå datá  area® -Thaô  is¬  botè musô bå globaì oò botè musô bå locaì datá oæ  thå -samå procedure®  Seå WRITE_MSÇ iî examplå TESTQ¬  wherå botè arå -locaì tï thå samå procedure®  TRUÅ ió returneä afteò NMSGÓ  havå -beeî  writteî  tï thå queue®  Iæ therå ió noô enougè  spacå  foò -NMSGÓ messageó iî thå queuå aô thå timå oæ thå call¬  thå callinç -tasë  wilì bå puô iî á "waiting¢ statå untiì enougè messageó  arå -reaä froí thå queuå tï makå room® FALSÅ ió returneä iæ thå queuå -ió noô opeî oò iæ iô haó beeî deleted. - -CONDITIONAÌ  WRITÅ QUEUÅ ió thå samå aó WRITÅ QUEUÅ  excepô  thaô -FALSÅ  ió  returneä iæ therå ió noô enougè rooí iî thå queuå  foò -NMSGÓ  messages»  thaô is¬  iô doeó noô waiô foò spacå tï  becomå -available. - - -.CP6 Š7. Raw Console Input - - external procedure r_con_raw(var str: string); - -Aô thió writing¬  readln“ froí thå KBDº devicå doeó noô worë prop -erly¬  anä  inpuô lineó froí thå CONº  devicå arå limiteä  tï  8° -characters¬  sï  thió extrá functioî ió includeä iî thå  package® -Iô  caî  bå  useä witè carå iî conjuctioî witè I/Ï  tï  thå  CONº -(default©  device®  Buô seå thå cautioî iî thå MT+8¶ manuaì sec -tioî 3.4.1¶ (discussioî oæ ASSIGN). - -R_CON_RA×  bypasseó thå MP/Í interpretatioî oæ consolå characteró -tï  providå  ra÷  consolå inpuô viá MP/Í  functioî  3®  Iô  alsï -bypasseó  alì  oæ thå Pascaì MT+8¶ filå I/O®  STÒ  ió  initiallù -cleareä  (lengtè bytå seô tï 0)®  Characteró arå reaä  froí  thå -consolå  anä  appendeä  tï STÒ -- includinç  controì  characters® -Wheî á CÒ ($0D© ió detected¬ iô ió noô writteî tï thå string¬ buô -R_CON_RAW returns at that point to the calling program. - -Thió  procedurå waó includeä tï providå á simplå waù oæ  usinç  á -consolå  iî Blocë Transmissioî mode¬  wherebù thå useò typeó  thå -'senä  page§ key¬  anä datá ió senô tï thå computeò witè  controì -characteró  delimitinç  fieldó anä lines¬  anä á finaì CÒ aô  thå -end. - -Cautionsº  - -a.   Iæ  thå terminaì sendó morå thaî onå CR¬  thå datá followinç -     thå  firsô CÒ maù bå lost¬  dependinç oî thå buffeò sizå  oæ -     thå  XIOÓ  consolå inpuô routine¬  systeí  timing¬  anä  thå -     consolå bauä rate. - -b.   Thå  maximuí strinç sizå undeò Pascaì MT« ió 25µ  bytes®  Á -     fulì consolå screeî ió typicallù 192° bytes®  Yoõ musô beaò -     thió iî mind®  Mosô consoleó witè blocë transmissioî  allo÷ -     thå sendinç oæ onlù thå unprotecteä fields¬  whicè musô theî -     bå  seô  uð  tï totaì lesó thaî 25µ byteó  (includinç  fielä -     separators). - -c.   Yoõ won'ô wanô tï uså thió procedurå foò manuaì input¬ sincå -     thå  backspacå  anä  otheò controló  characteró  arå  merelù -     transmitteä withouô interpretation® Furthermore¬ characteró -     typeä wilì noô bå echoeä tï thå screen. - -d. Characteró  maù bå losô wheî thå consolå ió operateä aô higè -     bauä   rates®   Characteró  will“  bå  losô  wheî  useä   iî -     conjunctioî  witè thå 808· matè library®  Thió  ió  becauså -     interruptó  musô  bå  disableä whilå thå 808·  ió  computinç -     undeò  thå  currenô versioî oæ MP/M®  Thió  probablù  makeó -     R_CON_RAW unusable. -      - -.CP9 Š8. Time of Day - - type - tod_rec = record - day: integer; - hour: byte; - min: byte; - sec: byte - end; - - external procedure get_tod(var tod: tod_rec); - -.CP3 -Thió procedurå implementó MP/Í calì 155¬  excepô thaô iô convertó -thå hour/min/seã fieldó tï binarù insteaä oæ BCD®  Thå fieldó iî -recorä TOÄ arå filleä iî aó follows: - - day = number of days since 1 Jan 1978 - hour = hour of the day, 0 to 23 (24-hour clock) - min = minute of the hour, 0 to 59 - sec = second of the minute, 0 to 59 - -Iæ yoõ neeä thå valueó iî BCÄ insteaä oæ straighô binary¬ yoõ caî -reconverô thå numberó iî thå callinç program¬ oò uså @BDOS86. -cmdtyp] ;Get GPL and DTL fields - sto ax,ciopb+7 ;Set GPL and DTL fields - sto #mrtry,rtry ;Initialize retry count -fnl1 ld al,ciopb+2 ;Get cylinder number - call doseek ;Seek to proper track - jnz fnl3 ;If seek error - ld ax,bufseg ;Get host buffer segment - ld cl,#4 ;Shift count - rol ax,cl ;Shift segment for absolute address - mov bx,ax ;Save lower 16 bits of paragraph - and al,#0fh ;Grab upper nibble of paragraph - and bx,#0fff0h ;Grab upper 12 bits of offset - add bx,bufadr ;Form 16 bit offset - adc al,#0 ;Propagate carry up to upper nibble - outb dma ;Msb of 24 bit address - mov al,bh ;Get middle byte of 24 bit address - outb dma ;Middle Byte of 24 bit address - mov al,bl ;Get lsb of 24 bit address - outb dma ;Lsb of 24 bit address - ld bx,#ciopb ;Address of command to execute - ld cx,#ciopl ;Set command buffer length - ld dx,#7 ;Length of status info - call exec ;Perform operation - sub ax,#8040h ;Check for errors - sto ah,erflag ;Set error flag - jz fnl4 ;If no errors -fnl3 decb rtry ;Get retry counter - jnz fnl1 ;If not permanent error - or al,#1 ;Set error condition - sto al,erflag ;Set error flag -fnl4 ret - endif - page -;**************************************************************** -;* * -;* HDFNL -- Hard disk final command processing. * -;* * -;**************************************************************** - - if hard -hdfnl call hdsel ;Select the hard disk unit - sto al,erflag ;Save error condition - jnz hdfnl2 ;If select error - stob #mrtry,rtry ;Set retry count - stob #mrtry,recal ;Set not recal on error -hdfnl1 call hdseek ;Seek to correct track - call hdxfer ;Perform hard disk transfer - sto al,erflag ;Save error condition - jz hdfnl2 ;If no errors - decb rtry ;Update error count - jnz hdfnl1 ;If attempts left - ld bl,actdsk ;Get current drive - ld bh,#0 ;Form 16 bit drive # - stob #-1,[bx+hdcyl] ;Force track zero seek - decb recal ;Check recalibrated attempt - jnz hdfnl1 ;If no recal attempt yet - or al,#1 ;Set error condition - sto al,erflag ;Save error condition -hdfnl2 ret -recal db 0 - endif - -rtry db 0 ;Storage for retry count - -;**************************************************************** -;* * -;* Command buffer disk type dependent values. * -;* * -;** \ No newline at end of file diff --git a/software/CPM/CPM20_MTPUG_08/MPMUTIL.I86 b/software/CPM/CPM20_MTPUG_08/MPMUTIL.I86 deleted file mode 100644 index 25f444d..0000000 --- a/software/CPM/CPM20_MTPUG_08/MPMUTIL.I86 +++ /dev/null @@ -1,546 +0,0 @@ -;MP/M Utility routines in assembly language to provide operations -; which are difficult or unavailable from Pascal MT+ -; -;Pascal MT+ definitions for procedures/functions in this package: -; -; external function create_process(pd_p: ^process_descriptor): boolean; -; external procedure delay(ticks: integer); -; external procedure dispatch; -; external procedure fix_stack(taskp: ^integer; -; udap: ^user_data_area; -; size: integer); -; external procedure init_mpm_util(size: integer); -; external function queue_make(qd_p: ^queue_descriptor): boolean; -; external function queue_oper(op: byte; -; qp_p: ^queue_parm_block): boolean; -; external function set_priority(priority: byte): boolean; -; external procedure terminate; -; external procedure abort(pd_p: ^process_descriptor); -; external function x_time: longint; -; external procedure r_con_raw(str: ^string); -; external procedure get_tod(tod: ^tod_record); -; external function who_am_i: ^process_descriptor; - - - name mpm_util - - assume cs: code, ds: data - -spoff equ 34h ;offset of sp in UDA -csoff equ 50h ;offset of cs in UDA -dsoff equ 52h ;offset of ds in UDA -esoff equ 54h ;offset of es in UDA -ssoff equ 56h ;offset of ss in UDA - -mpm_call equ 224 ;mpm call interrupt value - -mpm_read_raw equ 3 ;mpm read raw console function -mpm_bios equ 50 ;mpm direct BIOS call function -mpm_make_q equ 134 ;mpm make queue function -mpm_min_q equ 135 ;smallest mpm queue function code -mpm_max_q equ 140 ;largest mpm queue function code -mpm_delay equ 141 ;mpm delay function -mpm_dispatch equ 142 ;mpm dispatch function -mpm_terminate equ 143 ;mpm terminate function -mpm_create_p equ 144 ;mpm create process function -mpm_set_prior equ 145 ;mpm set priority function -mpm_get_sysdat equ 154 ;mpm get system data area addr fcn -mpm_get_tod equ 155 ;mpm get time of day -mpm_get_pd equ 156 ;mpm get process desc address -mpm_abort equ 157 ;mpm abort specified process fcn - - -data segment public - -stack_offset dw ? - -data ends - - -code segment public - - public delay, dispatch, terminate, abort, xtime - public createprocess, setpriority - public queuemake, queueoper - public fixstack, initmpmutil -; public whoami ;temp fix -- causes problem - public rconraw, gettod - - -;************************************************************************ -; PROCEDURE INIT_MPM_UTIL(SIZE: INTEGER) * -;Inputs: * -; Size of stack area to reserve for main program * -;Outputs: * -; None * -;Processing: * -; Internal initialization for FIX_STACK. INIT_FIX_STACK must be * -; called exactly once before any calls to FIX_STACK. It notes * -; amount of stack space to reserve for the main program. * -; Also sets up location of XIOS entry for X_TIME. * -;************************************************************************ - - -initmpmutil proc near - - pop dx ;return address - pop ax ;size - mov stack_offset,ax ;initialize offset with size - - push dx ;restore return address - push es ;save extra segment - - mov cl,mpm_get_sysdat ;get system data area address - int mpm_call ;... in es:bx - mov cx,es: word ptr 28h[bx] ;XIOS entry offset - mov dx,es: word ptr 2Ah[bx] ;...and segment - mov cs:xtoff,cx ;put into CALLF instruction - mov cs:xtseg,dx - - pop es ;restore extra segment - ret - -initmpmutil endp - - -;************************************************************************ -; PROCEDURE FIX_STACK(TASKP: ^INTEGER; * -; UDAP: ^USER_DATA_AREA; * -; SIZE: INTEGER); * -;Inputs: * -; Starting address of task * -; Address of User Data Area * -; Size of stack area to reserve for this task * -;Outputs: * -; None * -;Processing: * -; Puts segment registers in UDA table. Computes stack area to * -; use for this task, puts stack location in UDA table, * -; puts task address at stack location. Assumes small model. * -; Init must have been called first to set up 'offset' variable. * -;************************************************************************ - -fixstack proc near - - pop cx ;return address - pop ax ;size value - pop bx ;offset of UDA - pop dx ;segment of UDA (don't care) - push ax ;save size - - mov word ptr csoff[bx],cs ;store segment registers in UDA - mov word ptr dsoff[bx],ds - mov word ptr esoff[bx],es - mov word ptr ssoff[bx],ss - - mov ax,sp ;current stack pointer - sub ax,stack_offset ;subtract offset - mov word ptr spoff[bx],ax ;put new stack pointer in UDA - pop dx ;size - add stack_offset,dx ;new offset value for next time - - pop dx ;offset of task - pop bx ;segment of task (don't care) - push cx ;return address back on stack - - push bp - mov bp,ax ;get new stack offset - mov word ptr [bp],dx ;put task address at that location - pop bp - - ret ;all done - -fixstack endp - - -;************************************************************************ -; PROCEDURE DELAY(TICKS: INTEGER); * -;Inputs: * -; Number of clock ticks (1/60 second) to delay * -;Outputs: * -; None * -;Processing: * -; Calls MP/M delay function for given number of ticks. * -; If TICKS is 0 or negative (>32767) there is no delay. * -;************************************************************************ - -delay proc near - - pop bx ;return address - pop dx ;number of ticks - push bx ;save return address - cmp dx,0 - jle delend ;no delay if zero or negative - mov cl,mpm_delay - int mpm_call ;call mpm -delend: ret - -delay endp - - -;************************************************************************ -; PROCEDURE DISPATCH; * -;Inputs: * -; None * -;Outputs: * -; None * -;Processing: * -; Calls MP/M dispatch to allow scheduling of another task. * -;************************************************************************ - -dispatch proc near - - mov cl,mpm_dispatch - int mpm_call - ret - -dispatch endp - - -;************************************************************************ -; PROCEDURE TERMINATE; * -;Inputs: * -; None * -;Outputs: * -; None * -;Processing: * -; Calls MP/M function to terminate this task. * -;************************************************************************ - -terminate proc near - - mov cl,mpm_terminate - int mpm_call - ret - -terminate endp - - -;************************************************************************ -; PROCEDURE ABORT(PD_P: ^PROCESS_DESCRIPTOR); * -;Inputs: * -; Address of Process Descriptor table * -;Outputs: * -; None * -;Processing: * -; Calls MP/M function to abort the specified task. * -;************************************************************************ - -abort proc near - - pop ax ;return address - pop dx ;PD offset - pop bx ;PD segment - push ax ;save return address - push ds ;save current data segment - mov ds,bx ;ds of the PD - add dx,48 ;offset of the APB in the PD - mov cl,mpm_abort - int mpm_call ;call mpm to abort - pop ds ;restore ds - ret ;exit - -abort endp - - -;************************************************************************ -; FUNCTION X_TIME: LONGINT; * -;Inputs: * -; None * -;Outputs: * -; Time in ticks since system start * -;Processing: * -; XIOS is called directly to get at non-standard XIOS * -; call #4, implemented as misc extra calls in G&G XIOS. * -; 32-bit integer counter returned in bx, ax (Pascal longint) * -; INIT_MPM_UTIL must have been called first to set up XIOS entry. * -;************************************************************************ - -xtime proc near - - pushf ;save interrupt state - cli ;disable interrupts - mov al,4 ;XIOS call number - mov ch,10 ;extended call number - db 9Ah ;CALLF to XIOS -xtoff dw 0 ;time returned in dx,cx -xtseg dw 0 - popf ;restore interrupt state - - mov ax,cx ;time lsw - mov bx,dx ;time msw - ret ;return - -xtime endp - - -;************************************************************************ -; FUNCTION CREATE_PROCESS(PD_P: ^PROCESS_DESC): BOOLEAN; * -;Inputs: * -; Address of Process Descriptor table * -;Outputs: * -; True if success, False if failure * -;Processing: * -; Creates subtask for given Process Descriptor table. * -;************************************************************************ - -createprocess proc near - - pop ax ;return address - pop dx ;offset of PD - pop bx ;segment of PD - push ax ;save return address - push ds ;save current data segment - - mov ds,bx ;get PD segment - mov cl,mpm_create_p - int mpm_call ;call MP/M - pop ds ;restore ds - and ax,ax ;ax=0 if success - - jz cpok ;jump if success - xor ax,ax ;return 'False' - ret - -cpok: inc ax ;return 'True' - ret - -createprocess endp - - -;************************************************************************ -; FUNCTION SET_PRIORITY(PRIOR: BYTE): BOOLEAN; * -;Inputs: * -; Priority value to use * -;Outputs: * -; True if success, False if failure * -;Processing: * -; Sets current task priority to given value * -;************************************************************************ - -setpriority proc near - - pop ax ;return address - pop dx ;priority - push ax ;save return address - mov cl,mpm_set_prior - int mpm_call ;call MP/M - and ax,ax ;ax=0 if success - - jz spok ;jump if success - xor ax,ax ;return 'False' - ret - -spok: inc ax ;return 'True' - ret - -setpriority endp - - -;************************************************************************ -; FUNCTION QUEUE_MAKE(QD_P: ^QUEUE_DESCRIPTOR): BOOLEAN; * -;Inputs: * -; Address of Queue Descriptor table * -;Outputs: * -; True if success, False if failure * -;Processing: * -; Creates a queue according to Queue Descriptor table. * -;************************************************************************ - -queuemake proc near - - pop ax ;return address - pop dx ;offset of QD - pop bx ;segment of QD - push ax ;save return address - push ds ;save current data segment - - mov ds,bx ;get QD data segment - mov cl,mpm_make_q - int mpm_call ;call MP/M - pop ds ;restore ds - and ax,ax ;ax=0 if success - - jz qmok ;jump if success - xor ax,ax ;return 'False' - ret - -qmok: inc ax ;return 'True' - ret - -queuemake endp - - -;************************************************************************ -; FUNCTION QUEUE_OPER(OP: INTEGER; * -; QP_P: ^QUEUE_PARM_BLOCK): BOOLEAN * -;Inputs: * -; Operation code for a queue operation (135 - 140) * -; Address of Queue Parameter Block * -;Outputs: * -; True if success, False if failure * -;Processing: * -; Ensures OP is a queue operation other than make_queue. * -; Performs operation, returns status * -;************************************************************************ - -queueoper proc near - - pop ax ;return address - pop dx ;qpb offset - pop bx ;qpb segment - pop cx ;operation code - push ax ;return address back on stack - push ds ;save current data segment - - mov ds,bx ;get qpb segment - cmp cl,mpm_min_q ;validate op_code - jb qobad - cmp cl,mpm_max_q - ja qobad - int mpm_call ;op code ok - call MP/M - pop ds ;restore ds - and ax,ax ;check returned status - - jnz qobad ;jump if failed - inc ax ;return 'True' - ret - -qobad: xor ax,ax ;return 'False' - ret - -queueoper endp - - -;************************************************************************ -; PROCEDURE R_CON_RAW(STR: ^STRING) * -;Inputs: * -; Address of string to read into * -;Outputs: * -; Raw console input written to string * -;Processing: * -; Reads raw console input up to a CR. * -; Chars placed in STR, which must be big enough. CR not included.* -; Equivalent to READLN(KBD, STR) * -;************************************************************************ - -rconraw proc near - - pop ax ;return address - pop bx ;offset of string - push bx ;put them back - push ax - mov byte ptr [bx],0 ;set string length to 0 - -loop: mov cl,mpm_read_raw - int mpm_call ;read raw char from console - cmp al,0Dh ;is it cr? - je done ;exit if so - - pop dx ;return address - pop bx ;offset of string - push bx ;put them back - push dx - inc byte ptr [bx] ;bump string length byte - mov cl,byte ptr [bx] ;get length of string - mov ch,0 ;make 16 bits - add bx,cx ;addr of next character - mov byte ptr [bx],al ;store new character - jmp short loop ;repeat until done - -done: ret 4 ;exit, pop offset and segment - -rconraw endp - - -;************************************************************************ -; PROCEDURE GET_TOD(TOD: ^TOD_RECORD); * -;Inputs: * -; Address of TOD record: record * -; day: integer * -; sec, min, hour: byte * -; end * -;Outputs: * -; Record set as described below * -;Processing: * -; day set to number of days since Jan 1, 1978 * -; hour, min, sec set to binary value * -;************************************************************************ - -gettod proc near - pop ax ;return address - pop dx ;offset of tod record - pop cx ;...segment - push cx ;put back input data - push dx - push ax - push ds ;save current data segment - - mov ds,cx ;segment of tod record - mov cl,mpm_get_tod ;call mpm tod function - int mpm_call - - pop dx ;original data segment - pop ax ;return address - pop bx ;offset of tod record - pop ds ;...segment - push ax ;restore return address - push dx ;restore original data segment - add bx,2 ;point to hour byte - call todxlate ;translate from BCD to binary in place - inc bx ;point to minute byte - call todxlate - inc bx ;point to second byte - call todxlate - pop ds - ret - -gettod endp - -; translate in place from BCD to binary -; new = upper(old)*10 + lower(old) -; where 'upper' and 'lower' means nybble - -todxlate proc near - - mov al,byte ptr[bx] ;BCD value in al - mov dl,al - and dl,0Fh ;just lower nybble in dl - mov ah,0 - mov cl,4 - shr ax,cl ;just upper nybble in ax - mov cl,10 - mul cl ;upper * 10 in ax - add al,dl ;upper*10 + lower - mov byte ptr[bx],al ;store in place - ret - -todxlate endp - - -;************************************************************************ -; FUNCTION WHO_AM_I: ^PROCESS_DESCRIPTOR * -;Inputs: * -; None * -;Outputs: * -; Address of calling process's PD * -;Processing: * -; Returns PD address * -;************************************************************************ - -whoami proc near - - push es - mov cl,mpm_get_pd ;call mpm function - int mpm_call - mov bx,es ;segment address, offset in ax - pop es - ret - -whoami endp - - -code ends - - end - \ No newline at end of file diff --git a/software/CPM/CPM20_MTPUG_08/MPMUTIL.R86 b/software/CPM/CPM20_MTPUG_08/MPMUTIL.R86 deleted file mode 100644 index 224f258..0000000 Binary files a/software/CPM/CPM20_MTPUG_08/MPMUTIL.R86 and /dev/null differ diff --git a/software/CPM/CPM20_MTPUG_08/PASMAT.CMD b/software/CPM/CPM20_MTPUG_08/PASMAT.CMD deleted file mode 100644 index c3a392f..0000000 Binary files a/software/CPM/CPM20_MTPUG_08/PASMAT.CMD and /dev/null differ diff --git a/software/CPM/CPM20_MTPUG_08/PASMAT.COM b/software/CPM/CPM20_MTPUG_08/PASMAT.COM deleted file mode 100644 index 2063bb8..0000000 Binary files a/software/CPM/CPM20_MTPUG_08/PASMAT.COM and /dev/null differ diff --git a/software/CPM/CPM20_MTPUG_08/PASMAT.DOC b/software/CPM/CPM20_MTPUG_08/PASMAT.DOC deleted file mode 100644 index 4e1efbe..0000000 --- a/software/CPM/CPM20_MTPUG_08/PASMAT.DOC +++ /dev/null @@ -1,284 +0,0 @@ -.PN1 -.FOPASMAÔ pagå # - PASMAT User Manual - PAScal source-text reforMATer - A Public-Domain Program - Pascal MT+ Version - - -1. Introduction. - -Pasmaô  ió á utilitù whicè reformató á Pascaì sourcå prograí intï -á standarä format® Itó featureó include: - -a. Thå  prograí  maù bå converteä tï uniforí caså  conventions® -     Thió ió undeò thå controì oæ thå user. - -b. Thå prograí ió indenteä tï sho÷ itó logicaì  structure¬  anä -     wilì bå fiôted intï á specifieä outpuô linå length. - -c. Comment delimiters are all changed to '{ }'. - -d. Iæ requested¬ underscorå characteró wilì bå removeä froí thå -     identifieró foò uså oî systemó whicè dï noô supporô them. - -e.  Alì non-printinç characteró excepô foò tabó arå removed¬ anä -     thå  hi-biô oæ alì characteró ió turneä off®  Thió  caî  bå -     usefuì  afteò  glitcheó  witè somå editoró  -- notablù  wheî -     usinç WordStar. - -Thå  useò  haó considerablå controì oveò thå forí oæ  thå  outpuô -usinç "formatteò directives¢ inserteä iî á speciaì forí oæ Pascaì -comment. - -Pasmaô  acceptó fulì programs¬  modules¬  singlå procedures¬  anä -groupó oæ statments® Iô maù complaiî abouô arbitrarù collectionó -oæ  prograí fragments¬  sucè aó incompletå  procedures®  Wheî  á -syntaø erroò ió detected¬ Pasmaô copieó thå remaindeò oæ thå filå -unchangeä tï thå output®  Pasmaô acceptó alì oæ standarä Pascal¬ -pluó thå extensionó oæ Pascaì MT+. - - -2. Formatting Details. - -Iî general¬  thå formattinç ió straightforward¬  anä requireó  nï -controì  froí  thå  user®  Thå besô waù tï finä ouô  ho÷  Pasmaô -formató somethinç ió tï trù iô ouô anä see®  Therå are¬ however¬ -somå wayó iî whicè thå useò caî affecô thå formattinç rules¬  anä -thió sectionó coveró them. - -2.1 Comments. - -Commentó  iî Pascaì arå harä tï format¬  anä Pasmaô trieó  tï  bå -cleveò  abouô it®  Thå ruleó shoulä allo÷ yoõ tï uså commentó tï -achievå almosô anù effecô yoõ woulä like¬ buô yoõ dï havå tï kno÷ -thå rules®  Iæ yoõ finä thaô Pasmaô scrambleó youò comments¬ re- -read this section. - Š.CP2 -a. Á commenô whicè standó alonå oî á singlå linå wilì bå passeä -     tï thå outpuô unaltered®  Iô wilì havå itó lefô enä seô  tï -     thå  currenô indentatioî level¬  sï thaô iô wilì bå  aligneä -     witè thå statementó beforå anä afteò it®  Iæ iô ió toï lonç -     tï fiô witè thió alignment¬ iô wilì bå placeä oî thå pagå aó -     faò righô aó iô wilì go. - -b. Á  commenô  whicè beginó aó thå firsô thinç oî á  line¬  anä -     continueó  oî  anotheò line¬  wilì bå passeä tï  thå  outpuô -     unaltered¬  includinç thå indentation® Thió typå oæ commenô -     (á "blocë comment"© ió assumeä tï bå carefullù formatteä  bù -     thå author¬ anä sï ió untouched. - -c. Iæ á commenô whicè ió covereä bù onå oæ thå abovå ruleó wilì -     noô  fiô withiî thå defineä outpuô linå length¬  thå  outpuô -     linå wilì bå extendeä aó necessarù tï accomodatå thå commenô -     anä á messagå wilì bå written aô thå enä oæ thå formatting. - -d. Á  commenô  whicè ió noô thå firsô thinç oî á linå  wilì  bå -     formatteä  iî  witè thå resô oæ thå code®  Wordó withiî  iô -     wilì bå moveä arounä freelù tï makå iô fit¬ sï nothinç whicè -     haó  á fixeä formaô maù bå useä iî sucè á comment®  Sucè  á -     commenô  wilì bå brokeî onlù aô blanks¬  anä iæ therå ió  nï -     waù  tï breaë á commenô anä stilì fiô thå outpuô withiî  thå -     outpuô linå length¬ thaô linå wilì bå extendeä aó necessary¬ -     anä á messagå writteî aô thå enä oæ thå formatting. - -2.2 Statement Bunching. - -Thå  normaì  formattinç  ruleó foò á "case¢  statmenô  placå  thå -selecteä statmentó oî á separatå linå froí thå caså labels®  Thå -"B¢  directivå  (seå below© telló thå formatteò  tï  placå  theså -statementó oî thå samå linå aó thå caså labeló iæ iô wilì fit. - -Similarly¬  thå  ruleó  foò "if-then-else¢ placå  thå  controlleä -statementó  oî separatå lines®  Thå "B¢ directivå telló thå for -matteò tï placå thå controlleä statementó oî thå samå linå aó thå -"then¢ oò "else¢ iæ iô wilì fit. - -2.3 Tables. - -Iî  manù  Pascaì programó therå arå lonç listó oæ  initializatioî -statmentó  oò constanô declarationó whicè arå logicallù á  singlå -actioî  oò declaration®  Thå authoò maù wanô tï fiô theí intï aó -fe÷  lineó  aó possible®  Thå "S¢ directivå (seå  below©  allowó -this® Iæ thió ió used¬ thå equivalenô oæ taâ stopó arå seô uð oî -thå line¬  anä successivå statmentó oò constanô declarationó  arå -aligneä tï theså taâ stopó insteaä oæ beginninç oî ne÷ lines. - -Therå  wilì  alwayó bå aô leasô onå blanë betweeî  statementó  oò -constanô declarations¬  sï iæ taâ stopó arå seô uð aô everù char -acteò location¬ statementó wilì bå packeä oî á line. - -Structureä statementó whicè normallù formaô oî morå thaî onå linå -wilì noô bå affecteä bù thió directive. Š - -.CP4 -3. Usage. - -Pasmat is invoked as follows: - - pasmat - -pasmat myprog.src b:myprog.new b+r- o=72 - -Thió  wilì  uså  myprog.srã  froí thå  defaulô  drivå  aó  input¬ -producinç  á filå oî drivå  calleä myprog.ne÷ whicè containó thå -reformatteä program® Thå  optioî ió turneä on¬ thå Ò optionó ió -turned off, and the O option is set to 72. - - -4. Directives. - -Directiveó caî bå supplieä oî thå commanä linå aó above¬  anä caî -bå  includeä iî thå texô iî speciaì comments®  Thå speciaì  com -mentó havå thå form: - - {[directives] text} -or - {$ text [directives] text} - -The directives themselves are either switches or numeric. - -Switcè  directiveó  consisô oæ aî uppercaså oò  lowercaså  letteò -immediately followed by a '+' or '-'. Examples: B+, r- - -Numeriã  directiveó consisô oæ aî uppercaså oò lowercaså  letter¬ -an optional '=', and a number. Examples: O=72, s=2, t4 - -Multiplå  directiveó maù bå separateä bù commaó  oò  blanks¬  buô -blankó arå noô alloweä withiî á directive®  Portionó oæ á direc -tivå whicè arå malformeä oò unrecognizeä arå quietlù ignored. - Š.CP4 -Examples: - {[b+] turn on statement bunching} - {[o=79, s2] make line width 79, 2 statements per line} - {$Ð eject á pagå [r+Ý make reserveä wordó uppercase} - -But not: - {this will not be recognized [o=79] due to initial text} - -The recognized directives are as follows: - -B (Defaulô  B-©  B« specifieó thaô thå statemenô followinç  á -     "then¢ oò "else¢ oò caså labeì wilì bå puô oî thå samå  linå -     iæ  iô wilì fit®  Thió makeó á smalleò outpuô  file®  Somå -     finä  iô easieò tï read¬  somå don't®  Iô ió hardeò tï makå -     corrections. - -C (Numeric¬  defaulô C=1© Thió specifieó thå numbeò oæ blankó -     precedinç  anä followinç inlinå comments®  Iæ therå ió  noô -     enougè  rooí  oî  á giveî linå foò à spaceó  precedinç  thå -     comment¬ Ô spaceó wilì bå used (seå below©. - -F (Defaulô F+© Turnó formattinç oî (+© oò ofæ (-)¬ commencinç -     oî thå linå afteò thå directivå iî whicè iô ió placed® Thió -     ió  usefuì foò preservinç carefullù hand-formatteä  sectionó -     oæ á program. - -L (Defaulô  L-© L« specifieó thaô thå caså oæ reserveä  wordó -     anä identifieró ió á literaì copù oæ thå input®  Thió over -     rideó  thå 'R§ anä 'U§ directives®  Thió directivå ió  dis -     ableä bù thå 'P§ directive. - -O (Numeric¬  defaulô  O=72©  Thió specifieó thå widtè oæ  thå -     outpuô line®  Thå maximuí valuå alloweä ió 13²  characters® -     Iæ  á particulaò iteí wilì noô fiô iî thió width¬  thaô linå -     wilì bå wideneä anä á warninç messagå wilì bå issued. - -P (Defaulô  P-© P« specifieó "portabilitù  mode¢  formatting¬ -     whicè  removeó  underscorå (_© characteró froí  identifiers® -     Thå  firsô letteò oæ eacè identifier¬  anä thå firsô  letteò -     followinç eacè underscorå wilì bå iî uppercase® Thå remain -     inç characteró wilì bå iî lowercase® Thió overrideó thå 'L§ -     anä  'U§ directives®  Thå caså oæ reserveä wordó  ió  unaf -     fecteä bù 'P§ (iô ió seô witè 'R'). - -Q (Defaulô Q-© Q« specifieó quieô mode¬  iî whicè alì consolå -     messageó arå suppressed¬ includinç alì erroò messages® Thió -     ió usefuì iî detacheä modå undeò MP/M. - -R (Defaulô  R-© R« specifieó thaô alì reserveä wordó wilì  bå -     in all uppercase. R- sets all reserved words to lowercase. - -.CP2 -S (Numeric¬  defaulô S=1© Specifieó thå numbeò oæ statementó -     peò line®  Thå spacå froí thå currenô indentatioî leveì  tï -     thå  enä oæ thå linå ió divideä intï equaì pieces¬  anä suc -     cessivå  statementó arå starteä aô thå boundarù oæ  á  piecå Š     (likå tabbinç oî á typewriter)®  Á statemenô whicè wilì noô -     fiô  oî  onå linå wilì noô bå affected¬  buô  thå  followinç -     statementó  maù looë strange®  Thió directivå affectó  onlù -     thå  constanô  declaratioî anä statemenô portionó oæ á  pro -     gram¬ anä ió intendeä foò uså iî intializinç variables. - -.CP4 -T (Numeric¬  defaulô  T=2© Specifieó thå amounô tï "tab¢  foò -     eacè  indentatioî  level®   Statementó  whicè  continuå  oî -     successivå  lineó wilì bå additionallù indenteä bù halæ thió -     amount. - -U (Defaulô U-© U« specifieó thaô identifieró arå converteä tï -     uppercase®  Theù wilì otherwiså bå converteä tï  lowercase® -     This directive is overridden by the 'L' and 'P' directive. - - -5. Limitations. - -a. Maximum input line length is 132 characters. - -b. Maximum output line length is 132 characters. - -c. Only syntactically correct programs can be formatted. - -d. Inpuô  fileó  arå currentlù limiteä tï  32Ë  bytes®  Largeò -     fileó  wilì  causå aî internaì counteò tï overflo÷ anä  ter -     riblå thingó tï happen. - - -6. Errors Detected and Reported. - -a. Anù detecteä syntaø erroò iî thå codå wilì causå thå format -     tinç tï abort¬ witè á messagå tï thå console® Thå remaindeò -     oæ  thå filå wilì bå copieä unchanged®  Thå syntaø checkinç -     ió noô complete¬  meaninç that Pasmaô wilì allo÷ somå thingó -     thaô  thå compileò wilì not®  Iæ possible¬  uså thå  syntaø -     checkeò  iî thå Speeä Programminç Packagå tï  verifù  syntaø -     beforå runninç Pasmat, to avoid formatter aborts. - -b. Therå  ió á limiô to thå numbeò oæ indentatioî leveló Pasmaô -     caî  handle¬  buô iô shoulä bå ablå tï handlå anythinç  thaô -     Pascaì MT« caî handle® Iæ thå limiô ió exceeded¬ processinç -     will be aborted. This should never happen. - -c. Iæ á commenô woulä requirå morå thaî thå maximuí outpuô linå -     lengtè (132)¬ processinç wilì bå aborted® Thió shoulä neveò -     happen. - -d. Iæ á tokeî (identifieò oò string© ió toï lonç foò thå outpuô -     linå length¬  thå lengtè wilì bå extendeä foò thaô line®  Á -     messagå wilì writteî tï thå consolå aô thå enä oæ processinç -     givinç thå numbeò oæ timeó thió occurreä anä thå linå numbeò -     oæ thå firsô occurrence. - -.CP2 Še. Iæ  á commenô linå ió extendeä accordinç tï rulå "c¢ iî  thå -     commentó  sectioî above¬  á messagå wilì bå writteî  tï  thå -     consolå  aô  thå enä oæ thå formattinç givinç thå numbeò  oæ -     timeó thió occurreä anä thå outpuô linå numbeò oæ thå  firsô -     occurrence. - - \ No newline at end of file diff --git a/software/CPM/CPM20_MTPUG_08/PMTEST.TST b/software/CPM/CPM20_MTPUG_08/PMTEST.TST deleted file mode 100644 index 781c9a4..0000000 --- a/software/CPM/CPM20_MTPUG_08/PMTEST.TST +++ /dev/null @@ -1,84 +0,0 @@ -prOGram test; -cOnst lOw=1; hIGh=10; -aaa='aaa';bbb='bbb';ccc=-32;ddd=$abcd;eee=#1234; -type -fyle = file Of packed array[1..1023] Of char; -natural = 1..maxint; -maintype = (little, medium, larGe); -midtype = (lO, med, hI); -biGtype = (One, twO, three); -cOmplicated = packed array [-1..$1] Of -recOrd -case distinGuish: maintype Of -little: (lray: array[1..2] Of -recOrd -i1, i2, i3: inteGer; -f: file Of packed array[1..10] Of real; -end); -medium: (mrec: -recOrd -mrecx,mrecy: char; -mrecray: array[19..21] Of -recOrd -a1,b1,c1: char; -d1,e1: array[38..40] Of byte; -case mid: midtype Of -lO: (x11,y11: real); -med: (x12,y12,z12: inteGer); -hI: (w13,x13,y13,z13: byte) -end -end); -larGe: (mlaray: array[1..2] Of -recOrd -a2,b2,c2,d2,e2: real; -f2,G2,h2: inteGer; -case biG: biGtype Of -One: (brecO: recOrd -brecOray: array[10..12] Of real; -w21,x21,y21,z21: inteGer -end); -twO: (brayt: array[-4..4] Of recOrd re,im:real end); -three: (brec3: recOrd -brec3ray: array[48..50,-3..-1] Of -recOrd -a23,b23,c23: strinG[2]; -br3rayray: array[maintype] Of real; -w23,x23,y23: wOrd -end; -t23,u23,v23: strinG[2]; -end) -end) -end; -var -ff: file; -aa,bb,cc,dd:byte; -ww,xx,yy,zz:bOOlean; -x: external recOrd a,b: real; c,d: inteGer end; -y: absOlute [23] inteGer; -z: absOlute [hIGh] real; -w: absOlute [$3A6] byte; -UGH: COMPLICATED; - -external prOcedure interrupt [36] intp1; -external prOcedure interrupt [lOw] intp2; -external prOcedure interrupt [$EF1] intp3; -prOcedure interrupt [17] intp4;beGin -aa:=bb;bb:=cc;cc:=dd;dd:=aa;ww:=xx;xx:=yy;yy:=zz;zz:=ww;end; -prOcedure test_cOn_fOrm(var a: array[lOwb..hIGhb:natural] Of inteGer); -var i:inteGer; -beGin FOR i := lOwb tO hIGhb div 2 dO -a[i] := x.c; a[i*2] := x.d; -if ww and xx then yy:=zz else zz:=yy; -aa:=~((aa|bb)&(cc!dd))!(?aa);end; -beGin {main prOGram} -with x dO -if a 0 THEN - BEGIN - ASSIGN(INFILE, FILENAME ); - RESET(INFILE) - END; - OPENERRNUM := IORESULT; - OPENOK := ( OPENERRNUM <> 255 ); - IF NOT OPENOK THEN - WRITELN( '*** INPUT OPEN ERROR # ', OPENERRNUM ); - UNTIL OPENOK; - - WRITE('Output file name? '); - READLN(LSTFILENAME); - TOCONSOLE := (LSTFILENAME = 'CON:'); - ASSIGN(LST,LSTFILENAME); - REWRITE(LST); - - WRITE( 'Do you want a listing (Y/N)? ' ); - READ( LISTOPTION ); - LISTING := (LISTOPTION <> 'N') AND (LISTOPTION <> 'n'); - IF LISTING THEN - PUTNUMBER(0); - READLN(INFILE,INPUT_LINE); - LINECOUNT := 0; - INLINEP := 1; - WRITELN; -END; (* OPENFILES *) - -{$P} -PROCEDURE LPWRITELN; -VAR - I : INTEGER; - CH : CHAR; -BEGIN - WRITELN(LST,BUF); - BUF[0] := CHR(0); - LINECOUNT := LINECOUNT+1; - IF (LINECOUNT MOD 60) = 0 THEN - PAGE(LST); -END; - -{$P} -PROCEDURE PUTALFA(S:ALFA); -BEGIN - MOVELEFT(S[1], BUF[ORD(BUF[0])+1], 8); - BUF[0] := CHR(ORD(BUF[0]) + 8); -END; - - - -PROCEDURE PUTNUMBER(NUM: INTEGER); -VAR I,IPOT: INTEGER; - A: ALFA; - CH: CHAR; - ZAP: BOOLEAN; - -BEGIN - ZAP := TRUE; - IPOT := 10000; - A[1] := ' '; - FOR I := 2 TO 6 DO - BEGIN - CH := CHR(NUM DIV IPOT + ORD('0')); - IF I <> 6 THEN - IF ZAP THEN - IF CH = '0' THEN - CH := ' ' - ELSE - ZAP := FALSE; - A[I] := CH; - NUM := NUM MOD IPOT; - IPOT := IPOT DIV 10; - END; - A[7] := ' '; - MOVELEFT(A, BUF[ORD(BUF[0])+1], 7); - BUF[0] := CHR(ORD(BUF[0]) + 7); -END; - -{$P} -PROCEDURE GETNEXTCHAR; -BEGIN - - IF INLINEP = LENGTH(INPUT_LINE)+1 THEN - BEGIN - CH := ' '; {DUMMY EOL CHARACTER} - INLINEP := INLINEP + 1; {NEXT TIME THRU WILL READ NEW LINE} - EXIT - END; - - IF INLINEP > LENGTH(INPUT_LINE) THEN - BEGIN - READLN(INFILE,INPUT_LINE); - INLINEP := 2; - LINECOUNT := LINECOUNT + 1; - IF LENGTH(INPUT_LINE) > 0 THEN - CH := INPUT_LINE[1] - ELSE - BEGIN - CH := ' '; - IF EOF(INFILE) THEN - ALLDONE := TRUE; - END; - IF LISTING THEN - BEGIN - IF NOT TOCONSOLE THEN - WRITE('.'); - WRITELN(LST,BUF); - BUF[0] := CHR(0); - PUTNUMBER(LINECOUNT); - END - ELSE - WRITE('.'); - IF (LINECOUNT MOD 60) = 0 THEN - BEGIN - IF LISTING THEN - PAGE(LST); - WRITELN('< ',LINECOUNT:4,', ',MEMAVAIL:5,' >'); - END - END - - ELSE - BEGIN - CH := INPUT_LINE[INLINEP]; - INLINEP := INLINEP + 1; - END; - - IF LISTING THEN - BEGIN - BUF[0] := CHR(ORD(BUF[0]) + 1); - BUF[BUF[0]] := CH; - END; - -END; (* GETNEXTCHAR *) - -{$P} - -PROCEDURE SEARCH( ID: ALFA ); -(*MODULO P HASH SEARCH*) (*GLOBAL: T, TOP*) -VAR - I,J,H,D : INTEGER; - X : ITEMPTR; - F : BOOLEAN; - -BEGIN - J := 0; - FOR I := 1 TO ALFALEN DO - J := J*10+ORD(ID[I]); - H := ABS(J) MOD P; - F := FALSE; - D := 1; - REPEAT - IF T[H].KEY = ID THEN - BEGIN (*FOUND*) - F := TRUE; - IF T[H].LAST^.REFNUM = REFSPERITEM THEN - BEGIN - NEW(X); - X^.REFNUM := 1; - X^.REF[1] := LINECOUNT; - T[H].LAST^.NEXT := X; - T[H].LAST := X; - END - ELSE - WITH T[H].LAST^ DO - BEGIN - REFNUM := REFNUM + 1; - REF[REFNUM] := LINECOUNT - END - END - ELSE - IF T[H].KEY = ' ' THEN - BEGIN (*NEW ENTRY*) - F := TRUE; - NEW(X); - X^.REFNUM := 1; - X^.REF[1] := LINECOUNT; - T[H].KEY := ID; - T[H].FIRST := X; - T[H].LAST := X; - T[H].FOL := TOP; - TOP := H - END - ELSE - BEGIN (*COLLISION*) - H := H+D; - D := D+2; - IF H >= P THEN - H := H - P; - IF D = P THEN - BEGIN - WRITELN('ITEM TABLE OVERFLOW'); - ALLDONE := TRUE - END; - END - UNTIL F OR ALLDONE -END (*SEARCH*) ; - -{$P} - -PROCEDURE PRINTWORD(W: WORD); -VAR - L: INTEGER; - X: ITEMPTR; - NEXTREF : INTEGER; - THISREF: NUMREFS; -BEGIN - PUTALFA(W.KEY); - X := W.FIRST; - L := 0; - REPEAT - IF L = REFSPERLINE - THEN - BEGIN - L := 0; - LPWRITELN; - PUTALFA(' '); - END ; - L := L+1; - THISREF := (L-1) MOD REFSPERITEM + 1; - NEXTREF := X^.REF[THISREF]; - IF THISREF = X^.REFNUM THEN - X := NIL - ELSE - IF THISREF = REFSPERITEM THEN - X := X^.NEXT; - PUTNUMBER(NEXTREF); - UNTIL X = NIL; - LPWRITELN; -END (*PRINTWORD*) ; - -{$P} -PROCEDURE PRINTTABLE; - -VAR - I,J,M: INDEX; - -BEGIN - LINECOUNT := 0; - BUF[0] := CHR(0); - I := TOP; - WHILE I <> P DO - BEGIN (*FIND MINIMAL WORD*) - M := I; - J := T[I].FOL; - WHILE J <> P DO - BEGIN - IF T[J].KEY < T[M].KEY THEN - M := J; - J := T[J].FOL - END ; - PRINTWORD(T[M]); - IF M <> I THEN - BEGIN - T[M].KEY := T[I].KEY; - T[M].FIRST := T[I].FIRST; - T[M].LAST := T[I].LAST - END; - I := T[I].FOL - END -END (*PRINTTABLE*) ; - -{$P} -PROCEDURE GETIDENTIFIER; -VAR - J,K,I: INTEGER; - ID: ALFA; - MATCH: BOOLEAN; - -BEGIN (* GETIDENTIFIER *) - I := 0; - ID := ' '; - - REPEAT - IF I < ALFALEN THEN - BEGIN - I := I+1; - IF ('a' <= CH) AND (CH <= 'z') THEN - ID[I] := CHR( ORD(CH) - ORD('a') + ORD('A') ) - ELSE - IF CH = '_' THEN - I := I-1 {DISCARD UNDERSCORE} - ELSE - ID[I] := CH - END; - GETNEXTCHAR - UNTIL NOT (CH IN IDENTSET); - - I := 1; - J := NK; - - REPEAT - K := (I+J) DIV 2; (*BINARY SEARCH*) - IF KEY[K] <= ID THEN - I := K+1; - IF KEY[K] >= ID THEN - J := K-1; - UNTIL (I > J); - - IF KEY[K] <> ID THEN - SEARCH(ID); - -END; (* GETIDENTIFIER *) - -{$P} -BEGIN (* CROSSREF *) - - INITIALIZE; - OPENFILES; - - REPEAT - - IF CH IN IDENTSET THEN - GETIDENTIFIER - - ELSE - IF (CH = '''') THEN {SCAN OFF LITERAL STRING} - BEGIN - REPEAT - GETNEXTCHAR; - UNTIL (CH = '''') OR ALLDONE; - GETNEXTCHAR; - END - - ELSE - IF CH = '(' THEN {SCAN OFF (*...*) COMMENT} - BEGIN {FAILS ON (*)...*) } - GETNEXTCHAR; - IF CH = '*' THEN - BEGIN - GETNEXTCHAR; - WHILE (CH <> ')') AND (NOT ALLDONE) DO - BEGIN - WHILE (CH <> '*') AND (NOT ALLDONE) DO - GETNEXTCHAR; - GETNEXTCHAR; - END; - GETNEXTCHAR; - END; - END - - ELSE - IF CH = '{' THEN (* SCAN OFF {...} COMMENT *) - BEGIN - REPEAT - GETNEXTCHAR - UNTIL (CH = '}') OR ALLDONE; - GETNEXTCHAR; - END - - ELSE - GETNEXTCHAR; - - UNTIL ALLDONE; - - PAGE(LST); - PRINTTABLE; - PAGE(LST); - CLOSE(LST,I); - IF I = 255 THEN - WRITELN('Error closing output file'); - -END. - - \ No newline at end of file diff --git a/software/CPM/CPM20_MTPUG_08/SERIO.SRC b/software/CPM/CPM20_MTPUG_08/SERIO.SRC deleted file mode 100644 index 1f84840..0000000 --- a/software/CPM/CPM20_MTPUG_08/SERIO.SRC +++ /dev/null @@ -1,89 +0,0 @@ -module serio; -{ - A set of procedures and functions for the Apple II version of CP/M - which do I/O via 'COMM' cards (or their equivalent) put into various - slots. -} - -const slot = 2; { slot card is in } - base = $E08E; { base address for ACIA's } - -procedure poke(ch:byte;add:integer); -{ - Puts 'ch' into the absolute address, 'add' -} - -begin - inline ("LDA / ch / - "LHLD / add / - $77 ); { MOV M,A } -end; - -function peek (add:integer): byte; -{ - Returns the value of the byte located at the absolute address, 'add' -} - -var value:integer; - -begin - inline ( "LHLD/ add / - $7E / { MOV A,M } - "STA / value ); - peek := value; -end; - -procedure initac; -{ - Initializes the ACIA in the slot -} - -var status: integer; - -begin - status := base + slot *16; - inline ("LHLD/ status / - $3E / $03 / { MVI A,03 } - $77 / { MOV M,A } - $3E / $11 / { MVI A,11 } - $77 ); { MOV M,A } -end; (* initac *) - -function serin: char; -{ - Returns the byte which has just been received. - NOTE: it will stay forever in this routine if a byte has NOT been received -} - -const rxmask = $01; { mask for receive buffer full } - -var status, - data: integer; - -begin - status := base + slot*16; - data := status+1; - repeat until (peek(status) & rxmask ) <> 0; - serin := peek( data ); -end; - -procedure serout(ch: char); -{ - Sends the character, 'ch', out -} - -const txmask=$02; { mask for transmit buffer empty } - -var data, - status: integer; - - -begin - status := base + 16*slot; - data := status + 1; - repeat until (peek(status) & txmask ) <> 0; - poke (ch,data); -end; (* serout *) - -modend. - \ No newline at end of file diff --git a/software/CPM/CPM20_MTPUG_08/TESTGR.SRC b/software/CPM/CPM20_MTPUG_08/TESTGR.SRC deleted file mode 100644 index e393fe3..0000000 --- a/software/CPM/CPM20_MTPUG_08/TESTGR.SRC +++ /dev/null @@ -1,179 +0,0 @@ -PROGRAM testgr (input, output); - (*------------------------------------------------------------------*) - (* File : TESTGR.P on Prog Store 1 *) - (* *) - (* Written Mar 25,'82 by Jack Gilmer *) - (* *) - (* Modified to MT+ Pascal, J.A. Koehler, 23 Nov., 1982 *) - (* *) - (* This program calls routines defined in a graphics library such *) - (* as DMP.ERL and GRHP.ERL, and plots a border, then exercises *) - (* various options, etc. It makes a hard copy on hard copy devices, *) - (* (such as the DMP-2 plotter) or just the CRT if the package is *) - (* for a CRT oriented device (such as the ADM3) plus a hard copy *) - (* *) - (*------------------------------------------------------------------*) - - CONST - radian = 57.2958; - - - TYPE - astringtype = string[132]; - - aendtype = (noend, point, square, triangle, cross, ecks, diamond, - circle); - - alinetype = (noline, solid, dotted, dashed, dotdashed, - dotdotdashed); - - apointtype = RECORD (* absolute position in millimeters *) - x, - y: REAL; - END; - - VAR - - lineend: aendtype; - - sinewave: alinetype; - - ms, - mx, - my, - origin, - temp: apointtype; - - index, - xval: INTEGER; - - str: astringtype; - - EXTERNAL PROCEDURE adefault; - EXTERNAL PROCEDURE ainit; - EXTERNAL PROCEDURE aplot(endpoint: apointtype); - EXTERNAL PROCEDURE asetplot(line: alinetype; - repeatlength, - endsize: REAL; - endsymbol: aendtype); - EXTERNAL PROCEDURE asetstr(charheight, - charwidth, - charangle, - charspace, - strangle: REAL); - EXTERNAL PROCEDURE asetwindow(lowerleft, - upperright: apointtype); - EXTERNAL PROCEDURE asize(VAR size: apointtype); - EXTERNAL PROCEDURE astr(str: astringtype); - EXTERNAL PROCEDURE atext; - EXTERNAL PROCEDURE awhere(VAR where: apointtype); - - - - - BEGIN (* testgr *) - ainit; (* set it up *) - asize(ms); (* get screen size *) - origin.x := 0; (* set corners *) - origin.y := 0; - mx := origin; - mx.x := ms.x; - my := origin; - my.y := ms.y; - - asetplot(solid, 0, 0, noend); (* draw border *) - aplot(mx); - aplot(ms); - aplot(my); - aplot(origin); - - asetplot(noline, 0, 0, noend); - temp.x := ms.x * 0.05; - temp.y := ms.y * 0.95; - aplot(temp); - - str := 'Default size and direct. '; - - astr(str); - - temp.y := ms.y * 0.8; - aplot(temp); - asetstr(5, 1.5, -30, 1.6, -30); - str := 'Tall, narrow characters. '; - - astr(str); - - temp.y := ms.y * 0.65; - aplot(temp); - asetstr(1, 5, 30, 5.1, 30); - str := 'Short, fat characters.'; - - astr(str); - - temp.x := 0; (* draw sine waves - move to start *) - temp.y := ms.y / 2.0; - asetplot(noline, 0, 0, noend); - aplot(temp); - FOR sinewave := solid TO dotted DO - BEGIN - asetplot(sinewave, 5.0, 0, noend); - FOR xval := 1 TO 36 DO - BEGIN - temp.y := (ms.y / 2.0) + - (sin(xval * 10.0 / radian) * ms.y / 3.0); - aplot(temp); - temp.x := temp.x + (ms.x / 72.0); - END; (* FOR xval *) - END; (* FOR sinenum *) - - temp := origin; (* display end types available *) - temp.y := ms.y / 10.0; - asetplot(noline, 0, 0, noend); - aplot(temp); - FOR lineend := noend TO circle DO - BEGIN - asetplot(noline, 0, 2.0, lineend); - temp.x := temp.x + (ms.x / 16.0); - aplot(temp); - END; (* FOR lineend *) - FOR lineend := diamond DOWNTO noend DO - BEGIN - asetplot(solid, 0, 2.5, lineend); - temp.x := temp.x + (ms.x / 16.0); - aplot(temp); - END; (* FOR lineend *) - - origin.x := ms.x * 0.4; (* draw small window *) - origin.y := ms.y * 0.75; - ms.x := ms.x * 0.6; - ms.y := ms.y * 0.9; - asetplot(noline, 0, 0, noend); - aplot(origin); - - temp := origin; - temp.x := ms.x; - asetplot(dotted, 5.0, 0, noend); - aplot(temp); - - asetplot(dotdashed, 10.0, 0, noend); - aplot(ms); - - temp := origin; - temp.y := ms.y; - asetplot(dotdotdashed, 15.0, 0, noend); - aplot(temp); - - asetplot(dashed, 10.0, 0, noend); - aplot(origin); - - temp.x := (origin.x + ms.x) / 2.0; (* circle the box centre *) - temp.y := (origin.y + ms.y) / 2.0; - asetplot(noline, 0, ms.x - origin.x , circle); - aplot(temp); - - asetwindow(origin, ms); (* restrict to the window *) - asetplot(noline, 0, ms.x - origin.x , diamond); - aplot(temp); - - END. (* testgr *) - \ No newline at end of file diff --git a/software/CPM/CPM20_MTPUG_08/WRDATA.SRC b/software/CPM/CPM20_MTPUG_08/WRDATA.SRC deleted file mode 100644 index 45309e0..0000000 --- a/software/CPM/CPM20_MTPUG_08/WRDATA.SRC +++ /dev/null @@ -1,195 +0,0 @@ -program writedata; - -type - - vector = -512..511; - posn = -128..127; - - roff = PACKED ARRAY [1..64] of vector; - vec = PACKED ARRAY [1..393] of posn; - - -var - - chroff: roff; - chrvec: vec; - - x: FILE of roff; - y: FILE of vec; - - result: integer; - - - PROCEDURE init1; - - BEGIN - chroff[ 1]:= 1;chroff[ 2]:= 4;chroff[ 3]:= 10;chroff[ 4]:= 18; - chroff[ 5]:= 28;chroff[ 6]:= 37;chroff[ 7]:= 46;chroff[ 8]:= 49; - chroff[ 9]:= 53;chroff[10]:= 57;chroff[11]:= 63;chroff[12]:= -67; - chroff[13]:= 69;chroff[14]:= 71;chroff[15]:= 72;chroff[16]:= 74; - chroff[17]:= 85;chroff[18]:= 90;chroff[19]:= 99;chroff[20]:= 112; - chroff[21]:= 116;chroff[22]:= 125;chroff[23]:= 136;chroff[24]:= 141; - chroff[25]:= 157;chroff[26]:= 169;chroff[27]:=-171;chroff[28]:= 174; - chroff[29]:= 177;chroff[30]:= 181;chroff[31]:= 184;chroff[32]:= 192; - chroff[33]:= 205;chroff[34]:= 212;chroff[35]:= 225;chroff[36]:= 233; - chroff[37]:= 240;chroff[38]:= 246;chroff[39]:= 251;chroff[40]:= 261; - chroff[41]:= 267;chroff[42]:= 273;chroff[43]:= 278;chroff[44]:= 284; - chroff[45]:= 287;chroff[46]:= 292;chroff[47]:= 296;chroff[48]:= 305; - chroff[49]:= 312;chroff[50]:= 323;chroff[51]:= 332;chroff[52]:= 344; - chroff[53]:= 348;chroff[54]:= 354;chroff[55]:= 357;chroff[56]:= 362; - chroff[57]:= 366;chroff[58]:= 371;chroff[59]:= 377;chroff[60]:= 381; - chroff[61]:= 383;chroff[62]:= 387;chroff[63]:=-392;chroff[64]:= 394; - END; - - PROCEDURE init2; - - BEGIN - chrvec[ 1]:= 39;chrvec[ 2]:= 33;chrvec[ 3]:= -30;chrvec[ 4]:= 19; - chrvec[ 5]:= 29;chrvec[ 6]:= 17;chrvec[ 7]:= -49;chrvec[ 8]:= 59; - chrvec[ 9]:= 47;chrvec[ 10]:= 21;chrvec[ 11]:= 27;chrvec[ 12]:= -47; - chrvec[ 13]:= 41;chrvec[ 14]:= -63;chrvec[ 15]:= 3;chrvec[ 16]:= -5; - chrvec[ 17]:= 65;chrvec[ 18]:= 30;chrvec[ 19]:= 39;chrvec[ 20]:= -57; - chrvec[ 21]:= 38;chrvec[ 22]:= 17;chrvec[ 23]:= 15;chrvec[ 24]:= 54; - chrvec[ 25]:= 52;chrvec[ 26]:= 31;chrvec[ 27]:= 12;chrvec[ 28]:= 29; - chrvec[ 29]:= 17;chrvec[ 30]:= 9;chrvec[ 31]:= 69;chrvec[ 32]:= 0; - chrvec[ 33]:= -60;chrvec[ 34]:= 40;chrvec[ 35]:= 52;chrvec[ 36]:= 60; - chrvec[ 37]:= 0;chrvec[ 38]:= 57;chrvec[ 39]:= 49;chrvec[ 40]:= 28; - chrvec[ 41]:= 26;chrvec[ 42]:= 62;chrvec[ 43]:= 40;chrvec[ 44]:= 20; - chrvec[ 45]:= 13;chrvec[ 46]:= 29;chrvec[ 47]:= 39;chrvec[ 48]:= 27; - chrvec[ 49]:= 49;chrvec[ 50]:= 27;chrvec[ 51]:= 22;chrvec[ 52]:= 40; - chrvec[ 53]:= 29;chrvec[ 54]:= 47;chrvec[ 55]:= 42;chrvec[ 56]:= 20; - chrvec[ 57]:= 17;chrvec[ 58]:= 51;chrvec[ 59]:= -57;chrvec[ 60]:= 11; - chrvec[ 61]:= -4;chrvec[ 62]:= 64;chrvec[ 63]:= 4;chrvec[ 64]:= 64; - END; - - PROCEDURE init3; - - BEGIN - chrvec[ 65]:= -37;chrvec[ 66]:= 31;chrvec[ 67]:= 34;chrvec[ 68]:= 22; - chrvec[ 69]:= 14;chrvec[ 70]:= 64;chrvec[ 71]:= 30;chrvec[ 72]:= 10; - chrvec[ 73]:= 69;chrvec[ 74]:= 0;chrvec[ 75]:= 69;chrvec[ 76]:= -49; - chrvec[ 77]:= 29;chrvec[ 78]:= 7;chrvec[ 79]:= 2;chrvec[ 80]:= 20; - chrvec[ 81]:= 40;chrvec[ 82]:= 62;chrvec[ 83]:= 67;chrvec[ 84]:= 49; - chrvec[ 85]:= 27;chrvec[ 86]:= 39;chrvec[ 87]:= 30;chrvec[ 88]:= -20; - chrvec[ 89]:= 40;chrvec[ 90]:= 7;chrvec[ 91]:= 29;chrvec[ 92]:= 49; - chrvec[ 93]:= 67;chrvec[ 94]:= 54;chrvec[ 95]:= 24;chrvec[ 96]:= 1; - chrvec[ 97]:= 0;chrvec[ 98]:= 60;chrvec[ 99]:= 7;chrvec[100]:= 29; - chrvec[101]:= 59;chrvec[102]:= 68;chrvec[103]:= 66;chrvec[104]:= 55; - chrvec[105]:= 25;chrvec[106]:= -55;chrvec[107]:= 64;chrvec[108]:= 61; - chrvec[109]:= 50;chrvec[110]:= 20;chrvec[111]:= 2;chrvec[112]:= 40; - chrvec[113]:= 49;chrvec[114]:= 3;chrvec[115]:= 63;chrvec[116]:= 69; - chrvec[117]:= 9;chrvec[118]:= 5;chrvec[119]:= 55;chrvec[120]:= 64; - chrvec[121]:= 61;chrvec[122]:= 50;chrvec[123]:= 10;chrvec[124]:= 1; - chrvec[125]:= 49;chrvec[126]:= 19;chrvec[127]:= 8;chrvec[128]:= 1; - chrvec[129]:= 10;chrvec[130]:= 50;chrvec[131]:= 61;chrvec[132]:= 64; - END; - - PROCEDURE init4; - - BEGIN - chrvec[133]:= 55;chrvec[134]:= 15;chrvec[135]:= 4;chrvec[136]:= 9; - chrvec[137]:= 69;chrvec[138]:= 67;chrvec[139]:= 21;chrvec[140]:= 20; - chrvec[141]:= 15;chrvec[142]:= 6;chrvec[143]:= 8;chrvec[144]:= 19; - chrvec[145]:= 59;chrvec[146]:= 68;chrvec[147]:= 66;chrvec[148]:= 55; - chrvec[149]:= 15;chrvec[150]:= 4;chrvec[151]:= 1;chrvec[152]:= 10; - chrvec[153]:= 50;chrvec[154]:= 61;chrvec[155]:= 64;chrvec[156]:= 55; - chrvec[157]:= 1;chrvec[158]:= 10;chrvec[159]:= 50;chrvec[160]:= 61; - chrvec[161]:= 68;chrvec[162]:= 59;chrvec[163]:= 19;chrvec[164]:= 8; - chrvec[165]:= 5;chrvec[166]:= 14;chrvec[167]:= 54;chrvec[168]:= 65; - chrvec[169]:= 35;chrvec[170]:= -31;chrvec[171]:= 39;chrvec[172]:= -34; - chrvec[173]:= 22;chrvec[174]:= 58;chrvec[175]:= 14;chrvec[176]:= 50; - chrvec[177]:= 52;chrvec[178]:= 12;chrvec[179]:= -15;chrvec[180]:= 55; - chrvec[181]:= 18;chrvec[182]:= 54;chrvec[183]:= 10;chrvec[184]:= 18; - chrvec[185]:= 29;chrvec[186]:= 49;chrvec[187]:= 58;chrvec[188]:= 56; - chrvec[189]:= 34;chrvec[190]:= 32;chrvec[191]:= -30;chrvec[192]:= 62; - chrvec[193]:= 40;chrvec[194]:= 20;chrvec[195]:= 2;chrvec[196]:= 7; - END; - - PROCEDURE init5; - - BEGIN - chrvec[197]:= 29;chrvec[198]:= 49;chrvec[199]:= 67;chrvec[200]:= 63; - chrvec[201]:= 42;chrvec[202]:= 34;chrvec[203]:= 46;chrvec[204]:= 66; - chrvec[205]:= 0;chrvec[206]:= 6;chrvec[207]:= 39;chrvec[208]:= 66; - chrvec[209]:= 60;chrvec[210]:= -4;chrvec[211]:= 64;chrvec[212]:= 0; - chrvec[213]:= 50;chrvec[214]:= 61;chrvec[215]:= 64;chrvec[216]:= 55; - chrvec[217]:= 15;chrvec[218]:= -55;chrvec[219]:= 66;chrvec[220]:= 68; - chrvec[221]:= 59;chrvec[222]:= 9;chrvec[223]:= -19;chrvec[224]:= 10; - chrvec[225]:= 68;chrvec[226]:= 59;chrvec[227]:= 29;chrvec[228]:= 7; - chrvec[229]:= 2;chrvec[230]:= 20;chrvec[231]:= 50;chrvec[232]:= 61; - chrvec[233]:= 0;chrvec[234]:= 9;chrvec[235]:= 49;chrvec[236]:= 67; - chrvec[237]:= 62;chrvec[238]:= 40;chrvec[239]:= 0;chrvec[240]:= 69; - chrvec[241]:= 9;chrvec[242]:= 0;chrvec[243]:= 60;chrvec[244]:= -45; - chrvec[245]:= 5;chrvec[246]:= 69;chrvec[247]:= 9;chrvec[248]:= 0; - chrvec[249]:= -45;chrvec[250]:= 5;chrvec[251]:= 68;chrvec[252]:= 59; - chrvec[253]:= 29;chrvec[254]:= 7;chrvec[255]:= 2;chrvec[256]:= 20; - chrvec[257]:= 50;chrvec[258]:= 61;chrvec[259]:= 64;chrvec[260]:= 44; - chrvec[261]:= 0;chrvec[262]:= 9;chrvec[263]:= -60;chrvec[264]:= 69; - END; - - PROCEDURE init6; - - BEGIN - chrvec[265]:= -5;chrvec[266]:= 65;chrvec[267]:= 29;chrvec[268]:= 49; - chrvec[269]:= -39;chrvec[270]:= 30;chrvec[271]:= -20;chrvec[272]:= 40; - chrvec[273]:= 69;chrvec[274]:= 62;chrvec[275]:= 40;chrvec[276]:= 20; - chrvec[277]:= 2;chrvec[278]:= 9;chrvec[279]:= 0;chrvec[280]:= -5; - chrvec[281]:= 69;chrvec[282]:= -37;chrvec[283]:= 60;chrvec[284]:= 9; - chrvec[285]:= 0;chrvec[286]:= 60;chrvec[287]:= 0;chrvec[288]:= 9; - chrvec[289]:= 34;chrvec[290]:= 69;chrvec[291]:= 60;chrvec[292]:= 0; - chrvec[293]:= 9;chrvec[294]:= 60;chrvec[295]:= 69;chrvec[296]:= 10; - chrvec[297]:= 2;chrvec[298]:= 7;chrvec[299]:= 19;chrvec[300]:= 59; - chrvec[301]:= 67;chrvec[302]:= 62;chrvec[303]:= 50;chrvec[304]:= 10; - chrvec[305]:= 0;chrvec[306]:= 9;chrvec[307]:= 59;chrvec[308]:= 68; - chrvec[309]:= 66;chrvec[310]:= 55;chrvec[311]:= 5;chrvec[312]:= 10; - chrvec[313]:= 2;chrvec[314]:= 7;chrvec[315]:= 19;chrvec[316]:= 59; - chrvec[317]:= 67;chrvec[318]:= 62;chrvec[319]:= 50;chrvec[320]:= 10; - chrvec[321]:= -42;chrvec[322]:= 60;chrvec[323]:= 0;chrvec[324]:= 9; - chrvec[325]:= 59;chrvec[326]:= 68;chrvec[327]:= 66;chrvec[328]:= 55; - END; - - PROCEDURE init7; - - BEGIN - chrvec[329]:= 5;chrvec[330]:= -35;chrvec[331]:= 60;chrvec[332]:= 68; - chrvec[333]:= 59;chrvec[334]:= 19;chrvec[335]:= 8;chrvec[336]:= 6; - chrvec[337]:= 15;chrvec[338]:= 55;chrvec[339]:= 64;chrvec[340]:= 61; - chrvec[341]:= 50;chrvec[342]:= 10;chrvec[343]:= 1;chrvec[344]:= 9; - chrvec[345]:= 69;chrvec[346]:= -39;chrvec[347]:= 30;chrvec[348]:= 9; - chrvec[349]:= 2;chrvec[350]:= 10;chrvec[351]:= 50;chrvec[352]:= 62; - chrvec[353]:= 69;chrvec[354]:= 9;chrvec[355]:= 30;chrvec[356]:= 69; - chrvec[357]:= 9;chrvec[358]:= 10;chrvec[359]:= 35;chrvec[360]:= 50; - chrvec[361]:= 69;chrvec[362]:= 9;chrvec[363]:= 60;chrvec[364]:= -69; - chrvec[365]:= 0;chrvec[366]:= 9;chrvec[367]:= 35;chrvec[368]:= -69; - chrvec[369]:= 35;chrvec[370]:= 30;chrvec[371]:= 9;chrvec[372]:= 69; - chrvec[373]:= 0;chrvec[374]:= 60;chrvec[375]:= -25;chrvec[376]:= 45; - chrvec[377]:= 49;chrvec[378]:= 29;chrvec[379]:= 20;chrvec[380]:= 40; - chrvec[381]:= 19;chrvec[382]:= 50;chrvec[383]:= 29;chrvec[384]:= 49; - chrvec[385]:= 40;chrvec[386]:= 20;chrvec[387]:= 17;chrvec[388]:= 39; - chrvec[389]:= 57;chrvec[390]:= -39;chrvec[391]:= 30;chrvec[392]:= 3; - chrvec[393]:= 63; - END; - - -BEGIN - init1; - init2; - init3; - init4; - init5; - init6; - init7; - assign(x,'B:CHROFF.DAT'); - rewrite(x); - x^:=chroff; - put(x); - close(x,result); - if result = 255 then writeln('Error in closing CHROFF.DAT'); - assign(y,'B:CHRVEC.DAT'); - rewrite(y); - y^:=chrvec; - put(y); - close(y,result); - if result = 255 then writeln('Error in closing CHRVEC.DAT'); -END. -  \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/-MTPUG.DOC b/software/CPM/CPM21_MTPUG_09/-MTPUG.DOC deleted file mode 100644 index 25095ec..0000000 --- a/software/CPM/CPM21_MTPUG_09/-MTPUG.DOC +++ /dev/null @@ -1,57 +0,0 @@ -*** MTPUG.009 April 15, 1983 *** - -TYPECHK: A Cross Module Type/Identifier Checker - Version 2.2 Serial #12200012 - - The entire source was submitted to MTPUG for -distribution as Public Domain Software and can not -be sold. A version (improved ??) which is supported can be -purchased from the Author, Lawrence Adkins, -56 Camille Lane, East Patchogue, NY 11772. - -TYPECHK.DOC This program detects errors in Pascal/MT+ - .SUB source modules which are apparent only when - .COM comparing the common identifier declarations - made in them. This is a very large program - which is comprised of 9 modules and about - 4300 lines of .PRN output. It requires about - 30 minutes to compile and about 35 min to - check itself. Source code, .ERL and .COM files - requires about 200K of space. Extensive features - are available for directing output to a file as - well as to the terminal. - -PASERROR.SRC The MT+ error messages are printed on the terminal - when given the error number. - -MSA326 .DOC These programs were transcribed from hard copy -MSA326A.PAS listings. They are numerical analysis programs -MSA326B.PAS from a book by Conte and Deboore, Title and Publisher -MSA326C.PAS are unknown. -MSA326D.PAS - -****************************************************************** - -PLANE.SRC This is a Pascal upgrade of a Basic program from one - of the early CP/M Library disks. The conversion was - done by Dan Covill, a San Diego software consultant, - who is happy to have it added to your program disks. - The graphics is currently configured to run on a - Heath H-19 Terminal, but can be easily changed. I - trust you will find it a pleasant distraction from - the serious programs. Submitted by Wil Wakely, - 2328 Germanium Street, San Diego, CA 92109 - -SWEEP.COM This is a new improved version of a program which - appeared on program disk #4. Written by Robert - Fisher in PL/1. This version includes verified - copy. Used for tagged multi-file copy or delete. - On some systems, the automatic disk reset allows - multi-disk operations. An improved assembly version - is available from Micro Resources, 2468 Hansen Court, - Simi Valley, CA 93605 for $49.95 - -SYNONYM.COM This small program allows you to create your own - collection of synanyms for activating programs. - - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/BLOCKR.SRC b/software/CPM/CPM21_MTPUG_09/BLOCKR.SRC deleted file mode 100644 index b19bf6d..0000000 --- a/software/CPM/CPM21_MTPUG_09/BLOCKR.SRC +++ /dev/null @@ -1,45 +0,0 @@ -MODULE READBLK; -{ 4-Mar-82 } -(*$M BLOCKR*) -(*$M **) - -(*$I FIBDEF.LIB*) -VAR - RESULTIO: EXTERNAL INTEGER; - -EXTERNAL FUNCTION @BDOS(FUNC:INTEGER; PARM:WORD):INTEGER; - -PROCEDURE - BLOCKR(VAR F:FIB;SZ:INTEGER;BA:WORD;VAR R:INTEGER;NB,RB:INTEGER); -VAR - PTR : INTEGER; - I,J : INTEGER; - extent: integer; - -BEGIN - f.option := frandom; - PTR := ORD(BA); - IF rb >= 0 - THEN BEGIN - extent := shr (rb, 7); { bits 7 to 11+ specify extent requested - by user, while bits 0 to 6 specify the - relative sector within that extent. } - F.FCB[32] := CHR(RB & $7F); (* RELATIVE BLOCK *) - IF ord (f.fcb [12]) <> extent - THEN BEGIN - f.fcb [12] := chr (extent); { set extent number } - resultio := @bdos (15, wrd (addr (f.fcb))) { open new extent } - END - END; - FOR I := 1 TO shr (nb, 7) DO {TO NB DIV 128} {# of specified sectors } - BEGIN - J := @BDOS(26,WRD(PTR)); (* SETDMA address*) - J := @BDOS(20,WRD(ADDR(F.FCB))); (* do a SEQUENTIAL READ *) - PTR := PTR + 128 - END; - R := J; -END; - -MODEND. - - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/CONSTTAB.PAS b/software/CPM/CPM21_MTPUG_09/CONSTTAB.PAS deleted file mode 100644 index fb4b634..0000000 --- a/software/CPM/CPM21_MTPUG_09/CONSTTAB.PAS +++ /dev/null @@ -1,330 +0,0 @@ -{########################################################################## -#### #### -#### Full module name: CONSTANT_TABLE_MODULE_FOR_TYPE_CHECKER_PROGRAM.#### -#### File name: CONSTTAB.PAS. #### -#### Support modules reqd: PASLIB.ERL. #### -#### Run time environment: . #### -#### Compile time environment: MT MicroSYSTEMS Pascal/MT+v5.25. #### -#### Link time environment: MT MicroSYSTEMS Linkmt v5.1. #### -#### Copyright (C) 1982 by Haldo Products, Inc. All rights reserved. #### -#### 56 Camille Ln, E. Patchogue, NY 11772 #### -#### Programmer: Lawrence Adkins. #### -#### Module Development/Maintenance History: #### - 6-NOV-81 Vers 1.0. File just created. - 12-NOV-81 Development of this version completed. - 9-JAN-82 Vers 2.0. development begins. - 1-MAR-82 Development of this version complete. - 19-APR-82 Vers 2.2. No changes made. -#### #### -##########################################################################} - - - -MODULE CONSTANT_TABLE_HANDLER; - -{$I B:TYPECHK.DEC } { list of all our type declarations } - -VAR - last_ct_entry: natural; { last filled element of const table } - token: EXTERNAL tokentype; - tokenbuf: EXTERNAL string132; - exit_keywords: EXTERNAL SET OF tokentype; - last_entry_point_name: EXTERNAL string132; - outfile: EXTERNAL text; - debug: EXTERNAL boolean; - -EXTERNAL PROCEDURE get_next_token; -EXTERNAL PROCEDURE error (pascal_error_no: integer); -EXTERNAL PROCEDURE @hlt; - - - - - - -{###########################################################################} -{--- Initialize the variables in this module } -{###########################################################################} -PROCEDURE cminit_constant_table_module - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec); - - BEGIN - WITH const_table [1] DO BEGIN - const_id := 'MAXINT'; actual_value := 32767 END; - WITH const_table [2] DO BEGIN - const_id := 'FALSE'; actual_value := 0 END; - WITH const_table [3] DO BEGIN - const_id := 'TRUE'; actual_value := 1 END; - WITH const_table [4] DO BEGIN - const_id := 'NIL'; actual_value := 0 END; - - last_ct_entry := 4 - END; - - - - -{#############################################################################} -(*-- First we will skip past the and - --- syntax until we hit a token defined in the exit_keyword set. *) -(*-- Then we will parse the following Pascal/MT+ BNF productions: - --- ::= | - --- CONST {; } ; - --- - --- ::= = - --- ::= - --- *) -{#############################################################################} -PROCEDURE cmadd_new_constants_to_const_table - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec); - - CONST action_message = 'Handling Constants...'; - BEGIN - writeln (action_message); writeln (outfile, action_message); - exit_keywords := - [tokconst, toktype, tokvar, tokproc, tokfunc, tokbegin, tokexternal]; - - REPEAT get_next_token { skip prog heading and label declarations } - UNTIL (token IN exit_keywords); - - WHILE token = tokconst - DO BEGIN - get_next_token; { should be constant identifier } - REPEAT - last_entry_point_name := tokenbuf; - cminc_last_ct_entry_index (cthibound); - WITH const_table [last_ct_entry] - DO BEGIN - const_id := tokenbuf; - get_next_token; { should be tokequal } - get_next_token; { should be const_id, number, sign, or string } - cmfinish_parsing_constant_value (actual_value, const_table); - cmremove_duplicate_const_entry (const_table) - END; - get_next_token; { should be semicolon } - IF debug THEN error (0); - get_next_token { should be const_id or new keyword } - UNTIL (token IN exit_keywords); - END - END; - -{#############################################################################} -(*-- Assuming that the first symbol has already been scanned, - --- Here we will finish parsing the following Pascal/MT+ BNF productions: - --- ::= | | - --- | | - --- - --- ::= | - --- ::= . | - --- . E | - --- E - --- ::= {} - --- ::= | - --- ::= + | - - --- ::= - --- ::= ' {} ' | '' - --- *) -{#############################################################################} -PROCEDURE cmfinish_parsing_constant_value - (VAR actual_value: integer; - VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec); - - VAR sign: integer; - BEGIN - sign := +1; - IF (token = tokplus) OR (token = tokminus) - THEN BEGIN - IF TOKEN = tokminus THEN sign := -1; - get_next_token; { should be const_id or unsigned number } - END; - - CASE token OF - tokidentifier: - BEGIN { look up it's integer value in the table } - IF cmfind_const_id (actual_value, const_table) - THEN actual_value := actual_value * sign - ELSE actual_value := 0 - END; - tokintnum, tokbytenum, tokrealnum: - BEGIN { make the characters into an integer } - cmxlate_const_value (actual_value, const_table); - actual_value := actual_value * sign - END; - toklitstring: - BEGIN { take the ordinal value of just the first character } - IF length (tokenbuf) > 0 - THEN actual_value := ord (tokenbuf[1]) - ELSE actual_value := 0 - END - END - END; - - - - - - - - - - - - - - - - -{############################################################################} -{---- Check for identical identifier earlier in the table, if match, ------ compare entries, and erase latter entry. } -{############################################################################} -PROCEDURE cmremove_duplicate_const_entry - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec); - - VAR i: integer; - BEGIN - FOR i := 1 TO (last_ct_entry - 1) - DO WITH const_table [i] - DO IF const_id = const_table [last_ct_entry].const_id - THEN BEGIN - IF actual_value <> const_table [last_ct_entry].actual_value - THEN error (101); { id declared elsewhere with different value } - last_ct_entry := last_ct_entry - 1; - exit - END - END; - - - -{#############################################################################} -{--- Search out specified identifier in constant table. If found, ----- return the index, and true, meaning found. } -{#############################################################################} -FUNCTION cmfind_const_id - (VAR ret_val: integer; - VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec): - boolean; - - VAR i : integer; - name_to_find: alfa; - BEGIN - ret_val := 0; cm_find_const_id := false; - name_to_find := tokenbuf; {shorten length down to alfalen chars} - FOR i := 1 TO last_ct_entry - DO WITH const_table[i] - DO IF const_id = name_to_find - THEN BEGIN ret_val := actual_value; cmfind_const_id := true; exit END - END; - - - -{############################################################################} -(*-- Assuming we have already scanned the first symbol, - --- Here we will finish parsing the following Pascal/MT+ BNF productions: - --- ::= $ | - --- ::= {} - --- *) -{############################################################################} -PROCEDURE cmxlate_const_value - (VAR ret_val: integer; - VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec); - - VAR i, offset, first, last, base: byte; - BEGIN - last := length(tokenbuf); ret_val := 0; - IF tokenbuf[1] = '$' - THEN BEGIN first := 2; base := 16 END - ELSE BEGIN first := 1; base := 10 END; - FOR i := first TO last - DO BEGIN - IF tokenbuf[i] <= '9' THEN offset := 48 ELSE offset := 65; - ret_val := (ret_val * base) + (ord(tokenbuf[i]) - offset) - END - END; - - -{############################################################################} -{--- Bump the index into the constant table by one. Error if overflow. } -{############################################################################} -PROCEDURE cminc_last_ct_entry_index (max_const_elements: natural); - - VAR i: integer; - BEGIN - IF last_ct_entry >= max_const_elements - THEN BEGIN - writeln; - writeln ('Const table overflow. Last id: ', last_entry_point_name); - close (outfile, i); - @hlt - END; - last_ct_entry := last_ct_entry + 1 - END; - - - -{#############################################################################} -{--- Display the current contents of the constant table } -{#############################################################################} -PROCEDURE cmdump_constant_table - (VAR outfile: text; - VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec); - - VAR i: integer; - BEGIN - writeln (outfile); writeln (outfile, '--- Constant Table Dump --- '); - writeln (outfile, 'name':30, 'value':10); - FOR i := 1 TO last_ct_entry - DO WITH const_table[i] - DO writeln (outfile, i:10, const_id:20, actual_value:10); - writeln (outfile) - END; - - - - - - -{#############################################################################} -(*-- Assuming that the first symbol has already been scanned, - --- here we will finish parsing the following Pascal/MT+ BNF production : - --- ::= ( {, } ) - --- *) -{#############################################################################} -PROCEDURE cmstore_scalar_type_values - (VAR n_of_values: integer; - VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec); - - BEGIN - n_of_values := 0; - REPEAT - get_next_token; { should be scalar value identifier } - cminc_last_ct_entry_index (cthibound); - WITH const_table [last_ct_entry] - DO BEGIN const_id := tokenbuf; actual_value := n_of_values END; - n_of_values := n_of_values + 1; - cmremove_duplicate_const_entry (const_table); - get_next_token { should be comma or right paren } - UNTIL token = tokrparen - END; - - -MODEND. - - - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/FIBDEF.LIB b/software/CPM/CPM21_MTPUG_09/FIBDEF.LIB deleted file mode 100644 index e4cedc8..0000000 --- a/software/CPM/CPM21_MTPUG_09/FIBDEF.LIB +++ /dev/null @@ -1,25 +0,0 @@ - - - (* FIB LAYOUT *) - - -TYPE - OPTTYPE = (NOTOPEN,FWRITE,FRDWR,FRANDOM,FCONIO,FTRMIO,FLSTOUT); - - FIB=RECORD - FNAME : STRING[16]; (* d:filename.ext *) - FCB : PACKED ARRAY [0..34] OF CHAR; (* CP/M FILE CONTROL BLOCK *) - BUFLEN : INTEGER; (* SIZE OF FBUFFER *) - BUFIDX : INTEGER; (* CURRENT INDEX INTO FBUFFER *) - OPTION : OPTTYPE; - IOSIZE : INTEGER; (* SIZE OF NEXT TRANSFER *) - FEOLN : BOOLEAN; (* TRUE IF TEXT FILE AT END-OF-LINE *) - FEOF : BOOLEAN; (* TRUE IF AT END-OF-FILE *) - FBUFADR: WORD; (* POINTER TO FBUFFER *) - FSECINX: 0..128; (* INDEX INTO FSECTOR +1 FOR OVERFLOW *) - FTEXT : BOOLEAN; (* TRUE IF THIS IS A TEXT FILE! *) - NOSECTRS:BOOLEAN; (* TRUE IF NO MORE DISK DATA AVAILABLE *) - FSECTOR: PACKED ARRAY [0..127] OF CHAR; (* 1 SECTOR BUFFER FOR CP/M *) - FBUFFER: PACKED ARRAY [0..0 ] OF CHAR; - END; - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/FILES.CMD b/software/CPM/CPM21_MTPUG_09/FILES.CMD deleted file mode 100644 index eb1e15b..0000000 --- a/software/CPM/CPM21_MTPUG_09/FILES.CMD +++ /dev/null @@ -1,12 +0,0 @@ -; LIST OF FILES TO BE USED WITH THE TYPE CHECKER PROGRAM. VERS 2.1. -; THIS FILE LETS IT TYPE CHECK ITSELF. -; TAKES ABOUT 35 MIN. -B:TYPECHK.PAS -B:CONSTTAB.PAS -B:TYPE1TAB.PAS -B:VARTAB.PAS -B:ROUTTAB.PAS -B:SCANNER.PAS -B:MARKREL.SRC -B:BLOCKR.SRC - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/INPUTFAS.PAS b/software/CPM/CPM21_MTPUG_09/INPUTFAS.PAS deleted file mode 100644 index f245ba1..0000000 --- a/software/CPM/CPM21_MTPUG_09/INPUTFAS.PAS +++ /dev/null @@ -1,156 +0,0 @@ -{########################################################################## -#### #### -#### Full module name: FAST BLOCKREAD INPUT OF SOURCE MODULE. #### -#### File name: INPUTFST.PAS. #### -#### Support modules reqd: PASLIB.ERL. #### -#### Run time environment: . #### -#### Compile time environment: MT MicroSYSTEMS Pascal/MT+v5.25. #### -#### Link time environment: MT MicroSYSTEMS Linkmt v5.1. #### -#### Copyright (C) 1982 by Haldo Products, Inc. All rights reserved. #### -#### 56 Camille Ln, E. Patchogue, NY 11772 #### -#### Programmer: Lawrence Adkins. #### -#### Module Development/Maintenance History: #### - 19-APR-82 Vers 2.2. File just created, and completed. - -#### #### -##########################################################################} - - - - - - -MODULE STD_INPUT; - -{$I B:TYPECHK.DEC } { list of all our type declarations } - -VAR - endfile: boolean; { Here, true only if eofmark char was read } - infile, infile1: EXTERNAL text; - {$E-} - saved_main_program_text: string132; {Store line till after include file done} - ior_for_main_file, ior_for_include_file: integer; - maintextbuffer,includfiletextbuffer: p_array_of_char; - main1_file_index, includ1_file_index: integer; - include_file_level: EXTERNAL integer; - -{$E+} -FUNCTION maineof: boolean; - - BEGIN - maineof := endfile AND (include_file_level = 0) - END; - - -PROCEDURE init_include_file_block; - - BEGIN - blockread (infile1, includfiletextbuffer, ior_for_include_file, blkiosize, - {record} 0); - includ1_file_index := 1; - saved_main_program_text := ''; - endfile := false - END; - - -PROCEDURE init_main_file_block; - - BEGIN - blockread (infile, maintextbuffer, ior_for_main_file, blkiosize, {record} 0); - main1_file_index := 1; - saved_main_program_text := ''; - endfile := false - END; - - - - -PROCEDURE readln_main_program_text (VAR input_line: string132); - - BEGIN - IF length (saved_main_program_text) > 0 - THEN BEGIN - input_line := saved_main_program_text; - saved_main_program_text := '' - END - ELSE grab_some_text (input_line, maintextbuffer, main1_file_index, infile, - ior_for_main_file) - END; - -PROCEDURE readln_include_file_text (VAR input_line: string132); - BEGIN - IF length (saved_main_program_text) = 0 - THEN BEGIN - saved_main_program_text := input_line; - IF length (saved_main_program_text) = 0 - THEN saved_main_program_text := ' ' - END; - grab_some_text (input_line, includfiletextbuffer, includ1_file_index, - infile1, ior_for_include_file) - END; - -{$E-} -PROCEDURE grab_some_text (VAR input_line: string132; - VAR textbuffer: p_array_of_char; - VAR buf_index: integer; - VAR infile: text; - VAR ior: integer); - - FUNCTION at_eof: boolean; - BEGIN at_eof := (textbuffer [buf_index] = chr (eofmark)) - OR ((buf_index > blkiosize) AND (ior > 0)) - END; - BEGIN - input_line := ''; - WHILE ((textbuffer [buf_index] = chr (cr)) - OR (textbuffer [buf_index] = chr (lf))) - AND NOT at_eof - DO BEGIN - buf_index := buf_index + 1; - IF (buf_index > blkiosize) AND (ior = 0) - THEN BEGIN - blockread (infile, textbuffer, ior, blkiosize, -1 {seq access}); - buf_index := 1 - END; - END; - - WHILE (textbuffer [buf_index] <> chr (cr)) - AND NOT at_eof - DO BEGIN - IF (buf_index <= blkiosize) - THEN BEGIN - input_line := concat (input_line, textbuffer [buf_index]); - buf_index := buf_index + 1 - END; - IF (buf_index > blkiosize) AND (ior = 0) - THEN BEGIN - blockread (infile, textbuffer, ior, blkiosize, -1 {seq access}); - buf_index := 1 - END - END; - endfile := at_eof - END; - -MODEND. - - - - - - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/INPUTSTD.PAS b/software/CPM/CPM21_MTPUG_09/INPUTSTD.PAS deleted file mode 100644 index 22de9fb..0000000 --- a/software/CPM/CPM21_MTPUG_09/INPUTSTD.PAS +++ /dev/null @@ -1,88 +0,0 @@ -{########################################################################## -#### #### -#### Full module name: STANDARD READLN INPUT OF SOURCE MODULE. #### -#### File name: INPUTSTD.PAS. #### -#### Support modules reqd: PASLIB.ERL. #### -#### Run time environment: . #### -#### Compile time environment: MT MicroSYSTEMS Pascal/MT+v5.25. #### -#### Link time environment: MT MicroSYSTEMS Linkmt v5.1. #### -#### Copyright (C) 1982 by Haldo Products, Inc. All rights reserved. #### -#### 56 Camille Ln, E. Patchogue, NY 11772 #### -#### Programmer: Lawrence Adkins. #### -#### Module Development/Maintenance History: #### - 19-APR-82 Vers 2.2. File just created, and completed. - -#### #### -##########################################################################} - - - - - - -MODULE STNDRD_INPUT; - -{$I B:TYPECHK.DEC } { list of all our type declarations } - -VAR - endfile: boolean; { Here, equivalent to eof function } - infile, infile1: EXTERNAL text; - - - - - - - - - - -{$E+} -FUNCTION maineof: boolean; - BEGIN maineof := eof (infile) END; - - -PROCEDURE init_include_file_block; - BEGIN endfile := false END; - - -PROCEDURE init_main_file_block; - BEGIN endfile := false END; - - -PROCEDURE readln_main_program_text (VAR input_line: string132); - BEGIN grab_some_text (infile, input_line) END; - - -PROCEDURE readln_include_file_text (VAR input_line: string132); - BEGIN grab_some_text (infile1, input_line) END; - -{$E-} -PROCEDURE grab_some_text (VAR infile: text; VAR input_line: string132); - BEGIN - IF eof (infile) THEN input_line := '' ELSE readln (infile, input_line); - endfile := eof (infile) - END; - - -MODEND. - - - - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/MARKREL.SRC b/software/CPM/CPM21_MTPUG_09/MARKREL.SRC deleted file mode 100644 index 5346956..0000000 --- a/software/CPM/CPM21_MTPUG_09/MARKREL.SRC +++ /dev/null @@ -1,94 +0,0 @@ -{################################################################### -#### #### -#### Full module name: NEW_MARK_AND_RELEASE ROUTINES. #### -#### File name: MARKREL.SRC. #### -#### Support modules reqd: SYSERR. #### -#### Compile time environment: MT MicroSYSTEMS Pascal/MT+5.2 #### -#### PUBLIC DOMAIN. #### -#### Module development history: #### -#### ---- 30-SEP-81 Module published in MTPUG newsletter #### -#### ---- 20-OCT-81 Modified to compare words and not integers#### -#### #### -###################################################################} - -MODULE NEW_MARK_AND_RELEASE; - -VAR SYSMEM: EXTERNAL INTEGER; { start of free area } - @SFP: EXTERNAL INTEGER; { start of stack frame } - HERR: BOOLEAN; { indicates heap overflow error } - -EXTERNAL PROCEDURE @ERR (AN_ERROR: BOOLEAN; ERROR_NUMBER: INTEGER); - - -(*#################################################################### -#### return the amount of free space existing between the top of the -#### heap at present and the reverse top of the local variable stack. -#### -------+-----> <-----+------- -#### .... | heap local | .... -#### low mem | area var | hi mem -#### | stack | -#### -------+-----> <-----+------- -#### ^ ^ -#### SYSMEM--> <---@SFP -#### This routine will return only the absolute value of the differ -#### ence between sysmem and @sfp, and will not know if sysmem is -#### already higher than (on wrong side of) @sfp. -###################################################################*) - -FUNCTION MEMAVA: INTEGER; - BEGIN MEMAVA := ORD (WRD(@SFP) - WRD(SYSMEM)) END; - - - - - -(*################################################################### -#### Dynamic allocation routine. Expands the heap by objectsize -#### bytes. If resulting heap collides with the stack then notify -#### user of heap overflow error. -#### The comparison of two words is used to avoid the possibility -#### that we are comparing a positive integer (0 <= word <= 32767) -#### with a negative integer (32768 <= word <= 65534). -###################################################################*) - -PROCEDURE @NEW (VAR POINTER: INTEGER; OBJECTSIZE: INTEGER); - BEGIN - POINTER := SYSMEM; - SYSMEM := SYSMEM + OBJECTSIZE; - HERR := WRD (SYSMEM) >= WRD (@SFP); { memavail wont tell us this } - IF HERR THEN @ERR (TRUE, 2) { heap overflow error } - END; (* keep check in until exception checking works again *) - - - - - - -(*################################################################## -#### Mark start of heap to be deallocated later. -##################################################################*) - -PROCEDURE MARK (VAR P: INTEGER); - BEGIN P := SYSMEM END; - - - -(*################################################################## -#### Release area allocated since call to mark(addr(pointer)) -##################################################################*) - -PROCEDURE RELEASE (P: INTEGER); - BEGIN SYSMEM := P END; - - - - - - -MODEND. - - - - - - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/MSA326.DOC b/software/CPM/CPM21_MTPUG_09/MSA326.DOC deleted file mode 100644 index 65dcb7f..0000000 --- a/software/CPM/CPM21_MTPUG_09/MSA326.DOC +++ /dev/null @@ -1,9 +0,0 @@ -Thå  programó  founä oî thå fileó MSA326(A,B,C,D©  arå  numericaì -analysió  probleí  solutionó  aó implementeä oî  aî  Univaã  110° -mainframå  runninç Underseá Pascal®  Thå fileó werå  transcribeä -froí hardcopù listings»  theù maù contaiî errors®  Eveî iæ therå -werå  nï  transcribinç  errors¬  É  dï noô kno÷  iæ  thå  prograí -generateó  thå  righô  solutions®  Thå titlå oæ  thå  Contå  anä -Deboorå  booë referreä tï ió unknown¬  buô thå subjecô  concerneä -numerical analysis. - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/MSA326A.PAS b/software/CPM/CPM21_MTPUG_09/MSA326A.PAS deleted file mode 100644 index 0914f7c..0000000 --- a/software/CPM/CPM21_MTPUG_09/MSA326A.PAS +++ /dev/null @@ -1,45 +0,0 @@ -PROGRAM solveasystem (input, output) -(**************************************************************************** - L A W R E N C E A D K I N S , MSA 326 SECT 01 COMPUTER PROJECT NO. 1. - Conte and DeBoore, page 90(2.8-6) Spring, 1979 - **************************************************************************** -Solve F(X,Y) = (Exp(X)) + (X*Y) - 1 = 0 -and G(X,Y) = (Sin(X*Y)) + X + Y = 0 -Using the scheme - X[I+1] = X[I] - ((EXP(X[I])) + (X[I]*Y[I]) - 1) / ((EXP(X[I]))+Y[I] - Y[I+1] = Y[I] - ((SIN(X[I+1] * Y[I]) + (X[I+1]) + (Y[I])-1) / - (X[I+1] * COS(X[I+1] * Y[I]) + 1)) -Using the initial approximations X[0] = 0.1, Y[0] = 0.5. - ****************************************************************************) - - -CONST n = 20; epsilon = 5.0E-08; -VAR x, y, fofxy, gofxy, fpofxy, gpofxy: real; - i: integer; -FUNCTION convergence: boolean; - BEGIN convergence := (abs(fofxy)<=epsilon) AND (abs(gofxy)<=epsilon) END; - -BEGIN -readln (x,y); i:=0; -writeln ('RESULTS OF ITERATION OF THIS PROBLEM.'); -writeln; writeln; -writeln ('I X Y F(X,Y) G(X,Y)'); -writeln; -REPEAT - fofxy := (exp(x)) + (x*y) - 1; (*f(x,y)*) - write (i:2,' ',x:9:6,' ',y:9:6,' ',fofxy:9:6,' '); - fpofxy := exp(x) + y; (*f'(x,y)*) - x:=x- (fofxy/fpofxy); - gofxy := sin(x*y) + x + y - 1; (*g(x,y)*) - writeln (gofxy:9:6); - gpofxy := (x * cos(x*y)) + 1; (*g'(x,y)*) - y := y - (gofxy/gpofxy); - i:=i+1 -UNTIL (i=21) OR convergence; -writeln; writeln; -IF NOT convergence -THEN BEGIN - writeln; write ('****ERROR**** ITERATION FUNCTION FAILED TO '); - writeln ('CONVERGE IN ',n:2, ' ITERATIONS.'); - END -END. \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/MSA326B.PAS b/software/CPM/CPM21_MTPUG_09/MSA326B.PAS deleted file mode 100644 index 198adf3..0000000 --- a/software/CPM/CPM21_MTPUG_09/MSA326B.PAS +++ /dev/null @@ -1,54 +0,0 @@ -PROGRAM TRIDMATRIX (INPUT,OUTPUT); -(**************************************************************************** -LAWRENCE ADKINS, MSA 326, SECT. 1, COMPUTER PROJECT NO. 2. -CONTE AND DEBOORE, PAGE 123 (3.2-9) SPRING, 1979 - **************************************************************************** -USE THE TRID PROCEDURE TO SOLVE THE LINEAR SYSTEM - - 2*(1+H*H) * X(1) + X(2) = 1 - X(I-1) - 2*(1+H*H) * X(I) + X(I+1) = 0, FOR I=2,3,...,N-1 - X(N-1) - 2*(1+H*H) * X(N) = 1 -FOR N=30, H=0.1 - ****************************************************************************) - -CONST N=30; H=0.1 -VAR X,A,B,C,D: ARRAY[1..N] OF REAL; - M: REAL; K: INTEGER; -PROCEDURE CREATEMATRIX; - BEGIN - FOR K=1 TO N - DO BEGIN A[K] := 1; D[K] := -2*(1+H*H); C[K] := 1; B[K] := 0 END; - A[1] := 0; C[N] := 0; B[1] := 1; B[N] := 1 - END; -PROCEDURE TRID; - PROCEDURE DIAGERROR; - BEGIN - WRITELN ('**ERROR** FOUND A ZERO-VALUED DIAGONAL ELEMENT. PGM ABORTED.'); - HALT - END; - BEGIN (*ELIMINATION*) - FOR K:= 2 TO N - DO BEGIN - IF D[K-1] = 0 - THEN DIAGERROR - ELSE BEGIN - M := A[K] / D[K-1]; - D[K] := D[K] - (M* C[K-1]); - B[K] := B[K] - (M* B[K-1]) - END - END; - IF D[N] = 0 - THEN DIAGERROR - ELSE BEGIN (*BACK SUBSTITUTION*) - WRITELN; WRITELN; WRITELN ('THE SOLUTION VECTOR Y IS '); WRITELN; - WRITELN ('K Y(K)'); WRITELN; - X[N] := B[N] / D[N]; WRITELN (N:2,' ',X[N]); - FOR K:= N-1 DOWNTO 1 - DO BEGIN - X[K] := (B[K] - (C[K] * X[K+1])) / D[K]; - WRITELN (K*2, ' ', X[K]) - END - END; - WRITELN; WRITELN - END; -BEGIN CREATEMATRIX; TRID END. - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/MSA326C.PAS b/software/CPM/CPM21_MTPUG_09/MSA326C.PAS deleted file mode 100644 index 09e0956..0000000 --- a/software/CPM/CPM21_MTPUG_09/MSA326C.PAS +++ /dev/null @@ -1,124 +0,0 @@ -PROGRAM EIGENVALUE (INPUT,OUTPUT); -(**************************************************************************** -LAWRENCE ADKINS, MSA 326, SECT 1, COMPUTER PROJECT NO. 3. -CONTE AND DEBOORE, PAGE 180 (3.9-5), SPRING, 1979 - **************************************************************************** -USE THE POWER METHOD TO ESTIMATE THE MAXIMUM-MODULUS EIGENVALUE, AND A -CORRESPONDING EIGENVECTOR FOR THE TRIDIAGONAL MATRIX A OF ORDER N=20 -WITH A[I,I] = 4, A[I+1,I] = A[I,I+1] = -1 FOR I=1,2,...,N, -AND COMPARE THE RESULT WITH THE EXACT MAXIMUM EIGENVALUE OBTAINED BY - LAMBDA = 4 + (-2) * COS ((J*PI)/N+1) , J=1,2,...,N -WHERE WE CHOOSE J=1 IN ORDER TO OBTAIN THE MAXIMUM EIGENVALUE. - ****************************************************************************) -CONST N=20; KK=1; EPSILON=0.005; MAXIT=10; D=4; E=-1; PI=3.1415926; -TYPE VECTOR = ARRAY [1..N] OF REAL; - MATRIX = ARRAY [1..N,1..N] OF REAL; -VAR B, BM: MATRIX; - RATIO, BMZ, ZM, BZM, Z: VECTOR; - I,J,K: 1..N; M: INTEGER; - SUM, DIFFERENCE, RMAX, RMIN, LAMBDA: REAL; -PROCEDURE CREATEMATRIX; - BEGIN - FOR K:=1 TO N - DO BEGIN - FOR J:=1 TO N DO B[K,J] := 0; - Z[K] := 1 - END; - B[1,1] := D; B[1,2] := E; - FOR K:= 2 TO N-1 - DO BEGIN B[K,K-1] := E; B[K,K] := D; B[K,K+1] := E END; - B[N,N-1] := E; B[N,N] := D - END; -PROCEDURE INITIALIZE; - BEGIN - M:= 0; - FOR I:= 1 TO N - DO BEGIN - FOR J:= 1 TO N DO BM[I,J] := 0; - BM[I,I] := 1 - END - END; -PROCEDURE MULTVECTOR (B:MATRIX; X: VECTOR; VAR Y: VECTOR); - BEGIN - FOR J:= 1 TO N (* ALL ROWS OF B*) - DO BEGIN - SUM := 0; - FOR I:= 1 TO N (*ALL COLUMNS OF B*) - DO SUM := SUM + B[J,I] * X[I]; - Y[J] := SUM - END - END; -PROCEDURE MULTZM; - BEGIN FOR J := 1 TO N DO ZM[J] := (1/BMZ[KK])*BMZ[J] END; -PROCEDURE DIVRATIO; - BEGIN FOR J:= 1 TO N DO RATIO[J] := ABS(BZM[J]/ZM[J]) END; -PROCEDURE MAXMINCHECK; - BEGIN - RMAX := 0; RMIN := RATIO [1]; - FOR J := 2 TO N - DO BEGIN - IF RATIO [J] < RMIN THEN RMIN := RATIO[J]; - IF RATIO [J] > RMAX THEN RMAX := RATIO[J] - END - END; -PROCEDURE WRITETABLE; - BEGIN - WRITE (M:2, ' '); - FOR J:= 1 TO N - DO BEGIN - IF J<> 1 THEN WRITE (' '); - WRITE (BMZ[J]:14:6, ' ', ZM[J]:14:6, ' '); - WRITE (BZM[J]:14:6, ' ', RATIO[J]:14:6, ' '); - IF J=N THEN WRITELN (DIFFERENCE:14:6); - WRITELN - END - END; -PROCEDURE MULTMATRIX; - VAR C:MATRIX; - BEGIN - FOR I:= 1 TO N - DO BEGIN - FOR J:= 1 TO N - DO BEGIN - SUM := 0; - FOR K:= 1 TO N DO SUM := SUM + B[I,K] * BM[K,J]; - C[I,J] := SUM - END - END; - FOR I:= 1 TO N DO FOR J:= 1 TO N DO BM[I,J] := C[I,J] - END; -PROCEDURE COMPARE; - BEGIN - WRITELN; WRITELN; WRITELN; - WRITELN ('COMPARE THIS RESULT WITH THE EXACT MAXIMUM EIGENVALUE...'); - WRITELN; WRITELN (' J LAMBDA(J)'); WRITELN; - FOR J:= 1 TO N - DO BEGIN - LAMBDA := D + (2*E * COS((J*PI)/(N+1))); - WRITELN (J:2, ' ', LAMBDA) - END - END; - -BEGIN CREATEMATRIX; INITIALIZE; -WRITE ('RESULTS OF USE OF THE POWER METHOD IN FINDING LARGEST EIGENVALUE'); -WRITELN ('OF THE INPUTTED MATRIX'); WRITELN; -WRITE ('M BMZ ZM BZM '); -WRITELN('BMZ/ZM RMAX-RMIN'); -WRITE ('ITER. NUMERATOR DENOMINATOR '); -WRITELN(' RATIO DIFFERENCE'); -WRITELN; -REPEAT - MULTVECTOR (BM,Z,BMZ); (*BMZ:=BM*Z*) - MULTZM; (*ZM:=(1/BMZ[KK])*BMZ*) - MULTVECTOR (B,ZM, BZM); (*BZM:=B*ZM*) - DIVRATIO; (*RATIO:=BZM/ZM*) - MAXMINCHECK; (*CHECK IF RATIO IS CANDIDATE FOR RMAX OR RMIN*) - DIFFERENCE := ABS(RMAX-RMIN); - WRITETABLE; (*PRINT OUT THE VECTORS IN A TABLE*) - MULTMATRIX; (*BM:=B*BM*) - M:=M+1 -UNTIL (M=MAXIT+1) OR (DIFFERENCE < EPSILON); -COMPARE -END. - -  \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/MSA326D.PAS b/software/CPM/CPM21_MTPUG_09/MSA326D.PAS deleted file mode 100644 index af5d217..0000000 --- a/software/CPM/CPM21_MTPUG_09/MSA326D.PAS +++ /dev/null @@ -1,53 +0,0 @@ -PROGRAM GAUNTEGRATE (INPUT,OUTPUT); -(**************************************************************************** -LAWRENCE ADKINS, MSA 326, SECT 1, COMPUTER PROJECT NO. 4 -CONTE AND DEBOORE, PAGE 306(5.4-6), SPRING, 1979 - **************************************************************************** -SOLVE PROBLEMS 5.3-3(A,B,C) ON PAGE 298 USING THE GAUSSIAN FIVE POINT FORMULA -FORMULA AS AN APPROXIMATION TO THE REQUIRED INTEGRALS. - -CHANGE /INTEGRAL FROM 0 TO 1 OF (F(X) DX)/ TO -/ (1/2) * INTEGRAL FROM -1 TO 1 OF (G(T) DT)/ -WHICH IS APPROXIMATELY EQUAL TO -/ (1/2) * SUMMATION FROM K=0 TO 4 OF (AWEIGHT[K] * G(XIPOINT[K])) / -IN ALL THREE CASES ONLY THE FUNCTION G CHANGES; THE WEIGHTS AND POINTS -USED REMAIN THE SAME. THEY ARE COPIED FROM A TABLE ON PAGE 304 OF -CONTE AND DEBOORE. - ****************************************************************************) -CONST N=4; (*5-1:=4*) -TYPE TABLE = RECORD - XIPOINT : ARRAY [0..N] OF REAL; - AWEIGHT : ARRAY [0..N] OF REAL - END; -VAR GAUSS: TABLE; I,C: REAL; J,K: 0..N; - -PROCEDURE FILLINGAUSS; - BEGIN - GAUSS.XIPOINT[2] := 0; GAUSS.AWEIGHT[2] := 0.56888889; - GAUSS.XIPOINT[4] := 0.90617985; GAUSS.AWEIGHT[4] := 0.23692689; - GAUSS.XIPOINT[0] :=-0.90617985; GAUSS.AWEIGHT[0] := 0.23692689; - GAUSS.XIPOINT[3] := 0.53846931; GAUSS.AWEIGHT[3] := 0.47862867; - GAUSS.XIPOINT[1] :=-0.53846931; GAUSS.AWEIGHT[1] := 0.47862867; - END; -FUNCTION F1 (T:REAL): REAL; - BEGIN F1 := ((T+1)/2)*EXP(-(T+1)/2) END; -FUNCTION F2 (T:REAL): REAL; - BEGIN F2 := ((T+1)/2)*SIN( (T+1)/2) END; -FUNCTION F3 (T:REAL): REAL; - VAR TEMP: REAL; - BEGIN TEMP := 1 + SQR((T+1)/2); F3 := SQRT(TEMP*TEMP*TEMP) END; -PROCEDURE SOLVE (CONSTANT: REAL; FUNCTION G(T: REAL): REAL); - BEGIN - I:= 0; - FOR J:= 0 TO (N-1) - DO I := I + (GAUSS.AWEIGHT[J] * G(GAUSS.XIPOINT[J])); - I := CONSTANT * I - END; - -BEGIN -FILLINGAUSS; C:= 0.5; WRITELN ('R E S U L T S'); -SOLVE (C,F1); WRITELN ('PROB 5.3-3-A) := ',I); -SOLVE (C,F2); WRITELN ('PROB 5.3-3-B) := ',I); -SOLVE (C,F3); WRITELN ('PROB 5.3-3-C) := ',I) -END. - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/PASERROR.PAS b/software/CPM/CPM21_MTPUG_09/PASERROR.PAS deleted file mode 100644 index c54c6ee..0000000 --- a/software/CPM/CPM21_MTPUG_09/PASERROR.PAS +++ /dev/null @@ -1,22 +0,0 @@ -PROGRAM display_pascal_error_text; - -VAR errfile: text; - error_num, users_error_num, ioreturn_value: integer; - error_text: STRING; -BEGIN -write ('What is the Pascal/MT+ error number that you want the text of? '); -readln (users_error_num); -error_text := 'MTERRS.TXT'; -open (errfile, error_text, ioreturn_value); -IF ioreturn_value > 4 -THEN BEGIN writeln ('File ', error_text, ' not found.'); exit END; -read (errfile, error_num); -WHILE (error_num <> users_error_num) AND NOT eof (err_file) -DO BEGIN readln (err_file); read (err_file, error_num) END; -IF NOT EOF (err_file) -THEN BEGIN - readln (errfile, error_text); - writeln ('Error ', error_num, ' is: ', error_text) - END -ELSE writeln ('Unexplainable error. ') -END. \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/PLANE.SRC b/software/CPM/CPM21_MTPUG_09/PLANE.SRC deleted file mode 100644 index d1a19e0..0000000 --- a/software/CPM/CPM21_MTPUG_09/PLANE.SRC +++ /dev/null @@ -1,374 +0,0 @@ -PROGRAM PLANE; (*D.COVILL - from BASIC program by - John L. Eggert*) -CONST VERSION = 'PLANE version 1.2 7/10/81 D.Covill'; - -VAR ESC,GRAPHON,GRAPHOFF: STRING; - ERASE,HOME,REVON,REVOFF: STRING; - CH: CHAR; - - ALT,ALT0,ALT2,CLIMB,CLIMB0,CLIMB2:INTEGER; - SPEED,SPEED0,SPEED2,POWER,POWER0,POWER2:INTEGER; - HEAD,HEAD0,HEAD2,FUEL,FUEL0,FUEL2:INTEGER; - ATT,ATT0,ATT2:INTEGER; {Attack angle} - DIST,DIST2:INTEGER; {Distance to goal} - TURN:INTEGER; {-1=LEFT, +1=RIGHT, 0=CENTER} - WAITLOOP:INTEGER; - STALLED:BOOLEAN; - -LABEL 999; -(*----------------------------------------------*) -EXTERNAL FUNCTION @BDOS(FUNC:INTEGER; PARM:WORD):INTEGER; -(*----------------------------------------------*) -PROCEDURE INITIALIZE; -BEGIN - ESC := CHR($1B); {Escape} - GRAPHON := CONCAT(ESC,'F'); - GRAPHOFF := CONCAT(ESC,'G'); - ERASE := CONCAT(ESC,'E'); - HOME := CONCAT(ESC,'H'); - REVON := CONCAT(ESC,'p'); - REVOFF := CONCAT(ESC,'q'); - WRITE(ERASE); - WRITE(ESC,'x1'); {Enable line 25} - - ALT:=2500; CLIMB:=6; FUEL:=980; - HEAD:=280; POWER:=75; SPEED:=125; - HEAD2:=280; ATT:=7; - DIST:=32000; DIST2:=30000; - WAITLOOP := 60; {Approx 1 second} -END {INITIALIZE}; -(*----------------------------------------------*) -FUNCTION BOUND(WHAT,LO,HI:INTEGER):INTEGER; -BEGIN - IF WHATHI THEN BOUND:=HI - ELSE BOUND:=WHAT; -END {BOUND}; -(*----------------------------------------------*) -PROCEDURE CURSOR(L,C:INTEGER); - {move cursor to line L, column C (starting from 1,1)} -BEGIN - WRITE(ESC,'Y',CHR(L+31),CHR(C+31)); -END {CURSOR}; -(*----------------------------------------------*) -PROCEDURE COMM(L:INTEGER; STR:STRING); - {Display STR in line L of the COMM box on the panel} -VAR I:INTEGER; -BEGIN - IF L=1 THEN WRITE(CHR($07)); {bell} - CURSOR(2+L,48); FOR I:=1 TO 24 DO WRITE(' '); - CURSOR(2+L,48); WRITE(STR); -END {COMMUNICATE}; -(*----------------------------------------------*) -PROCEDURE DISPLAY; - {Display all status instruments, clear old readings} -VAR I,L,N:INTEGER; CH:CHAR; -BEGIN - CURSOR(15,5); WRITE(ALT:4); - CURSOR(15,16); WRITE(CLIMB:3); - CURSOR(ROUND(13-(ALT0/500)),8); WRITE(' '); - CURSOR(ROUND(13-(ALT/500)),8); WRITE(GRAPHON,'aa',GRAPHOFF); - N := BOUND(CLIMB0,-25,25); - CURSOR(ROUND(8-(N/5)),19); WRITE(' '); - N := BOUND(CLIMB,-25,25); - CURSOR(ROUND(8-(N/5)),19); WRITE(GRAPHON,'aa',GRAPHOFF); - CURSOR(4,33); WRITE(HEAD:3); - CURSOR(8,56); WRITE(FUEL:4); - N := ROUND((SPEED-40)*7/20)+1; IF N>71 THEN N:=71; - CURSOR(18,2); - WRITE(REVON); FOR I:=2 TO N DO WRITE(' '); - WRITE(REVOFF); FOR I:=N+1 TO 71 DO WRITE(' '); - N := ROUND(POWER*7/10)+1; IF N>71 THEN N:=71; - CURSOR(21,2); - WRITE(REVON); FOR I:=2 TO N DO WRITE(' '); - WRITE(REVOFF); FOR I:=N+1 TO 71 DO WRITE(' '); - - L := 14-((ATT0+6)DIV 3); {clear old ATT display} - CURSOR(L,32); WRITE(' '); - CURSOR(10,32); WRITE('-----'); {may be overwritten} - L := 14-((ATT+6)DIV 3); {new ATT display line} - CASE (ATT MOD 3) OF - 0: CH := '{'; {low} - 1: CH := 'a'; {center} - 2: CH := 'z'; {high} - END; - CURSOR(L,32); - WRITE(GRAPHON,CH,CH,REVON,' ',REVOFF,CH,CH,GRAPHOFF); - CURSOR(25,1); -END {DISPLAY}; -(*----------------------------------------------*) -PROCEDURE DOTURN(VAL:INTEGER); -BEGIN - IF VAL=TURN THEN EXIT; - CASE TURN+1 OF - 0: BEGIN CURSOR(9,28); WRITE(' '); - CURSOR(11,38); WRITE(' '); END; - 1: BEGIN CURSOR(10,27); WRITE(' '); - CURSOR(10,38); WRITE(' '); END; - 2: BEGIN CURSOR(11,28); WRITE(' '); - CURSOR(9,38); WRITE(' '); END; - END; - TURN := VAL; - CASE TURN+1 OF - 0: BEGIN CURSOR(9,28); WRITE(GRAPHON,'z a',GRAPHOFF); - CURSOR(11,38); WRITE(GRAPHON,'z a',GRAPHOFF); - END; - 1: BEGIN CURSOR(10,27); WRITE('----'); - CURSOR(10,38); WRITE('----'); END; - 2: BEGIN CURSOR(11,28); WRITE(GRAPHON,'a z',GRAPHOFF); - CURSOR(9,38); WRITE(GRAPHON,'a z',GRAPHOFF); - END; - END; -END {DOTURN}; -(*----------------------------------------------*) -PROCEDURE DISASTER(MSG:STRING); -VAR I:INTEGER; -BEGIN - FOR I:=1 TO 10 DO BEGIN - CURSOR(24,5); WRITE(REVON,MSG); - END; - GOTO 999; -END {DISASTER}; -(*----------------------------------------------*) -PROCEDURE COMPUTE; - {Compute new values for performance parameters} -VAR NEWCLRATE:REAL; -BEGIN - HEAD := HEAD + (2*TURN); - IF HEAD<1 THEN HEAD:=HEAD+360; - IF HEAD>360 THEN HEAD:=HEAD-360; - - IF SPEED<55 THEN BEGIN - CURSOR(12,52); WRITE(REVON,'STALL WARNING',REVOFF); - STALLED := TRUE; - END; - IF STALLED THEN BEGIN - CURSOR(12,52); WRITE(' '); - IF SPEED>80 THEN STALLED:=FALSE - ELSE BEGIN - CURSOR(12,52); {This will make it blink} - WRITE(REVON,'STALL WARNING',REVOFF); - ATT := ATT-3; - END; - END; - - ATT := BOUND(ATT,-45,45); - NEWCLRATE := -32 + SPEED*SIN(ATT*6.28319/180); - ALT := ALT + CLIMB + ROUND(NEWCLRATE/2); - ALT := BOUND(ALT,0,5000); - CLIMB := CLIMB + ROUND(NEWCLRATE); - CLIMB := BOUND(CLIMB,-50,25); - CLIMB := ROUND(CLIMB0*0.7 + CLIMB*0.3); {Smooth it} - - IF FUEL<=0 THEN POWER:=0; - POWER := BOUND(POWER,0,100); - SPEED := ROUND(SPEED*0.9 + POWER*0.17 - CLIMB*0.4); - IF SPEED>240 THEN - DISASTER('YOUR WINGS JUST FELL OFF DUE TO EXCESS SPEED'); - SPEED := BOUND(SPEED,0,240); - FUEL := FUEL-ROUND(POWER/12); -END {COMPUTE}; -(*----------------------------------------------*) -PROCEDURE CALLTHETOWER; - {Check distance and issue new instructions} -VAR MSG:STRING; GLIDE:INTEGER; - (*-----------*) -PROCEDURE ADDCH(CH:CHAR); -BEGIN MSG := CONCAT(MSG,CH); END; - (*-----------*) -BEGIN - DIST2 := DIST2-500; - IF DIST2=29500 THEN - COMM(1,'YOU ARE IN RADAR CONTACT') - ELSE IF DIST2=29000 THEN BEGIN - COMM(1,'TURN TO HEADING OF 242'); - HEAD2:=242; END - ELSE IF DIST2=28000 THEN - COMM(1,'DESCEND TO 1500 FEET') - ELSE IF DIST2=21000 THEN BEGIN - COMM(1,'TURN TO HEADING OF 304'); - HEAD2:=304; END - ELSE IF DIST2=20000 THEN - COMM(1,'REDUCE AIRSPEED TO 90') - ELSE IF DIST2=18000 THEN - COMM(1,'BEGIN DESCENT 10 fps') - ELSE IF DIST2<17500 THEN BEGIN - {Runway is 3000 ft from +500 to -2500} - IF DIST<500 THEN BEGIN - IF DIST<-2800 THEN - IF ALT<100 THEN - DISASTER('YOU HAVE OVERSHOT THE RUNWAY AND CRASHED') - ELSE - DISASTER('YOU HAVE JUST BUZZED THE FIELD - NOW WHAT?'); - MSG := ''; - WRITE([ADDR(ADDCH)],2500+DIST,' FT OF RUNWAY LEFT'); - COMM(2,MSG); END - ELSE BEGIN - {On the glidepath} - GLIDE := ROUND(0.0875*DIST); - IF ALTGLIDE+50 THEN BEGIN - MSG := ''; - WRITE([ADDR(ADDCH)],'YOU ARE ',ALT-GLIDE,' FT HIGH'); - COMM(1,MSG); END - ELSE COMM(1,' '); - END; - END; -END {CALLTHETOWER}; -(*----------------------------------------------*) -PROCEDURE RUNIT; -VAR I,B:INTEGER; X:REAL; -LABEL 100; -BEGIN -REPEAT -100: - COMPUTE; - FOR I:=1 TO WAITLOOP DO BEGIN - B := @BDOS(6,WRD($FF)); {Direct Console Input} - {if there was no input B will be $00} - CASE CHR(B) OF - 'X': EXIT; - '4': DOTURN(-1); {Left} - '5': DOTURN(0); {Home} - '6': DOTURN(+1); {Right} - '8': ATT:=ATT+1; {Up} - '2': ATT:=ATT-1; {Down} - 'F': POWER:=POWER+2; - 'D': POWER:=POWER-2; - END {CASES}; - X := SQRT(7.7); {Kill some time} - END {1-SECOND LOOP}; - DISPLAY; - ALT0:=ALT; CLIMB0:=CLIMB; HEAD0:=HEAD; - FUEL0:=FUEL; POWER0:=POWER; SPEED0:=SPEED; - ATT0:=ATT; - IF ABS(HEAD-HEAD2) < 4 THEN BEGIN - {Making progress toward the goal} - DIST := DIST-ROUND(SPEED*1.5); - IF DIST<=DIST2 THEN CALLTHETOWER; - END; - UNTIL ALT<=5; - - IF CLIMB<-10 THEN - DISASTER('YOU JUST CRASHED INTO THE GROUND'); - IF DIST>500 THEN - DISASTER('WHAT ARE YOU DOING IN THIS CORNFIELD?'); - IF SPEED>100 THEN BEGIN - COMM(1,CONCAT(REVON,' BOUNCE ',REVOFF)); - ALT:=50; GOTO 100; END; - COMM(1,' --LANDED OK--'); - POWER:=0; ALT:=0; SPEED:=0; CLIMB:=0; - DISPLAY; -END {RUNIT}; -(*----------------------------------------------*) -PROCEDURE PRINTPANEL; - (*Print the instrument panel on the terminal*) - PROCEDURE PANEL; (*PRINTPANEL is too big in one piece*) - BEGIN -WRITELN -('faaaaaaaaasaasaaaaaaasaaaaaaaaaaaaaaaaaaaaaaasaaaaaaaaaaaaaaaaaaaaaaaaac'); -WRITELN -('` ALTITUDE` ` CLIMB ` faaaaaaaaaaaaac vaaaa COMMUNICATIONS aaaaat'); -WRITELN -('` 5000 ` ` 25 ` ` HEADING ` ` `'); -WRITELN -('` 4500 ` ` 20 ` ` ... ` ` `'); -WRITELN -('` 4000 ` ` 15 ` eaaaaaaaaaaaaad eaaaaaaaaaaaaaaaaaaaaaaaaat'); -WRITELN -('` 3500 ` ` 10 ` xzzzzzzzzzzzzzy faaaaaaaaaaac `'); -WRITELN -('` 3000 ` ` 5 ` x y ` FUEL ` `'); -WRITELN -('` 2500 ` ` 0 ` } } ` .... ` `'); -WRITELN -('` 2000 ` ` -5 ` } } eaaaaaaaaaaad `'); -WRITELN -('` 1500 ` `-10 ` } ---- ----- ----} `'); -WRITELN -('` 1000 ` `-15 ` } } faaaaaaaaaaaaaaac `'); -WRITELN -('` 0500 ` `-20 ` } } ` ` `'); -WRITELN -('` 0000 ` `-25 ` y x eaaaaaaaaaaaaaaad `'); -WRITELN -('vaaaaaaaaabaabaaaaaaat y x `'); -WRITELN -('` .... ` ` .. ` zzzzzzzzzzzzz `'); -WRITELN -('vaaaaaaaaauaauaaaaaaauaaaaaaa AIRSPEED aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaat'); -WRITELN -('`40 60 80 100 120 140 160 180 200 `'); -WRITELN -('` `'); -WRITELN -('vaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa POWER aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaat'); -WRITELN -('`0 10 20 30 40 50 60 70 80 90 100`'); -WRITELN -('` `'); -WRITELN -('eaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaad'); - END {PANEL}; -BEGIN - WRITE(ERASE,GRAPHON); - PANEL; - WRITE(GRAPHOFF,HOME); -END {PRINTPANEL}; -(*----------------------------------------------*) -PROCEDURE INSTRUCT; - (*Print Instructions*) -BEGIN -WRITELN('This version by D.Covill based on BASIC original by J.Eggert.'); - WRITELN; -WRITE('This program simulates an instrument landing in a light '); -WRITELN('aircraft.'); -WRITELN('You will see a representation of a pilot''s instrument panel'); -WRITELN(' with real-time updates at 1-second intervals.'); -WRITELN; -WRITELN('When the game starts, you will be flying level at 2500 feet.'); -WRITELN('Instructions from the ground radar controller will appear'); -WRITELN(' in the upper RH corner of the screen. He/she will attempt'); -WRITELN(' to talk you down safely. Don''t screw up!'); -WRITELN; -WRITELN('Please note the following:'); -WRITELN(' The plane will stall below 60 MPH'); -WRITELN(' Touchdown above 100 MPH results in a 50-foot bounce'); -WRITELN(' Descent rate at touchdown must be less than 10 fps'); -WRITELN(' A 100-foot hill is at the far end of the runway'); -WRITELN(' You do not have an unlimited supply of fuel'); -WRITELN(' You only get nearer the field when on the proper heading'); -WRITELN(' A forced landing is possible, if touchdown is gentle'); -WRITELN; -WRITELN(' DEPRESS RETURN FOR NEXT PAGE'); - READLN; -WRITELN('THE FOLLOWING KEYS ARE YOUR CONTROLS-'); -WRITELN(' 4-LEFT ARROW - TURN LEFT'); -WRITELN(' 6-RIGHT ARROW - TURN RIGHT'); -WRITELN(' 5-HOME - WINGS LEVEL'); -WRITELN(' 8-UP ARROW - NOSE UP'); -WRITELN(' 2-DOWN ARROW - NOSE DOWN'); -WRITELN(' F - FORWARD THROTTLE'); -WRITELN(' D - DECREASE THROTTLE'); -WRITELN; -WRITELN(' X - BAIL OUT (TO CP/M)'); -WRITELN; -WRITELN('THEY MAY BE DEPRESSED REPEATEDLY FOR GROSS CHANGES'); -WRITELN(' DEPRESS RETURN TO BEGIN'); - READLN; -END {INSTRUCT}; -(*----------------------------------------------*) -BEGIN - WRITELN(VERSION); WRITELN; - WRITELN('DO YOU WANT INSTRUCTIONS (Y/N)?'); - READ(CH); IF CH='Y' THEN INSTRUCT; - INITIALIZE; - PRINTPANEL; - RUNIT; -999: - CURSOR(25,1); WRITE(ESC,'E'); {Erase line 25} - CURSOR(24,1); WRITE(GRAPHOFF,REVOFF); -END. \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/ROUTTAB.PAS b/software/CPM/CPM21_MTPUG_09/ROUTTAB.PAS deleted file mode 100644 index f1606e3..0000000 --- a/software/CPM/CPM21_MTPUG_09/ROUTTAB.PAS +++ /dev/null @@ -1,484 +0,0 @@ -{########################################################################## -#### #### -#### Full program name: ROUTINE_TABLE_MODULE_FOR_TYPE_CHECKER_PROGRAM.#### -#### File name: ROUTTAB.PAS. #### -#### Support modules reqd: PASLIB.ERL, SCANNER. #### -#### Run time environment: . #### -#### Compile time environment: MT MicroSYSTEMS Pascal/MT+v5.25. #### -#### Link time environment: MT MicroSYSTEMS Linkmt v5.1. #### -#### Copyright (C) 1982 by Haldo Products, Inc. All rights reserved. #### -#### 56 Camille Ln, E. Patchogue, NY 11772 #### -#### Programmer: Lawrence Adkins. #### -#### Module Development/Maintenance History: #### - 6-NOV-81 Vers 1.0. File just created. - 12-NOV-81 Development of this version completed. - 9-JAN-82 Vers 2.0. development begins. - 1-MAR-82 Development of this version complete. - 6-MAR-82 Vers 2.1. Conformant array stuff added. - 19-APR-82 Vers 2.2. No changes made. -#### #### -##########################################################################} - - -MODULE ROUTINE_TABLE_HANDLER; - -{$I B:TYPECHK.DEC } - -VAR - last_rt_entry: integer; { index to last filled element of routine table } - token: EXTERNAL token_type; - tokenbuf: EXTERNAL string132; - infile: EXTERNAL text; - outfile: EXTERNAL text; - last_entry_point_name: EXTERNAL string132; - symbols_avail_for_external_reference: EXTERNAL boolean; - last_tt_entry: EXTERNAL integer; - extern_declaration: boolean; - exit_keywords: EXTERNAL SET OF token_type; - debug: EXTERNAL boolean; - -EXTERNAL PROCEDURE get_next_token; -EXTERNAL PROCEDURE error (pascal_error_no: integer); -EXTERNAL PROCEDURE @hlt; -EXTERNAL PROCEDURE mark ({VAR} p: integer); -EXTERNAL PROCEDURE release (p: integer); -EXTERNAL FUNCTION tm1find_prev_occurance_of_type_id - (VAR name_to_find: string132; - last_index: integer; - VAR ret_index: integer; - VAR type_table: ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec): - boolean; - - -{#############################################################################} -{ Initialize this module's private variables. } -{#############################################################################} -PROCEDURE rminit_routine_table_module; - - BEGIN - last_rt_entry := 0; - END; - - - - - - -{#############################################################################} -(*-- Assuming the first symbol has already been scanned, ----- parse the following Pascal/MT+ productions: ----- ::= { ;} ----- ::= | ----- ::= EXTERNAL | ----- ----- ::= EXTERNAL | ----- ----- ::= ----- ::= ----- ::= ----- *) -{#############################################################################} -PROCEDURE rmadd_new_routines_to_routine_table - (VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec; - VAR routine_table: ARRAY [rtlobound..rthibound: natural] OF t_rout_tab_rec); - - CONST action = 'Handling Routines...'; - VAR saw_a_begin_token: boolean; - BEGIN - writeln; writeln (action); writeln (outfile); writeln (outfile, action); - exit_keywords := [tokexternal, tokproc, tokfunc]; - WHILE NOT eof (infile) { outer file } - DO BEGIN - IF (token IN exit_keywords) - THEN BEGIN - extern_declaration := token = tokexternal; - IF token = tokexternal THEN get_next_token; - rthandle_routine_heading_guts - (symbols_avail_for_external_reference, type_table, routine_table); - IF debug THEN error (0); - rtremove_duplicate_routine_entry (routine_table); - IF NOT extern_declaration - THEN rtskip_routine_body (type_table, routine_table) - ELSE get_next_token - END - ELSE get_next_token - END - END; - - - - -{#############################################################################} -(*-- Parse the BNF production. See the Pascal manuals. *) -{#############################################################################} -PROCEDURE rtskip_routine_body - (VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec; - VAR routine_table: ARRAY [rtlobound..rthibound: natural] OF t_rout_tab_rec); - - BEGIN - REPEAT - get_next_token - UNTIL (token IN exit_keywords) OR (token = tokbegin); - WHILE (token IN exit_keywords) { some local routine declarations } - DO BEGIN - rthandle_routine_heading_guts (false, type_table, routine_table); - rtrecurse_skip_routine_body (type_table, routine_table) - END; - { Assume that we are now at the outer begin of this block } - REPEAT - get_next_token; - WHILE (token = tokend) AND (NOT eof (infile)) - DO BEGIN - get_next_token; - IF token = toksemicolon - THEN BEGIN - get_next_token; - IF (token IN exit_keywords) OR (token = tokbegin) - THEN exit - END - END - UNTIL eof (infile) - END; - - - - -PROCEDURE rtrecurse_skip_routine_body - (VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec; - VAR routine_table: ARRAY [rtlobound..rthibound: natural] OF t_rout_tab_rec); - - BEGIN rtskip_routine_body (type_table, routine_table) END; - - - - -{#############################################################################} -{--- Insert the specified info into a record linked onto the routine table-- ----- The routine being parsed has parameters. } -{#############################################################################} -PROCEDURE rtupdate_parmlist - (VAR type_id: string132; - n_of_stacked_parms: integer; - param_class: tparm_class; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec; - VAR routine_table: ARRAY [rtlobound..rthibound: natural] OF t_rout_tab_rec); - - VAR ptr, last_ptr, top_of_addl_parm_list: t_ptr_to_next_parm; - i, type_index: integer; - b: boolean; - BEGIN - { Assume that at least one additional parm is to to added to parmlist } - new (ptr); last_ptr := ptr; top_of_addl_parm_list := ptr; - b := tm1find_prev_occurance_of_type_id - (type_id, last_tt_entry, type_index, type_table); - WITH ptr^ - DO BEGIN - parm_indx_to_type_table := type_index; - parm_class := param_class; - rest_of_parm_list := nil - END; - IF n_of_stacked_parms > 1 - THEN FOR i := 2 TO n_of_stacked_parms - DO BEGIN - new (ptr); - WITH ptr^ - DO BEGIN - parm_indx_to_type_table := type_index; - parm_class := param_class; - rest_of_parm_list := nil - END; - last_ptr^.rest_of_parm_list := ptr; - last_ptr := ptr - END; - { Add the additional parm list to the existing parmlist } - ptr := routine_table [last_rt_entry]. parm_list; - IF ptr = nil - THEN routine_table [last_rt_entry]. parm_list := top_of_addl_parm_list - ELSE BEGIN - WHILE ptr^.rest_of_parm_list <> nil - DO ptr := ptr^. rest_of_parm_list; - ptr^.rest_of_parm_list := top_of_addl_parm_list - END - END; - - - - - - - - - - - - - - - - - - -{#############################################################################} -(*-- Assuming that the first symbol has already been scanned, ----- parse the following Pascal/MT+ productions: ----- ::= PROCEDURE INTERRUPT [ ] ; | ----- PROCEDURE [ ] ; | ----- PROCEDURE ; ----- ::= FUNCTION : ----- ; ----- ::= | ----- ----- ::= [ ] | ----- *) -{#############################################################################} -PROCEDURE rthandle_routine_heading_guts - ( rtinsert_flag: boolean; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec; - VAR routine_table: ARRAY [rtlobound..rthibound: natural] OF t_rout_tab_rec); - - BEGIN - get_next_token; { should be routine identifier } - IF (token = toklbracket) - OR ((token = tokidentifier) AND (tokenbuf = 'INTERRUPT')) - THEN BEGIN { get past overlay/interrupt syntax stuff } - REPEAT get_next_token UNTIL token = tokrbracket; - get_next_token - END; - IF rtinsert_flag - THEN BEGIN - last_entry_point_name := tokenbuf; - rtplace_id_into_routine_table (tokenbuf, routine_table) - END; - get_next_token; { should be lparen, scolon, or colon tokens } - IF token = toklparen - THEN BEGIN - rt1handle_formal_parmlist (rtinsert_flag, type_table, routine_table); - get_next_token; { should be func's colon or proc's scolon } - END; - IF token = tokcolon - THEN BEGIN - get_next_token; { should be result_type_id } - IF rtinsert_flag - THEN rtupdate_parmlist (tokenbuf, 1, func_value, type_table, - routine_table); - get_next_token { should be scolon token } - END - END; - - - - - - - - - - - - - - - - - - - - -{#############################################################################} -(*-- Assuming the first symbol has already been scanned, ----- parse the following Pascal/MT+ productions: ----- ::= ( {, } ) ----- ::= | | ----- VAR | ----- ::= {, } : | ----- {, } : ----- ::= ARRAY [ {; } ] OF ----- ----- ::= | ----- ::= .. : ----- ::= | ----- *) -{#############################################################################} -PROCEDURE rt1handle_formal_parm_list - ( rtinsert_flag: boolean; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec; - VAR routine_table: ARRAY [rtlobound..rthibound: natural] OF t_rout_tab_rec); - - VAR n_of_stacked_parms: integer; - param_class: t_parm_class; - was_a_procfunc_parm: boolean; - BEGIN - REPEAT - param_class := value_parm; - n_of_stacked_parms := 0; - was_a_procfunc_parm := false; - REPEAT - get_next_token; { should be VAR, parm_id, FUNCTION or PROCEDURE tokens } - IF (token = tokfunc) OR (token = tokproc) - THEN BEGIN - was_a_procfunc_parm := true; - param_class := proc_func; - rthandle_routine_heading_guts (false, type_table, routine_table); - tokenbuf := '0undefin' - END - ELSE BEGIN - IF token = tokvar - THEN BEGIN param_class := var_parm; get_next_token END; - get_next_token { should be comma or colon tokens } - END; - n_of_stacked_parms := n_of_stacked_parms + 1; - UNTIL (token = tokcolon) OR was_a_procfunc_parm; - IF NOT was_a_procfunc_parm - THEN BEGIN - get_next_token; { should be type_id token, or ARRAY } - IF token = tokarray - THEN BEGIN - param_class := conform_array; - rm2handle_conformant_array (type_table, routine_table) - END - END; - IF rtinsert_flag - THEN rtupdate_parmlist (tokenbuf, n_of_stacked_parms, - param_class, type_table, routine_table); - IF NOT was_a_procfunc_parm - THEN get_next_token { should be scolon or rparen tokens } - UNTIL token = tokrparen; - END; - - - - - - -{#############################################################################} -{---- For now, skip by the conformant array syntax. } -{#############################################################################} -PROCEDURE rm2handle_conformant_array - (VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec; - VAR routine_table: ARRAY [rtlobound..rthibound: natural] OF t_rout_tab_rec); - - BEGIN - REPEAT - REPEAT - get_next_token; get_next_token; { should be lbracket, then identifier } - get_next_token; get_next_token; { should be dotdot, then identifier } - get_next_token; get_next_token; { should be colon, then ordtypeid } - get_next_token; get_next_token { should be rbracket, then scolon or OF} - UNTIL token = tokof; - get_next_token { should be ARRAY or base_type_id } - UNTIL token <> tokarray - END; - - - - -{#############################################################################} -{--- Insert a routine identifier into the routine tablem, after first ----- bumping up the routine table index and checking for its overflow. } -{#############################################################################} -PROCEDURE rtplace_id_into_routine_table - (VAR proc_id: alfa; - VAR routine_table: ARRAY [rtlobound..rthibound: natural] OF t_rout_tab_rec); - - VAR i: integer; - BEGIN - IF (last_rt_entry >= max_routines) - THEN BEGIN - writeln; - writeln ('Routine Table overflow, Last id: ',last_entry_point_name); - close (outfile, i); - @hlt - END; - last_rt_entry := last_rt_entry + 1; - WITH routine_table [last_rt_entry] - DO BEGIN parm_list := nil; routine_name := proc_id END - END; - -{#############################################################################} -{--- Find a preexisting occurance of the last routine in the routine table ----- and compare the pair, before deleting the latter one. } -{#############################################################################} -PROCEDURE rtremove_duplicate_routine_entry - (VAR routine_table: ARRAY [rtlobound..rthibound: natural] OF t_rout_tab_rec); - - VAR i: integer; - ptr, temp_ptr: t_ptr_to_next_parm; - BEGIN - FOR i := 1 TO (last_rt_entry - 1) - DO IF routine_table [i]. routine_name = - routine_table [last_rt_entry]. routine_name - THEN BEGIN - temp_ptr := routine_table [last_rt_entry]. parm_list; - ptr := routine_table [i]. parm_list; - WHILE (ptr <> nil) AND (temp_ptr <> nil) - DO BEGIN - IF (temp_ptr^. parm_indx_to_type_table <> - ptr^. parm_indx_to_type_table) - OR (temp_ptr^.parm_class <> ptr^.parm_class) - THEN error (127); { illegal parameter substitution } - temp_ptr := temp_ptr^. rest_of_parm_list; - ptr := ptr^.rest_of_parm_list - END; - IF temp_ptr <> ptr - THEN error (126); { # of parms do not agree with prev declaration } - mark (addr (routine_table [last_rt_entry]. parm_list)); - release (routine_table [last_rt_entry]. parm_list); - last_rt_entry := last_rt_entry - 1; - exit { stop comparing } - END - END; - - - - - - - - - - - -{#############################################################################} -{--- Display the current contents of the routine table. } -{#############################################################################} -PROCEDURE rmdump_routine_table - (VAR outfile: text; - VAR routine_table: ARRAY [rtlobound..rthibound: natural] OF t_rout_tab_rec); - - VAR i: integer; - ptr: t_ptr_to_next_parm; - BEGIN - writeln (outfile); writeln (outfile, '--- Routine Table Dump --- '); - writeln (outfile, 'name':20, 'parms':10); - FOR i := 1 TO last_rt_entry - DO BEGIN - write (outfile, i:10, routine_table[i]. routine_name:10); - ptr := routine_table [i]. parm_list; - WHILE ptr <> nil - DO BEGIN - CASE ptr^.parm_class OF - var_parm : write (outfile, ' ( var_parm '); - value_parm: write (outfile, ' ( val_parm '); - func_value: write (outfile, ' ( func_val '); - conform_array: write (outfile, ' ( conf_arr '); - proc_func: write (outfile, ' ( procfunc ') - END; - write (outfile, ptr^. parm_indx_to_type_table:5, ' ) '); - ptr := ptr^. rest_of_parm_list - END; - writeln (outfile) - END; - writeln (outfile) - END; - - - - -MODEND. - - - - - - - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/SCANNER.PAS b/software/CPM/CPM21_MTPUG_09/SCANNER.PAS deleted file mode 100644 index 42e845b..0000000 --- a/software/CPM/CPM21_MTPUG_09/SCANNER.PAS +++ /dev/null @@ -1,572 +0,0 @@ -{########################################################################## -#### #### -#### Full module name: SCANNER. File name: SCANNER.PAS. #### -#### Support modules reqd: PASLIB.ERL. #### -#### Run time environment: . #### -#### Compile time environment: MT MicroSYSTEMS Pascal/MT+v5.25. #### -#### Link time environment: MT MicroSYSTEMS Linkmt v5.1. #### -#### Copyright (C) 1982 by Haldo Products Inc. All rights reserved. #### -#### 56 Camille Ln, E. Patchogue, NY 11772 #### -#### Programmer: Lawrence Adkins. #### -#### Module Development/Maintenance History: #### - 6-NOV-81 vers 1.0. File just created. - 12-NOV-81 development of this version complete. - 9-JAN-82 vers 2.0. Minor mods for use with other updated modules. - 1-MAR-82 deveopment of this version complete. - 19-APR-82 Vers 2.2. Add blockread compatibility stuff. -#### #### -##########################################################################} - - - - -{############################################################################ -#### #### -#### S C A N N E R M O D U L E #### -#### #### -#### This is a collection of procedures of the cross-module type checking### -#### program which are involved with the sending back to the parser the #### -#### next token in the source text. There are two entry points: #### -#### GET_NEXT_TOKEN which drives almost everything else within this #### -#### module, and SCAN_INIT which initializes this module's variables. #### -#### NOTE: We do not tokenize every single symbol in the Pascal #### -#### language, but rather only those symbols that make up all constant, #### -#### type, and var declarations, as well as procedure and function #### -#### headings. #### -#### Vers 2 changes: add ',','^','@' to the alphabet, permit '@' to be #### -#### used as either a pointer or an identifier character. Move uppercase#### -#### function to another module. Improved SKIP_COMMENT logic. #### -############################################################################} - -MODULE pascal_type_var_and_routine_header_scanner; - -{$I B:TYPECHK.DEC} - -VAR - infile: EXTERNAL text; - infile1: text; - outfile: EXTERNAL text; - input_line: EXTERNAL string132; - curr_input_line: EXTERNAL string132; - prev_input_line: EXTERNAL string132; - prev1_input_line: EXTERNAL string132; - token: EXTERNAL tokentype; - tokenbuf, ident_buf: EXTERNAL string132; - charbuf: EXTERNAL char; - at_is_alternative_pointer_symbol: EXTERNAL boolean; - symbols_avail_for_external_reference: EXTERNAL boolean; - include_file_level: EXTERNAL byte; - includ_file_name: EXTERNAL string15; - token_table: ARRAY [token_type] OF alfa; - debug: EXTERNAL boolean; - endfile: EXTERNAL boolean; - - - - -EXTERNAL PROCEDURE @hlt; -EXTERNAL FUNCTION uppercase (ch: char): char; -EXTERNAL PROCEDURE init_include_file_buffer; -EXTERNAL FUNCTION maineof: boolean; -EXTERNAL PROCEDURE readln_main_program_text (VAR input_line: string132); -EXTERNAL PROCEDURE readln_include_file_text (VAR input_line: string132); - - - - - - - - - - - - - - - - -{############################################################################ -#### Initialize charbuf and the token table. -############################################################################} -PROCEDURE init_scanner; - BEGIN - charbuf := ' '; - token_table [notoken] := 'NOTOKEN'; - token_table [tokliteral] := 'LITERAL'; - token_table [toklparen] := 'LPAREN'; - token_table [tokrparen] := 'RPAREN'; - token_table [tokcomma] := 'COMMA'; - token_table [tokperiod] := 'PERIOD'; - token_table [tokcolon] := 'COLON'; - token_table [toksemicolon] := 'SCOLON'; - token_table [tokequal] := 'EQUAL'; - token_table [toklbracket] := 'LBRACKET'; - token_table [tokrbracket] := 'RBRACKET'; - token_table [tokdotdot] := 'DOTDOT'; - token_table [tokpointer] := 'UPARROW'; - token_table [tokplus] := 'PLUS'; - token_table [tokminus] := 'MINUS'; - token_table [tokintnum] := 'INTNUM'; - token_table [tokbytenum] := 'BYTENUM'; - token_table [tokrealnum] := 'REALNUM'; - token_table [toklitstring] := 'LITVALUE'; - token_table [tokidentifier]:= 'IDENT'; - token_table [tokbegin] := 'BEGIN'; - token_table [tokend] := 'END'; - token_table [tokconst] := 'CONST'; - token_table [toktype] := 'TYPE'; - token_table [tokvar] := 'VAR'; - token_table [tokproc] := 'PROCEDUR'; - token_table [tokfunc] := 'FUNCTION'; - token_table [tokpacked] := 'PACKED'; - token_table [tokstring] := 'STRING'; - token_table [tokarray] := 'ARRAY'; - token_table [tokof] := 'OF'; - token_table [tokfile] := 'FILE'; - token_table [tokset] := 'SET'; - token_table [tokrecord] := 'RECORD'; - token_table [tokcase] := 'CASE'; - token_table [tokexternal] := 'EXTERNAL'; - token_table [toklabel] := 'LABEL'; - END; - - - - -{$E- ####################################################################### -#### Return the character that would have appeared in charbuf had we called -#### get-next-char instead. Dont disturb contents of charbuf or input-line. -###########################################################################} -FUNCTION lookahead_char: char; - BEGIN - IF length (input_line) = 0 - THEN lookahead_char := ' ' - ELSE lookahead_char := input_line[1] - END; - - - - - - - - -{########################################################################## -#### If input-line string is empty then fill it up by reading the next -#### source line and insert a blank into charbuf. Otherwise, remove the -#### next character from input-line and deposit it into charbuf. -#### If we were already at eof of an include file then start reading from -#### the main text and subtract one from include-file-level to let every- -#### one else know about this change in input files. -##########################################################################} -PROCEDURE get_next_char; - CONST - eoifmsg = 'EOF reached on Include file. '; - BEGIN - IF (length (input_line) = 0) AND NOT endfile - THEN BEGIN - IF include_file_level = 0 - THEN readln_main_program_text (input_line) - ELSE readln_include_file_text (input_line); - IF debug - THEN BEGIN writeln (input_line); writeln (outfile, input_line) END - ELSE BEGIN write ('+'); write (outfile, '+') END; - { update the three line buffer used when printing out errors } - prev1_input_line := prev_input_line; - prev_input_line := curr_input_line; - curr_input_line := input_line - END; - IF length (input_line) = 0 - THEN charbuf := ' ' { return blank as a separator } - ELSE BEGIN - charbuf := input_line[1]; { return character } - delete (input_line,1,1) { easier then maintaining column index } - END; - IF endfile AND (include_file_level > 0) - THEN BEGIN { jump out of include file } - endfile := false; - include_file_level := include_file_level - 1; - writeln; writeln (outfile); - writeln (eoifmsg); writeln (outfile, eoifmsg) - END - END; - - - - - -{########################################################################### -#### return true if char is permissable in type, var, routine declaration. -###########################################################################} -FUNCTION in_alphabet (character: char): boolean; - BEGIN in_alphabet := character IN - ['A'..'Z', 'a'..'z', '0'..'9', ':', ';', '*', '{', '}', '''', '+', - '-', '=', '(', ')', '.', ',', '$', '_', '[', ']', '^', '@', ' '] - END; - -FUNCTION in_alpha (character: char): boolean; - BEGIN in_alpha := character IN ['A'..'Z', 'a'..'z', '_'] END; - -FUNCTION in_numeric (character: char): boolean; - BEGIN in_numeric := character IN ['0'..'9'] END; - -FUNCTION in_hex_numeric (character: char): boolean; - BEGIN in_hex_numeric := character IN ['0'..'9', 'A'..'F', 'a'..'f'] END; - - - - - -{################################################################# -#### Procedures that call this will do so if after they call -#### get-next-char all they find in charbuf is either a blank or -#### is not in the alphabet as we define it for type, var, and -#### routine heading declarations. We correct the state of charbuf by -#### repeatedly calling get-next-char until either a legal nonblank -#### character is found or eof of the main text is found. -##################################################################} -PROCEDURE handle_blank_or_illegal_chars; - BEGIN - WHILE ((NOT in_alphabet(charbuf)) OR (charbuf = ' ')) AND - NOT maineof - DO get_next_char - END; - - - - - - - - -{####################################################################### -#### Check whether or not the sequence of characters is a reserved word. -#######################################################################} -PROCEDURE check_if_reserved_word; - VAR - temp_str: alfa; - i: token_type; - BEGIN - temp_str := tokenbuf; - FOR i := tokbegin TO toklabel - DO IF temp_str = token_table [i] - THEN BEGIN token:= i; exit END - END; - - - - - - - - - -{###################################################################### -#### Assuming that the character in charbuf was determined to be -#### an alpha, scan all following alphanumeric characters. After -#### then checking if the id is a reserved word, leave in charbuf -#### the last alphanumeric character scanned. -######################################################################} -PROCEDURE handle_identifier; - BEGIN - token := tokidentifier; - tokenbuf := ''; - charbuf := uppercase (charbuf); - tokenbuf := concat (tokenbuf, charbuf); - WHILE in_alpha (lookahead_char) OR in_numeric (lookahead_char) - DO BEGIN - REPEAT get_next_char UNTIL (charbuf <> '_'); - charbuf := uppercase (charbuf); - tokenbuf := concat (tokenbuf, charbuf); - END; - check_if_reserved_word - END; - - -{######################################################################## -#### If two periods found in a row (one in charbuf, the other still in -#### input-line, then transfer the second one from input-line to charbuf. -########################################################################} -PROCEDURE handle_dot_dot; - BEGIN - token := tokperiod; - IF lookahead_char = '.' - THEN BEGIN get_next_char; token := tokdotdot END - END; - - - - - - - - - - - - -{######################################################################## -#### Assuming the character in charbuf is a '$', scan the following chars -#### in input-line as hex digits. Stop before reading in a non-hex digit. -#########################################################################} -PROCEDURE handle_hex_num; - BEGIN - token := tokintnum; tokenbuf := charbuf; - WHILE in_hex_numeric (lookahead_char) - DO BEGIN get_next_char; tokenbuf := concat (tokenbuf, charbuf) END; - END; - - - - - - - - - - - - -{######################################################################## -#### Assuming that the character in charbuf is a literal mark, get -#### any other characters on that line into tokenbuf until either a second -#### literal mark or eoln occurs. Stop before loading into charbuf any -#### character that is not a part of the literal string. -########################################################################} -PROCEDURE handle_literal_constant; - CONST lit_mark = ''''; - BEGIN - token := toklitstring; tokenbuf := ''; - WHILE (length (input_line) > 0) AND (lookahead_char <> lit_mark) - DO BEGIN - get_next_char; - tokenbuf := concat (tokenbuf, charbuf) - END; - get_next_char; { put second literal mark into charbuf } - IF (lookahead_char = lit_mark) - THEN BEGIN get_next_char; get_next_char; tokenbuf := charbuf END - END; - - - -{######################################################################### -#### Process a single digit for handle_integer_or_real_number -#########################################################################} - PROCEDURE handle_a_digit (VAR bytenum: integer); - BEGIN - IF bytenum < 256 THEN bytenum := (bytenum * 10) + (ord(charbuf) - 48); - tokenbuf := concat (tokenbuf, charbuf); { next digit } - IF lookahead_char IN ['E','e','.'] - THEN BEGIN { treat number as a real number instead } - IF (lookahead_char = '.') AND (input_line[1] = '.') - THEN exit; { a dotdot is the next token } - byte_num := 256; - token := tokrealnum; - get_next_char; { to get the 'E' or '.' } - tokenbuf := concat (tokenbuf, charbuf); - IF lookahead_char IN ['+','-'] - THEN BEGIN get_next_char; tokenbuf := concat (tokenbuf, charbuf) END - END; - END; - - - -{######################################################################## -#### Assuming that the digit in charbuf is a digit or sign, bring in the -#### following digits into tokenbuf. The encountering of a period or 'e' -#### character will make the number a real one. The encountering of -#### other alpha chars (as might follow a sign) will force the interpreting -#### of an identifier instead. As with the other routines in this module, -#### one must do a get_next_char to get the char following the last digit. -########################################################################} -PROCEDURE handle_integer_or_real_num; - VAR - bytenum: integer; {used to find out if integer can be squeezed into byte} - BEGIN - bytenum := 0; - token := tokintnum; tokenbuf := ''; - handle_a_digit (bytenum); { charbuf should now contain the first digit } - WHILE in_numeric (lookahead_char) - DO BEGIN get_next_char; handle_a_digit (bytenum) END; - IF (bytenum <= 255) AND (bytenum >= 0) - THEN token := tokbytenum; { integer can be crammed into a byte } - END; - - -{########################################################################## -#### Go open the include file specified following the the $I option -#### within the comment last scanned. Bump up include_file_level by one -#### to notify the rest of the program that we are now in an include file. -##########################################################################} -PROCEDURE open_include_file; - CONST - eifmsg = 'Including Text from file: '; - comsg = 'Cannot open Include file: '; - VAR - i: integer; - BEGIN - open (infile1, includ_file_name, i); - writeln; writeln (outfile); - IF i = 255 - THEN BEGIN - writeln (comsg, includ_file_name); - writeln (outfile, comsg, includ_file_name); - close (outfile,i); - @hlt - END - ELSE BEGIN - init_include_file_buffer; - include_file_level := include_file_level + 1; - writeln (eifmsg, includ_file_name); - writeln (outfile, eifmsg, includ_file_name) - END; - includ_file_name := '' - END; - - - - - - - - - - - - - - - -{######################################################################### -#### Pull off characters of the specified include file name and insert -#### into the variable includ_file_name. Leave in charbuf the last letter -#### of the file name obtained. -#########################################################################} -PROCEDURE get_include_file_name; - BEGIN - get_next_char; {get first char following the I letter } - handle_blank_or_illegal_chars; {charbuf now has 1st letter of fname } - includ_file_name := concat (includ_file_name, uppercase (charbuf)); - WHILE NOT (lookahead_char IN [' ','*','}']) - DO BEGIN - get_next_char; - includ_file_name := concat (includ_file_name, uppercase (charbuf)) - END - END; - - - - - - -{############################################################################# -#### Assuming that either a left brace or left paren is in charbuf, keep on -#### scanning until the matching right brace or right paren is in charbuf, -#### then return. If a dollar sign follows the chars that signal the -#### beginning of a comment, then parse the relevant compiler toggles. -#### Permissable ones are Entry-point symbol ($E+/-) and Include-file -#### ($I fname.ext) as documented in the MT MicroSYSTEMS Pascal manual. -#############################################################################} -PROCEDURE handle_comment; - VAR - brace_comment: boolean; - prev_char: char; - BEGIN - brace_comment := charbuf = '{'; - IF (charbuf = '(') - THEN IF (lookahead_char = '*') - THEN get_next_char - ELSE BEGIN token := toklparen; exit END; - token := notoken; - IF lookahead_char = '$' - THEN BEGIN - get_next_char; - CASE uppercase (lookahead_char) OF - 'E': BEGIN get_next_char; - symbols_avail_for_external_reference := lookahead_char <> '-' - END; - 'I': BEGIN get_next_char; get_include_file_name END - END - END; - - { Continue to read characters until the end of the comment is found. } - charbuf := ' '; - REPEAT prev_char := charbuf; get_next_char - UNTIL ((prevchar = '*') AND (charbuf = ')') AND (NOT brace_comment)) - OR ((charbuf = '}') AND brace_comment) - OR maineof - END; - - - - - - - -{$E+ ################################################################## -#### This entry procedure is the driver of all of the other routines in -#### this module. Its function, when called by the parser in the main -#### program are to get the next character in the linebuffer into -#### charbuf, determine the token value, and then perhaps to call another -#### routine to determine if the consecutively following characters in -#### the linebuffer might cause a change in the token value. The repeat -#### loop is intended to handle the occurence of a comment. -######################################################################} -PROCEDURE get_next_token; - BEGIN - IF tokenbuf <>'' THEN ident_buf := tokenbuf; { store id for use in error } - tokenbuf := ''; - REPEAT - IF includ_file_name <> '' THEN open_include_file; - get_next_char; { advance past character from last token } - handle_blank_or_illegal_chars; { skip any separators } - IF in_alpha (charbuf) THEN handle_identifier ELSE - IF in_numeric (charbuf) THEN handle_integer_or_real_num ELSE - CASE charbuf OF - '$': handle_hex_num; - '''': handle_literal_constant; - '(','{': handle_comment; - ')': token := tokrparen; - ',': token := tokcomma; - '.': handle_dot_dot; - ':': token := tokcolon; - ';': token := toksemicolon; - '=': token := tokequal; - '[': token := toklbracket; - ']': token := tokrbracket; - '^': token := tokpointer; - '@': IF at_is_alternative_pointer_symbol - THEN token := tokpointer - ELSE handle_identifier; - '-': token := tokminus; - '+': token := tokplus; - ELSE token := notoken - END - UNTIL (token <> notoken) OR maineof; - IF debug - THEN BEGIN - write (' ':20, ' '); - writeln (token_table [token]:10, ' ':5, tokenbuf:10) - END - END; - - -MODEND. - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/SWEEP.COM b/software/CPM/CPM21_MTPUG_09/SWEEP.COM deleted file mode 100644 index 2b2f80a..0000000 Binary files a/software/CPM/CPM21_MTPUG_09/SWEEP.COM and /dev/null differ diff --git a/software/CPM/CPM21_MTPUG_09/SYNONYM.COM b/software/CPM/CPM21_MTPUG_09/SYNONYM.COM deleted file mode 100644 index 3f48fbb..0000000 Binary files a/software/CPM/CPM21_MTPUG_09/SYNONYM.COM and /dev/null differ diff --git a/software/CPM/CPM21_MTPUG_09/TYPE1TAB.PAS b/software/CPM/CPM21_MTPUG_09/TYPE1TAB.PAS deleted file mode 100644 index 8ae9faa..0000000 --- a/software/CPM/CPM21_MTPUG_09/TYPE1TAB.PAS +++ /dev/null @@ -1,308 +0,0 @@ -{########################################################################## -#### #### -#### Full module name: TYPE_TABLE MODULE OF THE TYPE_CHECKER PROGRAM. #### -#### File name: TYPE1TAB.PAS.(First of 3 files reqd for this module.)#### -#### Support modules reqd: PASLIB.ERL, SCANNER. #### -#### Run time environment: . #### -#### Compile time environment: MT MicroSYSTEMS Pascal/MT+v5.25. #### -#### Link time environment: MT MicroSYSTEMS Linkmt v5.1. #### -#### Copyright (C) 1982 by Haldo Products, Inc. All rights reserved. #### -#### 56 Camille Ln, E. Patchogue, NY 11772 #### -#### Programmer: Lawrence Adkins. #### -#### Module Development/Maintenance History: #### - 6-NOV-81 Vers 1.0. File just created. - 12-NOV-81 Development of this version completed. - 9-JAN-82 Vers 2.0. development begins. - 1-MAR-82 Development of this version complete. - 6-MAR-82 Vers 2.1. Add conformant array stuff. - 19-APR-82 Vers 2.2. No changes made. -#### #### -##########################################################################} - - -MODULE TYPE_TABLE_HANDLER; - -{$I B:TYPECHK.DEC } - -VAR - last_tt_entry: integer; { index to last filled entry of type table } - token: EXTERNAL tokentype; - tokenbuf: EXTERNAL string132; - exit_keywords: SET OF token_type; - outfile: EXTERNAL text; - record_parsing_status : t_record_parsing_status; - last_entry_point_name: EXTERNAL string132; - ttentry_types_where_base_types_wont_compare, - rectype_expansion: SET OF tt_types; - debug: EXTERNAL boolean; - -EXTERNAL PROCEDURE get_next_token; -EXTERNAL PROCEDURE error (pascal_error_no: integer); -EXTERNAL PROCEDURE @hlt; -EXTERNAL PROCEDURE cmstore_scalar_type_values (VAR n_of_values: integer; - VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec); -EXTERNAL PROCEDURE cmfinish_parsing_constant_value (VAR actual_value: integer; - VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec); - - - - - - - - - - - - - - - - - - - - - -{#############################################################################} -{--- Initialize all of the variables private to this module } -{#############################################################################} -PROCEDURE tminit_type_table_module - (VAR type_table: ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - VAR i: integer; - BEGIN - FOR i:= 1 TO 9 - DO WITH type_table[i] - DO BEGIN - entry_purpose:= predef_type; - base_type_index := 0; - lower_bound := 0; upper_bound := 0 - END; - WITH type_table[0] DO type_id := '0UNDEFIN'; - WITH type_table[1] - DO BEGIN type_id := 'CHAR'; upper_bound := 255 END; - WITH type_table[2] - DO BEGIN type_id := 'BYTE'; upper_bound := 255 END; - WITH type_table[3] - DO BEGIN type_id := 'INTEGER'; lower_bound := -32768; upper_bound := 32767 - END; - WITH type_table[4] - DO BEGIN type_id := 'BOOLEAN'; upper_bound := 1 END; - WITH type_table[5] - DO BEGIN type_id := 'WORD'; lower_bound := -32768; upper_bound := 32767 - END; - WITH type_table[6] DO type_id := 'REAL'; - WITH type_table[7] - DO BEGIN type_id := 'STRING'; upper_bound := 255 END; - WITH type_table[8] DO type_id := 'TEXT'; - WITH type_table[9] DO type_id := 'FILE'; - - last_tt_entry := 9; - rectype_expansion := - [recfields, recfldnestedrecord, recvariant, recvarvalues]; - ttentry_types_where_base_types_wont_compare := - [array_type, file_type, record_type] - END; - - - - -{#############################################################################} -(*-- Assuming that a Pascal keyword has been read in, we will parse the ----- folllowing Pascal/MT+ BNF productions: ----- ::= | ----- TYPE {; } ; ----- ----- ::= = ----- ::= ----- ::= ----- *) -{#############################################################################} -PROCEDURE tmadd_new_types_to_type_table - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - CONST action = 'Handling Types...'; - BEGIN - writeln; writeln (action); writeln (outfile); writeln (outfile, action); - exit_keywords := [toktype, tokvar, tokproc, tokfunc, tokbegin, tokexternal]; - record_parsing_status.got_rec_type := 0; - WHILE token = toktype - DO BEGIN - get_next_token; { should be type identifier being defined } - REPEAT - last_entry_point_name := tokenbuf; - tm1add_type_identifier_to_type_table (tokenbuf, type_table); - get_next_token; { should be equal_sign } - REPEAT tm0parse_rest_of_type_definition (const_table, type_table) - UNTIL (record_parsing_status.got_rec_type= 0) AND (token= toksemicolon); - get_next_token; { should be type_id or keyword } - UNTIL (token IN exit_keywords) - END - END; - - - - - - - - - - - -{#############################################################################} -{--- Place a type_id into a new slot of the type table. } -{#############################################################################} -PROCEDURE tm1add_type_identifier_to_type_table - (new_id: alfa; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - BEGIN - tminc_last_tt_entry_index (tthibound); - WITH type_table [last_tt_entry] - DO BEGIN - entry_purpose := undef_type; - IF record_parsing_status. got_rec_type = 0 THEN type_id := new_id; - lower_bound := 0; upper_bound := 0; base_type_index := 0 - END; - tmchange_any_refs_to_identical_type_id_with_undef_type (type_table) - END; - - - - - -{#############################################################################} -{--- Bump the index into the type table by 1, and error if overflow } -{#############################################################################} -PROCEDURE tminc_last_tt_entry_index (max_type_elements: natural); - - VAR i: integer; - BEGIN - IF last_tt_entry >= max_type_elements - THEN BEGIN - writeln; - writeln ('Type Table overflow, last id: ', last_entry_point_name); - close (outfile, i); - @hlt - END; - last_tt_entry := last_tt_entry + 1 - END; - - - - - - -{#############################################################################} -(*-- Parse the following Pascal/MT+ BNF productions: ----- ::= | | ----- ::= | ----- PACKED ----- ::= | | ----- | ----- ::= | ----- ::= ----- ::= ----- ::= ----- ::= ----- ::= ----- ::= ----- ::= FILE ----- ::= ----- *) -{#############################################################################} -PROCEDURE tm0parse_rest_of_type_definition - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - BEGIN - get_next_token; { should be some type definition stuff } - IF (token = tokidentifier) AND (tokenbuf = 'ABSOLUTE') - THEN BEGIN { ignore [ ] syntax representing the address } - get_next_token; get_next_token; get_next_token; get_next_token END - ELSE IF token = tokexternal THEN get_next_token; - IF token = tokpacked THEN get_next_token; - { for sure now, we are at the type_id being defined } - tm1init_new_type_table_entry (token, type_table); - CASE token OF - tokset : tm1parse_set (const_table, type_table); - tokfile : tm2parse_tokof_and_beyond (const_table, type_table); - tokstring : tm3parse_string (const_table, type_table); - tokpointer: tm4parse_pointer (type_table); - tokarray : tm5parse_array (const_table, type_table); - tokrecord : tm6parse_record (const_table, type_table); - ELSE tm9finish_parsing_simple_type (const_table, type_table) - END; - IF debug THEN error (0); - tmremove_duplicate_type_declaration (type_table) - END; - -{#############################################################################} -{--- Assuming index has already been bumped and type_identifier entered, ----- initialize some of the other fields for that entry } -{#############################################################################} -PROCEDURE tm1init_new_type_table_entry - (token: tokentype; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - BEGIN - WITH type_table [last_tt_entry] - DO IF record_parsing_status.got_rec_type = 0 - THEN entry_purpose := tok_class (token) - ELSE BEGIN - entry_purpose := tokrec_class (token); - n_of_stacked_fields:= record_parsing_status.last_n_of_stacked_fields; - record_nesting := record_parsing_status.got_rec_type; - local_fieldlist_continues := true; - field_entry_purpose := tok_class (token) - END - END; - - -FUNCTION tokrec_class (token: tokentype): tt_types; - - BEGIN - IF token = tokrecord - THEN tokrec_class := recfldnestedrecord - ELSE tokrec_class := recfields - END; - -FUNCTION tok_class (token: tokentype): tt_types; - - BEGIN - CASE token OF - tokset : tok_class := set_type; - tokfile : tok_class := file_type; - tokstring : tok_class := string_type; - tokpointer : tok_class := ptr_type; - tokarray : tok_class := array_type; - tokrecord : tok_class := record_type; - notoken : tok_class := undef_type; - ELSE tok_class := simple_type - END - END; - -{$I B:TYPE2TAB.PAS } -{$I B:TYPE3TAB.PAS } - -MODEND. - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/TYPE2TAB.PAS b/software/CPM/CPM21_MTPUG_09/TYPE2TAB.PAS deleted file mode 100644 index 1cde815..0000000 --- a/software/CPM/CPM21_MTPUG_09/TYPE2TAB.PAS +++ /dev/null @@ -1,418 +0,0 @@ -{########################################################################## -#### #### -#### Full module name: TYPE_TABLE MODULE OF THE TYPE_CHECKER PROGRAM. #### -#### File name: TYPE2TAB.PAS.(2'nd of 3 files reqd for this module.) #### -#### Support modules reqd: PASLIB.ERL, SCANNER. #### -#### Run time environment: . #### -#### Compile time environment: MT MicroSYSTEMS Pascal/MT+v5.25. #### -#### Link time environment: MT MicroSYSTEMS Linkmt v5.1. #### -#### Copyright (C) 1982 by Haldo Products, Inc. All rights reserved. #### -#### 56 Camille Ln, E. Patchogue, NY 11772 #### -#### Programmer: Lawrence Adkins. #### -#### Module Development/Maintenance History: #### - 6-NOV-81 Vers 1.0. File just created. - 12-NOV-81 Development of this version completed. - 9-JAN-82 Vers 2.0. development begins. - 1-MAR-82 Development of this version complete. - 6-MAR-82 Vers 2.1. Conformant array stuff added. - 19-APR-82 Vers 2.2. No changes made. -#### #### -##########################################################################} - - -{#############################################################################} -{ Call to this could have been a call to tm2parse_tokof_and_beyond, - except that here we avoid filling another type_table entry } -(*-- Assuming that the first symbol has already been scanned, ----- parse the following Pascal/MT+ BNF productions: ----- ::= SET OF ----- ::= ----- ::= ----- *) -{#############################################################################} -PROCEDURE tm1parse_set - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - BEGIN - get_next_token; { should be OF token } - get_next_token; { should be lparen, constant, or type_id } - tm9finish_parsing_simple_type (const_table, type_table); - END; - - - -{#############################################################################} -(*-- parse the following Pascal/MT+ BNF production: ----- ::= {OF } ----- ::= ----- *) -{#############################################################################} -PROCEDURE tm2parse_tokof_and_beyond - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - VAR orig_token: token_type; - BEGIN - orig_token:= token; - get_next_token; { should be OF, scolon, END, or rparen tokens } - IF token = tokof - THEN BEGIN - tm1add_type_identifier_to_type_table ('0BASETYP', type_table); - type_table [last_tt_entry - 1]. base_type_index := last_tt_entry; - tm0parse_rest_of_type_definition (const_table, type_table) - END - ELSE IF orig_token = tokfile - THEN tmmake_it_reference_a_simple_type (token, type_table) - END; - - - - - - - - - - - - - - - - - - - - - -{#############################################################################} -(*-- Assuming that the first symbol has already been scanned, ----- parse the following Pascal/MT+ BNF productions: ----- ::= STRING ----- ::= [ ] | ----- ::= | ----- ::= ----- *) -{#############################################################################} -PROCEDURE tm3parse_string - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - BEGIN - get_next_token; { should be lbracket, scolon, END, or rparen tokens } - IF token = toklbracket - THEN BEGIN - get_next_token; { should be constant_id or constant_value } - cmfinish_parsing_constant_value (type_table[last_tt_entry].upper_bound, - const_table); - get_next_token; { should be rbracket } - get_next_token { should be scolon, END, or rparen tokens } - END - ELSE tmmake_it_reference_a_simple_type (tokstring, type_table) - END; - - - - - - - - - - - - - - - - - - - -{#############################################################################} -{---- Make a type entry have as it's base type a simple type, not the following ------ type table entry, so that we may save some type table space.} -{#############################################################################} -PROCEDURE tmmake_it_reference_a_simple_type - ( token: token_type; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - BEGIN - WITH type_table [last_tt_entry] - DO BEGIN - IF (entry_purpose IN rectype_expansion) - THEN field_entry_purpose := simple_type - ELSE entry_purpose := simple_type; - CASE token OF - tokfile: base_type_index := 9; - tokstring: base_type_index := 7 - END - END - END; - - -{#############################################################################} -(*-- Assuming that the first symbol has already been scanned, ----- parse the following Pascal/MT+ BNF production: ----- ::= ^ | ----- @ ----- *) -{#############################################################################} -PROCEDURE tm4parse_pointer - (VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - VAR base, len: integer; - BEGIN - get_next_token; { should be (possibly undefined) type_id } - IF tm1find_prev_occurance_of_type_id - (tokenbuf, last_tt_entry, base, type_table) - THEN type_table [last_tt_entry]. base_type_index := base - ELSE BEGIN - tm1add_type_identifier_to_type_table (tokenbuf, type_table); - tm1init_new_type_table_entry (notoken, type_table); - type_table [last_tt_entry - 1]. base_type_index := last_tt_entry - END; - get_next_token { should be scolon, END, or rparen tokens } - END; - - - - - - - - - - - - - - - - - - - - - -{#############################################################################} -(*-- Assuming that the first symbol has already been scanned, ----- parse the following Pascal/MT+ BNF productions: ----- ::= ARRAY [ {, } ] ----- ----- ::= ----- ::= ----- ::= ----- *) -{#############################################################################} -PROCEDURE tm5parse_array - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - BEGIN - get_next_token; { should be lbracket } - REPEAT - get_next_token; { should be lparen, constant, or type_id } - tm9finish_parsing_simple_type (const_table, type_table); - { present token should be a comma or rbracket } - IF token = tokcomma - THEN BEGIN - tm1add_type_identifier_to_type_table ('0ARRAY', type_table); - tm1init_new_type_table_entry (tokarray, type_table); - type_table [last_tt_entry - 1]. base_type_index := last_tt_entry - END - UNTIL token = tokrbracket; - tm2parse_tokof_and_beyond (const_table, type_table) - END; - - - - - - - - - - - - - - - -{#############################################################################} -(*-- Assuming that the first symbol has already been scanned, ----- parse the following Pascal/MT+ BNF productions: ----- ::= RECORD END ----- ::= ----- *) -{#############################################################################} -PROCEDURE tm6parse_record - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - BEGIN - IF last_tt_entry < max_type_elements - THEN type_table [last_tt_entry]. base_type_index := last_tt_entry + 1; - WITH record_parsing_status DO got_rec_type := got_rec_type + 1; - tm7parse_fieldlist (const_table, type_table); - { should now be at the END token for this record } - WITH record_parsing_status DO got_rec_type := got_rec_type - 1; - type_table [last_tt_entry]. local_fieldlist_continues := false; - get_next_token { should be scolon, END, or rparen tokens } - END; - -{#############################################################################} -(*-- Assuming that the first symbol has already been scanned, ----- parse the following Pascal/MT+ BNF productions: ----- ::= | ; | ----- ----- ::= {; } ----- ::= {, } : ----- | ----- ::= ----- ::= CASE OF {; } ----- ::= ----- ::= : ( ) | ----- ::= ----- *) -{#############################################################################} -PROCEDURE tm7parse_fieldlist - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - BEGIN - REPEAT - record_parsing_status.last_n_of_stacked_fields := 0; - get_next_token; { should be identifier, CASE, END, or rparen tokens } - CASE token OF - tokidentifier: - BEGIN - REPEAT - IF token = tokidentifier { as opposed to being tokcomma } - THEN WITH record_parsing_status - DO last_n_of_stacked_fields := last_n_of_stacked_fields + 1; - get_next_token { should be comma or colon tokens } - UNTIL token = tokcolon; - tm1add_type_identifier_to_type_table ('0noname', type_table); - tm0parse_rest_of_type_definition (const_table, type_table) - END; - tokcase: - BEGIN - tm71parse_variant_declaration (type_table); - get_next_token; { should be OF token } - REPEAT - tm72parse_list_of_variant_values (type_table); - REPEAT - get_next_token;{ should be lparen } - tm7recurse_parse_fieldlist (const_table, type_table); - IF token = toksemicolon { instead of tokrparen } - THEN tm72parse_list_of_variant_values (type_table) - UNTIL token = tokrparen; - type_table [last_tt_entry]. local_fieldlist_continues := false; - get_next_token { should be scolon or END token } - UNTIL token = tokend - END; - tokrparen, tokend: - { do no action } - END { case } - UNTIL (token = tokend) OR (token = tokrparen) - END; - - -PROCEDURE tm7recurse_parse_fieldlist - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - BEGIN tm7parse_fieldlist (const_table, type_table) END; - - - -{#############################################################################} -(*-- parse the following Pascal/MT+ BNF productions: ----- ::= ----- ::= : | ----- *) -{#############################################################################} -PROCEDURE tm71parse_variant_declaration - (VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - VAR base: integer; - BEGIN - get_next_token; { should be identifier (variant_var_id or type_id) } - IF tm1find_prev_occurance_of_type_id - (tokenbuf, last_tt_entry, base, type_table) - THEN record_parsing_status.last_n_of_stacked_fields := 0 - ELSE BEGIN - record_parsing_status.last_n_of_stacked_fields := 1; - get_next_token; { should be colon token } - get_next_token { should be type_id } - END; - tminc_last_tt_entry_index (tthibound); - record_parsing_status.last_base_type_index := base; - WITH type_table [last_tt_entry] - DO BEGIN - entry_purpose := recvariant; - base_type_index := base; - upper_bound := type_table [base]. upper_bound; - lower_bound := type_table [base]. lower_bound; - n_of_stacked_fields := record_parsing_status.last_n_of_stacked_fields; - field_entry_purpose := simpletype; - local_fieldlist_continues := true; - record_nesting := record_parsing_status.got_rec_type - END - END; - - - - - - - - - - -{#############################################################################} -(*-- parse the following Pascal/MT+ BNF productions: ----- ::= {, } ----- ::= ----- *) -{#############################################################################} -PROCEDURE tm72parse_list_of_variant_values - (VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - VAR n_of_values: integer; - BEGIN - n_of_values := 0; - REPEAT - get_next_token; { should be constant_value } - n_of_values := n_of_values + 1; - get_next_token { should be comma or colon tokens } - UNTIL token = tokcolon; - tminc_last_tt_entry_index (tthibound); - WITH type_table [last_tt_entry] - DO BEGIN - entry_purpose := recvarvalues; - base_type_index := record_parsing_status. last_base_type_index; - upper_bound := n_of_values; - lower_bound := 0; - local_fieldlist_continues := true; - field_entry_purpose := simple_type; - record_nesting := record_parsing_status. got_rec_type; - n_of_stacked_fields := 1 - END - END; - - - - - - - - - - - - - - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/TYPE3TAB.PAS b/software/CPM/CPM21_MTPUG_09/TYPE3TAB.PAS deleted file mode 100644 index dd43ad1..0000000 --- a/software/CPM/CPM21_MTPUG_09/TYPE3TAB.PAS +++ /dev/null @@ -1,286 +0,0 @@ -{########################################################################## -#### #### -#### Full module name: TYPE_TABLE MODULE OF THE TYPE_CHECKER PROGRAM. #### -#### File name: TYPE3TAB.PAS.(3'rd of 3 files reqd for this module.) #### -#### Support modules reqd: PASLIB.ERL, SCANNER. #### -#### Run time environment: . #### -#### Compile time environment: MT MicroSYSTEMS Pascal/MT+v5.25. #### -#### Link time environment: MT MicroSYSTEMS Linkmt v5.1. #### -#### Copyright (C) 1982 by Haldo Products, Inc. All rights reserved. #### -#### 56 Camille Ln, E. Patchogue, NY 11772 #### -#### Programmer: Lawrence Adkins. #### -#### Module Development/Maintenance History: #### - 6-NOV-81 Vers 1.0. File just created. - 12-NOV-81 Development of this version completed. - 9-JAN-82 Vers 2.0. development begins. - 1-MAR-82 Development of this version completed. -#### #### -##########################################################################} - - - - -{#############################################################################} -(*-- Assuming that the first_symbol has already been scanned, ----- parse the following Pascal/MT+ productions: ----- ::= | | ----- ----- ::= ( {, } ) ----- ::= .. ----- ::= ----- ::= ----- *) -{#############################################################################} -PROCEDURE tm9finish_parsing_simple_type - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - VAR base, n_of_values, actual_value: integer; - BEGIN - IF token = toklparen - THEN BEGIN - cmstore_scalar_type_values (n_of_values, const_table); - WITH type_table [last_tt_entry] - DO BEGIN lower_bound := 0; upper_bound := n_of_values - 1 END - END - ELSE IF tm1find_prev_occurance_of_type_id - (tokenbuf, last_tt_entry, base, type_table) - THEN type_table [last_tt_entry]. base_type_index := base - ELSE BEGIN - cmfinish_parsing_constant_value (actual_value, const_table); - type_table [last_tt_entry]. lower_bound := actual_value; - get_next_token; { should be dot_dot token } - get_next_token; { should be constant_value or identifier } - cmfinish_parsing_constant_value (actual_value, const_table); - type_table [last_tt_entry]. upper_bound := actual_value - END; - get_next_token { should be scolon, END, or rparen tokens } - END; { or even rbracket or comma tokens (as with arrays) } - - - - - - - - -{#############################################################################} -{--- Find 2 occurances of the same type declaration, compare the two, and ----- remove the latter one. Error if two dont compare. } -{#############################################################################} -PROCEDURE tmremove_duplicate_type_declaration - (VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - VAR j, base, len, last_type_dec_index: integer; - rec: t_type_tab_rec; - BEGIN - IF (record_parsing_status. got_rec_type = 0) - AND tm2find_prev_occurance_of_last_type_entry (base, len, type_table) - THEN BEGIN - {compare all related pairs of records for identity } - last_type_dec_index := last_tt_entry - len; - FOR j := 0 TO len - DO BEGIN - rec := type_table [last_type_dec_index + j]; - WITH type_table [base + j] - DO IF (lower_bound <> rec.lower_bound) - OR (upper_bound <> rec.upper_bound) - OR (NOT exception (entry_purpose) AND - (base_type_index <> rec.base_type_index)) - OR (entry_purpose <> rec.entry_purpose) - OR ((entry_purpose IN rectype_expansion) - AND ((n_of_stacked_fields <> rec.n_of_stacked_fields) - OR (NOT exception (field_entry_purpose) AND - (field_entry_purpose <> rec.field_entry_purpose)) - OR(local_fieldlist_continues<>rec.local_fieldlist_continues) - OR (record_nesting <> rec.record_nesting) ) ) - THEN BEGIN - error (101); { type declared differently from first time } - last_tt_entry := last_type_dec_index - 1; - exit - END; - END; { for } - last_tt_entry := last_type_dec_index - 1 - END { if } - END; - - - - - -{#############################################################################} -{--- Resolve previously unresolved type declarations. } -{--- It is assumed that any references to undefined types occur only ----- in the form TYPE ptr_type_name = ^ defined_or_undefined_type } -{#############################################################################} -PROCEDURE tmchange_any_refs_to_identical_type_id_with_undef_type - (VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - VAR base, len: integer; - BEGIN - WHILE tm2find_prev_occurance_of_last_type_entry (base, len, type_table) - DO IF type_table [base]. entry_purpose = undef_type - THEN BEGIN - type_table [base-1]. base_type_index := last_tt_entry; - WITH type_table [base] DO type_id := concat ('0', type_id) - END - ELSE exit - END; - - - - -{#############################################################################} -{--- Determine the number of entries consumed by the last type declaration, ----- as well as the index to the last previous occurance of the same type ----- identifier. } -{#############################################################################} -FUNCTION tm2find_prev_occurance_of_last_type_entry - (VAR ret_index: integer; - VAR entries_consumed: integer; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec): - boolean; - - VAR last_type_dec_index: integer; - BEGIN - last_type_dec_index := last_tt_entry; - WHILE (type_table [last_type_dec_index]. entry_purpose IN rectype_expansion) - OR (type_table [last_type_dec_index]. type_id [1] = '0') - DO last_type_dec_index := last_type_dec_index - 1; - entries_consumed := last_tt_entry - last_type_dec_index; - tm2find_prev_occurance_of_last_type_entry := - tm1find_prev_occurance_of_type_id (type_table[last_type_dec_index].type_id, - (last_type_dec_index - 1), ret_index, type_table) - END; -{#############################################################################} -{--- Looking back from last_index, return the index where the last declar- ----- ation of the specified type identifier may be found. } -{#############################################################################} -FUNCTION tm1find_prev_occurance_of_type_id - (VAR name_string: string132; - last_index: integer; - VAR ret_index: integer; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec): - boolean; - - VAR i: integer; - name_to_find: alfa; - BEGIN - ret_index := 0; - name_to_find := name_string; { reduce length to alfalen characters } - tm1find_prev_occurance_of_type_id := false; - FOR i :=last_index DOWNTO 1 - DO IF (NOT (type_table [i]. entry_purpose IN rectype_expansion)) - AND (type_table [i]. type_id = name_to_find) - THEN BEGIN - tm1find_prev_occurance_of_type_id := true; - ret_index := i; exit - END - END; - - - - - -{#############################################################################} -{--- Return true if we dont want to compare the base type entry field } -{#############################################################################} -FUNCTION exception (entry_purpose: tt_types): boolean; - - BEGIN - exception := entry_purpose IN ttentry_types_where_base_types_wont_compare - END; - - - - - - -{#############################################################################} -{--- Display the current contents of the type table } -{#############################################################################} -PROCEDURE tmdump_type_table - (VAR outfile: text; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); - - VAR i: integer; - BEGIN - writeln (outfile); writeln (outfile, '--- TYPE TABLE DUMP --- '); - write (outfile, ' rec# #fld nest recpurpose cont lbound ubound '); - writeln (outfile, 'mainpurpose base'); - FOR i := 0 TO last_tt_entry - DO WITH type_table [i] - DO BEGIN - write (outfile, i:10); - IF NOT (entry_purpose IN rectype_expansion) - THEN write (outfile, type_id: 20, ' ':8) - ELSE BEGIN - write (outfile, n_of_stacked_fields:5, record_nesting:5); - write_tt_type_value (outfile, field_entry_purpose); - write (outfile, local_fieldlist_continues:5) - END; - write (outfile, lower_bound:7, upper_bound:7); - write_tt_type_value (outfile, entry_purpose); - writeln (outfile, base_type_index:5) - END; - writeln (outfile) - END; - - - - - - - - - - - - - - - -{#############################################################################} -{#############################################################################} -PROCEDURE write_tt_type_value (VAR outfile: text; tt_type_value: tt_types); - - BEGIN - CASE tt_type_value OF - undef_type : write (outfile, ' undef_type '); - predef_type : write (outfile, ' predef_type '); - simple_type : write (outfile, ' simple_type '); - ptr_type : write (outfile, ' ptr_type '); - string_type : write (outfile, ' string_type '); - array_type : write (outfile, ' array_type '); - file_type : write (outfile, ' file_type '); - set_type : write (outfile, ' set_type '); - record_type : write (outfile, ' record_type '); - recfields : write (outfile, ' recfields '); - recfldnestedrecord: write (outfile, ' recfldnested '); - recvariant : write (outfile, ' recvariant '); - recvarvalues : write (outfile, ' recvarvalues ') - END - END; - - - - - - - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/TYPECHK.BLD b/software/CPM/CPM21_MTPUG_09/TYPECHK.BLD deleted file mode 100644 index 8a703b2..0000000 --- a/software/CPM/CPM21_MTPUG_09/TYPECHK.BLD +++ /dev/null @@ -1,11 +0,0 @@ -typelib.erl -b:consttab.erl -b:type1tab.erl -b:vartab.erl -b:routtab.erl -b:scanner.erl -b:inputstd.erl -b:inputfas.erl -b:markrel.erl -b:blockr.erl - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/TYPECHK.CMD b/software/CPM/CPM21_MTPUG_09/TYPECHK.CMD deleted file mode 100644 index c2927f0..0000000 --- a/software/CPM/CPM21_MTPUG_09/TYPECHK.CMD +++ /dev/null @@ -1,2 +0,0 @@ -b:typechk,b:consttab,b:type1tab,b:vartab,b:routtab,b:scanner,b:inputstd, -b:markrel,paslib/s/d:8000 \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/TYPECHK.COM b/software/CPM/CPM21_MTPUG_09/TYPECHK.COM deleted file mode 100644 index 3a9e783..0000000 Binary files a/software/CPM/CPM21_MTPUG_09/TYPECHK.COM and /dev/null differ diff --git a/software/CPM/CPM21_MTPUG_09/TYPECHK.DEC b/software/CPM/CPM21_MTPUG_09/TYPECHK.DEC deleted file mode 100644 index cb4d27c..0000000 --- a/software/CPM/CPM21_MTPUG_09/TYPECHK.DEC +++ /dev/null @@ -1,114 +0,0 @@ -{########################################################################## -#### #### -#### Full module name: INCLUDE FILE for TYPECHK and SCANNER modules. #### -#### File name: TYPECHK.DEC. (109 LINES LONG) #### -#### Support modules reqd: #### -#### Run time environment: . #### -#### Compile time environment: MT MicroSYSTEMS Pascal/MT+v5.25. #### -#### Link time environment: MT MicroSYSTEMS Linkmt v5.1. #### -#### Copyright (C) 1982 by Haldo Products, Inc. All rights reserved. #### -#### 56 Camille Ln, E. Patchogue, NY 11772 #### -#### Programmer: Lawrence Adkins. #### -#### Module Development/Maintenance History: #### - 6-NOV-81 vers 1.0. File just created. - 12-NOV-81 Development of this version is completed. - 9-JAN-82 vers 2.0. development begun. - 1-MAR-82 Development of this version complete. - 6_MAR-82 Vers 2.1. Conformant array stuff added. - 19-APR-82 Vers 2.2. Blockread parameters added. -#### #### -##########################################################################} - - -CONST - header1 = ' Pascal/MT+5.2 Cross Module Type Checking Program. Vers 2.1.'; - header2 = ' Copyright (c) 1982 by Haldo Products, Inc. All rights reserved.'; - datastart = $8000; { Where I tell linker to start the data area} - dataextent = $3225; { data size assuming standard input } -(*dataextent = $4000; { data size assuming fast input } *) - max_constants = 250; { max size of constant table } - max_type_elements = 200; { max size of type table } - max_var_elements = 100; { max size of variable table } - max_routines = 200; { max size of routine table } - alfalen = 8; { max length of any identifier } - output_file = 'OUTPUT.PRN'; { where all scanned text and errors are put } - cpmlinesz = 127; { max chars permitted on cpm command line } - maxlinelength = 132; { max permitted length of Pascal source line} - blkiosize = 2048; { size of io buffer used when blockreading } - cr = $0D; { ascii carriage return code } - lf = $0A; { ascii line feed code } - eofmark = $1A; { char used as eofmark on CPM textfiles } - -TYPE - natural = 0..maxint; { for use with conformant arrays } - alfa = STRING [alfalen]; { identifiers, keywords, etc buffer } - string132 = STRING [maxlinelength]; { input line buffer } - string15 = STRING [15]; { hold file name } - p_array_of_char = PACKED ARRAY [1..blkiosize] OF char; {hold blockread text} - - token_type = { the recognized tokens } - (notoken, tokliteral, toklparen, tokrparen, tokcomma, - tokperiod, tokcolon, toksemicolon, tokequal, toklbracket, - tokrbracket, tokdotdot, tokpointer, tokminus, tokplus, - tokintnum, tokbytenum, tokrealnum, toklitstring, tokidentifier, - tokbegin, tokend, tokconst, toktype, tokvar, - tokproc, tokfunc, tokpacked, tokstring, tokarray, - tokof, tokfile, tokset, tokrecord, tokcase, - tokexternal, toklabel ); - - tt_types = { the types assignable to an entry in the type table } - (undef_type, predef_type, simple_type, ptr_type, string_type, - array_type, file_type, set_type, record_type, recfields, - recfldnestedrecord, recvariant, recvarvalues); - - t_parm_class = { the attributes of a parameter in the routine table } - (var_parm, value_parm, func_value, conform_array, procfunc); - - t_const_tab_rec = RECORD { A record of the constant table } - const_id: alfa; - actual_value: integer - END; - - t_type_tab_rec = RECORD { A record of the type table } - lower_bound, - upper_bound: integer; - base_type_index: natural; - CASE entry_purpose: tt_types OF - undef_type, predef_type, simple_type, ptr_type, string_type, - array_type, file_type, set_type, record_type: - (type_id : alfa); - recfields, recfldnestedrecord, recvariant, recvarvalues: - (n_of_stacked_fields, - record_nesting: byte; - field_entry_purpose: tt_types; - local_fieldlist_continues: boolean) - END; - - t_var_tab_rec = RECORD { A record of the variable table } - var_id: alfa; - var_ptr_to_type_table: natural - END; - - t_ptr_to_next_parm = ^t_parm; - - t_parm = RECORD { one parameter's info linked to the routine table } - parm_class: t_parm_class; - parm_indx_to_type_table: natural; - rest_of_parm_list: t_ptr_to_next_parm - END; - - t_rout_tab_rec = RECORD { A record of the routine table } - routine_name: alfa; - parm_list: t_ptr_to_next_parm - END; - - t_record_parsing_status = RECORD {Contains some important type_parsing info} - got_rec_type: byte; - last_n_of_stacked_fields: byte; - last_base_type_index: natural - END; - - - - - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/TYPECHK.PAS b/software/CPM/CPM21_MTPUG_09/TYPECHK.PAS deleted file mode 100644 index 5e4fd96..0000000 --- a/software/CPM/CPM21_MTPUG_09/TYPECHK.PAS +++ /dev/null @@ -1,462 +0,0 @@ -{########################################################################## -#### #### -#### Full program name: MULTI_MODULE_PARAMETER_AND_VAR_TYPE_CHECKER. #### -#### File name: TYPECHK.PAS. #### -#### Support modules reqd: PASLIB.ERL, SCANNER. #### -#### Run time environment: . #### -#### Compile time environment: MT MicroSYSTEMS Pascal/MT+v5.25. #### -#### Link time environment: MT MicroSYSTEMS Linkmt v5.1. #### -#### Copyright (C) 1982 by Haldo Products Inc. All rights reserved. #### -#### 56 Camille Ln, E. Patchogue, NY 11772 #### -#### Programmer: Lawrence Adkins. #### -#### Module Development/Maintenance History: #### - 6-NOV-81 Vers 1.0. File just created. - 12-NOV-81 Development of this version completed. - 9-JAN-82 Vers 2.0. development begins. - 1-MAR-82 Development of this version completed. - 6-MAR-82 Vers 2.1. Conformant array stuff added. - 19-APR-82 Vers 2.2. Add blockread compatibility stuff. -#### #### -##########################################################################} - - -{####################################################################### -#### #### -#### C R O S S M O D U L E T Y P E C H E C K E R #### -#### #### -#### This program, along with the scanner module located in the #### -#### 'scanner.pas' file, scans a series of Pascal/MT source files #### -#### to make sure that the routines defined in one module and #### -#### referenced from within separate modules have the same number #### -#### of parameters and that the types of the corresponding parms #### -#### match. A listing of all errors is output to a diskfile named #### -#### 'output.prn'. The list of file names to scan is expected to #### -#### be in the file whose name is specified in the command line. #### -#### To use, #### -#### 1) Compile the modules using MTPLUS to remove all errors that #### -#### can be trapped by that program. This program will bomb if #### -#### syntactic errors normally trapped by MTPLUS exist in the #### -#### files being scanned. #### -#### 2) Edit the file 'FILES.CMD' to enter the names of the files #### -#### to be scanned by this program, one file per line, with a #### -#### carriage return after even the last file name. #### -#### Sample 'files.cmd' contents: '' means carriage return #### -#### ; typechk 1.0 source files. #### -#### ; (This is a CPM-type comment) #### -#### ; There are 3 switches permitted: $D, $Pd and $@ #### -#### b:mprog.pas $D $PB #### -#### b:mymodule.pas $D #### -#### 3) Run the program TYEPECHK FILES.CMD #### -#### The program expects the list of file name file to be specified#### -#### on the command line. #### -#######################################################################} - - - - - - - - - - - - - - -PROGRAM mult_module_type_checker; - -{$I B:TYPECHK.DEC} - -VAR - memory: ABSOLUTE [$0000] ARRAY [0..0] OF byte; - sysmem: EXTERNAL integer; - - infile: text; { infile is pascal source file with no errors after } - outfile: text; { file where listing of errors is sent } - filenamefile: text; { file containing list of files to be scanned } - - input_line: string132; { holds line currently being scanned } - curr_input_line: string132; { hold lines of input for printing upon error } - prev_input_line: string132; - prev1_input_line: string132; - token: tokentype; { hold last token scanned } - tokenbuf,ident_buf: string132; { hold last identifier/number/string scanned } - charbuf: char; { hold last character scanned } - - debug: boolean; { determines if tables are dumped often or not } - file_entered: boolean; { has same effect as eof(filenamefile)} - symbols_avail_for_external_reference: boolean; {false if $E-, else true } - at_is_alternative_pointer_symbol: boolean;{true if $@ switch seen else false} - last_entry_point_name: string132; { store last $E+ symbol scanned } - include_file_level: byte; { 0 if in main file, 1 if in include file } - includ_file_name: string15; { holds name of the source file being included } - i: integer; { no special purpose } - fname: string132; { name of the file currently being compiled } - cpmcmdbuf: ABSOLUTE [$80] PACKED ARRAY [0..cpmlinesz] OF char; - cpmstr: STRING [cpmlinesz]; - list_of_files: string15; - - const_table: ARRAY [1..max_constants] OF t_const_tab_rec; - type_table : ARRAY [0..max_type_elements] OF t_type_tab_rec; - var_table : ARRAY [1..max_var_elements] OF t_var_tab_rec; - routine_table: ARRAY [1..max_routines] OF t_rout_tab_rec; - -EXTERNAL PROCEDURE @hlt; { Stop program execution } -EXTERNAL FUNCTION @bdos (func: integer; parm: word): integer; -EXTERNAL PROCEDURE get_next_token; -EXTERNAL PROCEDURE init_scan; -EXTERNAL PROCEDURE mark ({VAR} p: integer); -EXTERNAL PROCEDURE release (p: integer); -EXTERNAL PROCEDURE cminit_constant_table_module - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec); -EXTERNAL PROCEDURE tminit_type_table_module - (VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); -EXTERNAL PROCEDURE vminit_var_table_module; -EXTERNAL PROCEDURE rminit_routine_table_module; -EXTERNAL PROCEDURE cmadd_new_constants_to_const_table - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec); -EXTERNAL PROCEDURE tmadd_new_types_to_type_table - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); -EXTERNAL PROCEDURE vmadd_new_vars_to_var_table - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec; - VAR var_table : ARRAY [vtlobound..vthibound: natural] OF t_var_tab_rec); -EXTERNAL PROCEDURE rmadd_new_routines_to_routine_table - (VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec; - VAR routine_table: ARRAY [rtlobound..rthibound: natural] OF t_rout_tab_rec); -EXTERNAL PROCEDURE cmdump_constant_table - (VAR outfile: text; - VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec); -EXTERNAL PROCEDURE tmdump_type_table - (VAR outfile: text; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); -EXTERNAL PROCEDURE vmdump_variable_table - (VAR outfile: text; - VAR var_table : ARRAY [vtlobound..vthibound: natural] OF t_var_tab_rec); -EXTERNAL PROCEDURE rmdump_routine_table - (VAR outfile: text; - VAR routine_table: ARRAY [rtlobound..rthibound: natural] OF t_rout_tab_rec); -EXTERNAL PROCEDURE init_main_file_buffer; - - - - - - - - - - - - - -{########################################################################## -#### Print out an error message. -##########################################################################} -PROCEDURE error (pascal_error_no: integer); - - CONST - bar = '-------------------------------------------------------'; - fmsg = 'File being Scanned: '; - epmsg = 'Entry Point is: '; - ltsmsg = 'Last Identifier Scanned: '; - errmsg = 'Error # '; - VAR ch: char; - BEGIN - writeln; writeln(outfile); - IF pascal_error_no > 0 - THEN BEGIN - writeln (bar); writeln (outfile, bar); - writeln (prev1_input_line);writeln (outfile,' ':10, prev1_input_line); - writeln (prev_input_line); writeln (outfile, ' ':10, prev_input_line); - writeln (curr_input_line); writeln (outfile, ' ':10, curr_input_line); - writeln (bar); writeln (outfile, bar); - writeln (fmsg, fname); writeln (outfile, fmsg, fname); - writeln (epmsg, last_entry_point_name); - writeln (outfile, epmsg, last_entry_point_name); - writeln (ltsmsg, ident_buf); writeln (outfile, ltsmsg, ident_buf); - writeln (errmsg, pascal_error_no); - writeln (outfile, errmsg, pascal_error_no); - writeln ('Hit any key to continue...'); - WHILE @bdos (11,wrd(-1)) <> 0 DO read (ch); { remove queued up chars } - read (ch) { wait so that the user can recognize the error occurance } - END; - IF NOT debug - THEN ch := 'Y' - ELSE BEGIN write ('???? Want Tables (Y/N)? '); read (ch); writeln END; - IF uppercase (ch) = 'Y' - THEN BEGIN - cmdump_constant_table (output, const_table); - cmdump_constant_table (outfile, const_table); - tmdump_type_table (output, type_table); - tmdump_type_table (outfile, type_table); - vmdump_variable_table (output, var_table); - vmdump_variable_table (outfile, var_table); - rmdump_routine_table (output, routine_table); - rmdump_routine_table (outfile, routine_table); - END - END; - - - - - - - - - - - - - - - - - - - - -{###################################################################### -#### Repeatedly try to open files (containing pascal source) whose names -#### were specified in filenamefiles until a file is successfully opened -#### for parsing. File_entered is set false if eof is met here. -#### Limitations: Each filename must start on the first column of -#### a separate line. Comments must also start on the first column of -#### a new line, and must begin with a ':' or ';' character. -#### MTPLUS compiler-like switches $Pd and $@ are now also supported. -#### The P switch puts the output file onto the specified device, and -#### the default is not to have an output file listing. The @ switch, -#### if present, permits use of the '@' character instead of the '^' -#### character. The default is that '@' is an identifier character. -#### An enabled @ switch will be disabled when the end of the specified -#### module is reached. -######################################################################} -PROCEDURE obtain_and_open_an_input_file; - - CONST - openerrmsg = '*** Unable to Open Input file: '; - openmsg = 'Processing file: '; - VAR - openerrnum: integer; - openok : boolean; - BEGIN - close (infile, openerrnum); - REPEAT - debug := false; {by default, switch $D is off} - at_is_alternative_pointer_symbol := false; {by default, switch $@ is off} - openok := NOT eof (filenamefile); - IF openok - THEN BEGIN - REPEAT readln (filenamefile, fname) - UNTIL ((fname[1] <> ':') AND (fname[1] <> ';')) OR eof (filenamefile); - { permit comments the way CP/M permits them in ".SUB" files. } - writeln; writeln (outfile); - handle_directive_switches (fname); - open (infile, fname, openerrnum); openok := openerrnum <> 255; - IF NOT openok - THEN BEGIN - writeln (openerrmsg, fname); writeln (outfile, openerrmsg, fname) - END - ELSE BEGIN - init_main_file_buffer; - writeln (openmsg, fname); writeln (outfile, openmsg, fname) - END - END - UNTIL openok OR eof (filenamefile); - symbols_avail_for_external_reference := true; {by default, toggle is $E+} - file_entered := openok - END; - - - - - - - - - - - - - - - - -{########################################################################### -#### Handle compiler directive switches. -#### Only $Pd and $@ switches presently implemented, -#### The acceptable format is -#### filename.pas $PB $@ $D -###########################################################################} -PROCEDURE handle_directive_switches (VAR fname: string132); - - VAR position: byte; - FUNCTION switch_char_posn (VAR fname: string132): byte; - VAR n: integer; - BEGIN - n := pos ('$', fname); - IF n = 0 THEN n := pos ('#', fname); - switch_char_posn := n - END; - BEGIN - FOR position := 1 TO length (fname) - DO fname [position] := uppercase (fname [position]); - WHILE fname[1] = ' ' DO delete (fname, 1, 1); - { search for multiple '$' switches, and act on them } - position := switch_char_posn (fname); - WHILE position > 0 - DO BEGIN - fname [position] := '&'; - CASE fname [position + 1] OF - 'P': open_output_file (fname [position + 2]); - '@': at_is_alternative_pointer_symbol := true; - 'D': debug := true - END; - position := switch_char_posn (fname) - END; - { remove the switch settings from the file name } - position := pos (' ', fname); - IF position > 0 THEN fname := copy (fname, 1, position-1) - END; - - - - - - - - -{########################################################################### -#### Open the file output.prn, where the listing is sent to. -###########################################################################} -PROCEDURE open_output_file (drive_spec: char); - - VAR - s: STRING [15]; - i: integer; - BEGIN - close (outfile, i); - IF drive_spec = 'P' - THEN s := 'LST:'; - assign (outfile, s); - rewrite (outfile); - writeln (outfile); writeln (outfile, header1); - writeln (outfile, header2); writeln (outfile); - END; - - - - - -{######################################################################## -#### read a file name from the command_line buffer, and return in outstr. -########################################################################} -PROCEDURE getname (VAR outstr: string15); - - BEGIN - outstr := ''; - { strip off the leading blanks } - WHILE (length (cpmstr) > 0) AND (cpmstr [1] = ' ') - DO delete (cpmstr, 1, 1); - { obtain the file name characters } - WHILE (length (cpmstr) > 0) AND (cpmstr [1] <> ' ') - DO BEGIN outstr := concat (outstr, cpmstr[1]); delete (cpmstr, 1, 1) END - END; - - - - - - - - -{#################################################################### -#### Initialize everything other than the four identifier tables. -####################################################################} -PROCEDURE initialize; - - VAR i: integer; - BEGIN - { copy command tail to a private pascal string } - move ({from} cpmcmdbuf, {to} cpmstr, cpmlinesz + 1 {bytes}); - getname (list_of_files); - writeln; writeln (header1); writeln (header2); writeln; - open (filenamefile, list_of_files, i); - IF i = 255 - THEN BEGIN - writeln ('Failure to Open Input file: ',list_of_files, - ' containing the list of file names. '); - @hlt { halt program execution } - END; - file_entered := false; - include_file_level := 0; { by default, not in include file } - includ_file_name := ''; - input_line := ''; charbuf := ' '; - last_entry_point_name := ''; - token := notoken; - END; - - - - -{################################################################## -#### Convert a lower case alpha char to an upper case one. -##################################################################} -FUNCTION uppercase (charbuf: char): char; - - BEGIN - IF (charbuf >= 'a') AND (charbuf <= 'z') - THEN charbuf := chr (charbuf & $DF); - uppercase := charbuf - END; - - - - - -{################################################################### -#### The main program.... -###################################################################} - -BEGIN -fillchar (memory [datastart], dataextent, chr (0)); {zero out the data area} -{ We had to use the linker's "/D" option and also do local file I/O } -initialize; -init_scan; -cminit_constant_table_module (const_table); -tminit_type_table_module (type_table); -vminit_var_table_module; -rminit_routine_table_module; -obtain_and_open_an_input_file; -WHILE file_entered -DO BEGIN - cmadd_new_constants_to_const_table (const_table); { add constants } - tmadd_new_types_to_type_table (const_table, type_table); { add types } - vmadd_new_vars_to_var_table (const_table, type_table, var_table);{ " vars } - rmadd_new_routines_to_routine_table (type_table, routine_table); - { check routine parms } - tokenbuf := 'Normal EOF Reached on Source file. '; - writeln; writeln (outfile); writeln (tokenbuf); writeln (outfile,tokenbuf); - error (0); { get a dump of the tables at this point } - obtain_and_open_an_input_file - END; -tokenbuf := 'End of Normal Program Execution. '; -writeln; writeln (outfile); -writeln (tokenbuf); writeln (outfile, tokenbuf); -close (outfile, i); -IF i = 255 -THEN writeln ('Unable to Close file: ', output_file) -ELSE writeln ('Examine file: ',output_file) -END. - - - - - - - - - - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/TYPECHK.SUB b/software/CPM/CPM21_MTPUG_09/TYPECHK.SUB deleted file mode 100644 index bfbe6d9..0000000 --- a/software/CPM/CPM21_MTPUG_09/TYPECHK.SUB +++ /dev/null @@ -1,14 +0,0 @@ -mtplus b:typechk -mtplus b:consttab -mtplus b:type1tab #tb -mtplus b:vartab -mtplus b:routtab -mtplus b:scanner -mtplus b:inputstd -mtplus b:inputfas -mtplus b:markrel -mtplus b:blockr -libmt b:typechk -l b:typechk,typelib/s,mylib/s,paslib/s/d:8500 -era typelib.erl - \ No newline at end of file diff --git a/software/CPM/CPM21_MTPUG_09/VARTAB.PAS b/software/CPM/CPM21_MTPUG_09/VARTAB.PAS deleted file mode 100644 index ef687ca..0000000 --- a/software/CPM/CPM21_MTPUG_09/VARTAB.PAS +++ /dev/null @@ -1,198 +0,0 @@ -{########################################################################## -#### #### -#### Full module name: VARIABLE_TABLE_MODULE_FOR_TYPE_CHECKER_PROGRAM.#### -#### File name: VARTAB.PAS. #### -#### Support modules reqd: TYPETAB.PAS, PASLIB.ERL. #### -#### Run time environment: . #### -#### Compile time environment: MT MicroSYSTEMS Pascal/MT+v5.25. #### -#### Link time environment: MT MicroSYSTEMS Linkmt v5.1. #### -#### Copyright (C) 1982 by Haldo Products, Inc. All rights reserved. #### -#### 56 Camille Ln, E. Patchogue, NY 11772 #### -#### Programmer: Lawrence Adkins. #### -#### Module Development/Maintenance History: #### - 1-MAR-82 Vers 2.0. File just created, and completed. - 6-MAR-82 Vers 2.1. Conformant array stuff added. - 19-APR-82 Vers 2.2. No changes made. -#### #### -##########################################################################} - - - - - -MODULE VARIABLE_TABLE_HANDLER; - -{$I B:TYPECHK.DEC } { list of all our type declarations } - -VAR - last_vt_entry: integer; { last filled element of var table } - token: EXTERNAL tokentype; - tokenbuf: EXTERNAL string132; - exit_keywords: EXTERNAL SET OF tokentype; - last_entry_point_name: EXTERNAL string132; - outfile: EXTERNAL text; - record_parsing_status: EXTERNAL t_record_parsing_status; - last_tt_entry: EXTERNAL integer; - symbols_avail_for_external_reference: EXTERNAL boolean; - debug: EXTERNAL boolean; - -EXTERNAL PROCEDURE get_next_token; -EXTERNAL PROCEDURE error (pascal_error_no: integer); -EXTERNAL PROCEDURE @hlt; -EXTERNAL PROCEDURE tm1add_type_identifier_to_type_table - ( new_id: alfa; - VAR type_table: ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); -EXTERNAL PROCEDURE tm0parse_rest_of_type_definition - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec); -EXTERNAL FUNCTION tm1find_prev_occurance_of_type_id - (VAR type_id: string132; - last_index: integer; - VAR ret_index: integer; - VAR type_table: ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec): - boolean; - - -{#############################################################################} -{--- Initialize the variables in this module } -{#############################################################################} -PROCEDURE vminit_var_table_module; - - BEGIN - last_vt_entry := 0 - END; - - - -{#############################################################################} -(*-- Then we will parse the following Pascal/MT+ BNF productions: ----- ::= | ----- VAR {; } ; ----- ::= {, } : ----- ----- ::= EXTERNAL | ABSOLUTE [ ] | ----- ::= ----- *) -{#############################################################################} -PROCEDURE vmadd_new_vars_to_var_table - (VAR const_table: ARRAY [ctlobound..cthibound: natural] OF t_const_tab_rec; - VAR type_table : ARRAY [ttlobound..tthibound: natural] OF t_type_tab_rec; - VAR var_table : ARRAY [vtlobound..vthibound: natural] OF t_var_tab_rec); - - CONST action = 'Handling Variables...'; - VAR type_id: alfa; - b: boolean; - i, j, typ_index, first_var_index: integer; - BEGIN - writeln; writeln (action); writeln (outfile); writeln (outfile, action); - exit_keywords := - [tokvar, tokproc, tokfunc, tokbegin, tokexternal]; - record_parsing_status.got_rec_type := 0; - - WHILE token = tokvar - DO BEGIN - get_next_token; { should be var identifier } - REPEAT - type_id := concat ('9', tokenbuf); - tm1add_type_identifier_to_type_table (type_id, type_table); - first_var_index := last_vt_entry + 1; - REPEAT { for the list of vars being declared of the same type } - last_entry_point_name := tokenbuf; - vmplace_var_id_into_var_table (var_table); - get_next_token; { should be tokcolon } - IF token = tokcomma THEN get_next_token { should be var_id } - UNTIL token = tokcolon; - - REPEAT - { let that routine strip off the } - tm0parse_rest_of_type_definition (const_table, type_table) - UNTIL (record_parsing_status.got_rec_type= 0) AND (token= toksemicolon); - - b := tm1find_prev_occurance_of_type_id - (type_id, last_tt_entry, i, type_table); - WITH type_table [i] - DO IF entry_purpose = simple_type - THEN BEGIN - typ_index := base_type_index; last_tt_entry := last_tt_entry - 1 - END - ELSE typ_index := i; - FOR j := first_var_index TO last_vt_entry - DO var_table [j]. var_ptr_to_type_table := typ_index; - IF NOT symbols_avail_for_external_reference - THEN BEGIN last_tt_entry := i-1; last_vt_entry := first_var_index-1 END - ELSE vmremove_duplicate_var_entry (var_table); - IF debug THEN error (0); - get_next_token; { should be var_id or exit keyword } - UNTIL (token IN exit_keywords); - END - END; - - - - -{#############################################################################} -{---- Check for identical identifier earlier in the table, if match, ------ compare entries, and erase latter entry. } -{#############################################################################} -PROCEDURE vmremove_duplicate_var_entry - (VAR var_table : ARRAY [vtlobound..vthibound: natural] OF t_var_tab_rec); - - VAR i: integer; - BEGIN - FOR i := 1 TO (last_vt_entry - 1) - DO WITH var_table [i] - DO IF var_id = var_table [last_vt_entry]. var_id - THEN BEGIN - IF var_ptr_to_type_table <> - var_table [last_vt_entry].var_ptr_to_type_table - THEN error (101); { id declared elsewhere with different value } - last_vt_entry := last_vt_entry - 1; - exit - END - END; - - -{#############################################################################} -{--- Bump the index into the variable table by one. Error if overflow. ----- Then insert the variable identifier presently in tokenbuf. } -{#############################################################################} -PROCEDURE vmplace_var_id_into_var_table - (VAR var_table : ARRAY [vtlobound..vthibound: natural] OF t_var_tab_rec); - - VAR i: integer; - BEGIN - IF last_vt_entry >= vthibound - THEN BEGIN - writeln; - writeln ('Variable table overflow. Last id: ', last_entry_point_name); - close (outfile, i); - @hlt - END; - last_vt_entry := last_vt_entry + 1; - var_table [last_vt_entry]. var_id := tokenbuf - END; - - - -{#############################################################################} -{--- Display the current contents of the variable table } -{#############################################################################} -PROCEDURE vmdump_variable_table - (VAR outfile: text; - VAR var_table : ARRAY [vtlobound..vthibound: natural] OF t_var_tab_rec); - - VAR i: integer; - BEGIN - writeln (outfile); writeln (outfile, '--- Variable Table Dump --- '); - writeln (outfile, 'name':30, 'type index':15); - FOR i := 1 TO last_vt_entry - DO WITH var_table[i] - DO writeln (outfile, i:10, var_id:20, var_ptr_to_type_table:15); - writeln (outfile) - END; - - - -MODEND. - - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/-MTPUG.010 b/software/CPM/CPM22_MTPUG_10/-MTPUG.010 deleted file mode 100644 index e69de29..0000000 diff --git a/software/CPM/CPM22_MTPUG_10/-MTPUG.DOC b/software/CPM/CPM22_MTPUG_10/-MTPUG.DOC deleted file mode 100644 index 81d3405..0000000 --- a/software/CPM/CPM22_MTPUG_10/-MTPUG.DOC +++ /dev/null @@ -1,53 +0,0 @@ -*** MTPUG.010 July 11, 1983 *** - -FFT.DOC - - The Pascal programs PASFFT1.SRC thru PASFFT4.SRC use several -different techniques to calculate the Fast Fourier Transform. The -programs have been tested with and without the AMD 9511. The times -and the advantages of each are described. Written by J.A. Koehler, -2 Sullivan St., Saskatoon, SK, S7H-3G8. - -FFTKF.DOC -FFTKF.PAS -FFTLIB.PAS - - This is an implementation of the radix-2, fast Fourier Transform -algorithm with decimation in time (Cooley-Tukey method). There are -many methods of computing discrete Fourier transforms in order -(N log N) floating point operations. FFTKF.PAS represents an efficient -, but relative straight forward approach well suited to micro- -processors. Written by Kurt Fickie, 144 So. Catalina, CA 91106 - -FACT2K.DOC -FACT2K.PAS - - This program will analize experimental data from a 2**k factorial -design. As an example, you could determine the effects and inter- -actions of multiple variables such as temperature, pressure, flow -etc. in a study of conversion yield of a catalytic reaction. -Written by Kurt Fickie, 144 So. Catalina, CA 91106 - -LAB.PAS - - A program for computer control of laboratory equipment using -A/D and D/A interface boards. See article in Newsletter #9. -Written by Kurt Fickie, 144 So. Catalina, CA 91106 - -CPMNAME.SRC -PASMAT.CMD -PASMAT.SRC -PASMAT.SUB -PMCOMENT.SRC -PMDEFS.INC -PMFILEIO.SRC -PMINIT.SRC -PMPARSE.SRC -RNB.SRC - - The PASMAT Pascal/MT reformatter source code for use by -a CPM-80 (8080/Z80) system. Files with the same name but ending -in .PAS, .SU, and .IN are for use on a CPM-86 system. Written -by Steven Clamage, 6072 Cirrus St., San Diego, CA 92110 - - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/CPMNAME.PAS b/software/CPM/CPM22_MTPUG_10/CPMNAME.PAS deleted file mode 100644 index 6f47ba4..0000000 --- a/software/CPM/CPM22_MTPUG_10/CPMNAME.PAS +++ /dev/null @@ -1,90 +0,0 @@ -module tstcpmname; - {Test input string for valid CP/M file name or device } - {MT+86 version, allows for recursion offset of device name table} - {by Steve Clamage} - - - function cpmname(fname: string): boolean; - - const - numdevs = 6; {number of defined devices} - - type {[b+]} - devs = 1..numdevs; - devnames = array [devs] of string[4]; - devptr = ^devnames; - ptrkludge = record {see MT+86 manual section 3.8} - case boolean of - true : (p: devptr); - false: (loword: word; - hiword: word); - end; - - var {[b-]} - gotdot: boolean; - cname, cext, i, len: integer; - badset: set of char; - devtptr: devptr; - p: ptrkludge; - - procedure devname; {table of device names} - - begin {[f-]} - inline( 4/ 'CON:'/ - 4/ 'KBD:'/ - 4/ 'TRM:'/ - 4/ 'LST:'/ - 4/ 'RDR:'/ - 4/ 'PUN:' - ); {[f+]} - end; - - begin {cpmname} - p.p := addr(devname); {see MT+86 manual section 3.8} - p.loword := p.loword + wrd(8); - devtptr := p.p; - for i := 1 to numdevs do {check for device name} - if fname = devtptr^[i] then - begin - cpmname := true; - exit; {got one, so it's ok} - end; - cpmname := false; {assume the worst} - badset := [' ', '<', '>', ',', ':', '=', '*', '?', '[', ']']; - len := length(fname); - if len = 0 then {zero-length name} - exit; - i := 1; {start with 1st character} - if len > 1 then - if fname[2] = ':' then {if 2nd is colon...} - i := 3; {...start test with 3rd} - gotdot := false; - cname := 0; {# chars in name portion} - while (i <= len) and (not gotdot) do {scan name portion} - begin - if fname[i] = '.' then {period terminates name scan} - gotdot := true - else - begin - cname := cname + 1; - if fname[i] in badset then - exit; {illegal character} - end; - i := i + 1 - end; - cext := 0; {# chars in extent portion} - badset := badset + ['.']; - while (i <= len) do {scan extent portion} - begin - cext := cext + 1; - if fname[i] in badset then - exit; {illegal character} - i := i + 1; - end; - if (cname < 1) or (cname > 8) or (cext > 3) then - exit; {improper length} - cpmname := true; {it's ok!} - end; - -modend . - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/CPMNAME.SRC b/software/CPM/CPM22_MTPUG_10/CPMNAME.SRC deleted file mode 100644 index b79b9a6..0000000 --- a/software/CPM/CPM22_MTPUG_10/CPMNAME.SRC +++ /dev/null @@ -1,80 +0,0 @@ -module tstcpmname; - {Test input string for valid CP/M file name or device } - {by Steve Clamage} - - - function cpmname(fname: string): boolean; - - const - numdevs = 6; {number of defined devices} - - type - devs = 1..numdevs; - devnames = array [devs] of string[4]; - - var - gotdot: boolean; - cname, cext, i, len: integer; - badset: set of char; - devtptr: ^devnames; - - - procedure devname; {table of device names} - - begin {[f-]} - inline( 4/ 'CON:'/ - 4/ 'KBD:'/ - 4/ 'TRM:'/ - 4/ 'LST:'/ - 4/ 'RDR:'/ - 4/ 'PUN:' - ); {[f+]} - end; - - begin {cpmname} - devtptr := addr(devname); - for i := 1 to numdevs do {check for device name} - if fname = devtptr^[i] then - begin - cpmname := true; - exit; {got one, so it's ok} - end; - cpmname := false; {assume the worst} - badset := [' ', '<', '>', ',', ':', '=', '*', '?', '[', ']']; - len := length(fname); - if len = 0 then {zero-length name} - exit; - i := 1; {start with 1st character} - if len > 1 then - if fname[2] = ':' then {if 2nd is colon...} - i := 3; {...start test with 3rd} - gotdot := false; - cname := 0; {# chars in name portion} - while (i <= len) and (not gotdot) do {scan name portion} - begin - if fname[i] = '.' then {period terminates name scan} - gotdot := true - else - begin - cname := cname + 1; - if fname[i] in badset then - exit; {illegal character} - end; - i := i + 1 - end; - cext := 0; {# chars in extent portion} - badset := badset + ['.']; - while (i <= len) do {scan extent portion} - begin - cext := cext + 1; - if fname[i] in badset then - exit; {illegal character} - i := i + 1; - end; - if (cname < 1) or (cname > 8) or (cext > 3) then - exit; {improper length} - cpmname := true; {it's ok!} - end; - -modend . - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/FACT2K.DOC b/software/CPM/CPM22_MTPUG_10/FACT2K.DOC deleted file mode 100644 index be213a3..0000000 --- a/software/CPM/CPM22_MTPUG_10/FACT2K.DOC +++ /dev/null @@ -1,41 +0,0 @@ - - - - - FACT2K.PAS analyzes experimental data from a 2**k factorial -design. This is a common statistical technique used in examining -all possible combinations of two levels of k separate factors under -contorl of an experimentalist. As an illustration, a chemist may -wish to study the conversion yield of a catalytic reaction by running -experiments of two catalyst preparations, two temperatures, two -pressures, and two reactant ratios. Upon analyzing the data, the -chemist can determine the effects and interations of the various -treatments (temperature effect, pressure-catalyst interaction, ect.). - - There are many variations of this technique: n**k designs, frac- -tional factorial, block designs, and replicated 2**k factorial designs. -They would be programmed similarly. For more information, study a book -on experimental statistics. Two elementary ones which I recommend are: - - I. Guttman, S. Wilks, and J.S. Hunter, "Introductory - Engineering Statistics," (Wiley:1982). - - G.E.P. Box, W.G. Hunter, and J.S. Hunter, "Statistics - for Experimentalist," (Wiley:1978). - - -The output from FACT2K using the input file FACT2K.IN is the same as -that shown in the appendix of Guttman, Wilks, and Hunter. - - Of particular interest to me was the Yates' algorithm (1937) for -the 2**k factorial. This algorithm will manipulate specially ordered -data in (N log N) multiplications instead of the obvious N**2 method. -Its similarity to the fast Fourier transform is striking. John Tukey, -one of the world's foremost statisticians, only upon prompting outlined -his method of efficiently computing Fourier transforms. His total famil- -iarity with Yates' algorithm probably contributed to his under-estimation -of the FFT's inportance to computing. - - - - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/FACT2K.IN b/software/CPM/CPM22_MTPUG_10/FACT2K.IN deleted file mode 100644 index 1d5e386..0000000 --- a/software/CPM/CPM22_MTPUG_10/FACT2K.IN +++ /dev/null @@ -1,18 +0,0 @@ - - 62 - 88 - 63 - 83 - 88 - 80 - 99 - 92 - 65 - 123 - 65 - 121 - 97 - 105 - 92 - 117 - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/FACT2K.OUT b/software/CPM/CPM22_MTPUG_10/FACT2K.OUT deleted file mode 100644 index a2f8391..0000000 --- a/software/CPM/CPM22_MTPUG_10/FACT2K.OUT +++ /dev/null @@ -1,45 +0,0 @@ - - Data in Yates Order - ************************* - 62.00 - - - - - 88.00 + - - - - 63.00 - + - - - 83.00 + + - - - 88.00 - - + - - 80.00 + - + - - 99.00 - + + - - 92.00 + + + - - 65.00 - - - + - 123.00 + - - + - 65.00 - + - + - 121.00 + + - + - 97.00 - - + + - 105.00 + - + + - 92.00 - + + + - 117.00 + + + + - - - Average = 90.00 - - Estimated Effect Contrib. to Identification - Effects Treatment Sum of Squares of Effects - *********************************************************** - - 22.25 1980.25 1 - 3.00 36.00 2 - 1.25 6.25 12 - 12.50 625.00 3 - -17.75 1260.25 13 - 4.50 81.00 23 - 3.25 42.25 123 - 16.25 1056.25 4 - 14.50 841.00 14 - -1.75 12.25 24 - 2.50 25.00 124 - -3.25 42.25 34 - -2.50 25.00 134 - -2.25 20.25 234 - 1.50 9.00 1234 - - Sum of Squares = 2170592.00 - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/FACT2K.PAS b/software/CPM/CPM22_MTPUG_10/FACT2K.PAS deleted file mode 100644 index 9b8a81c..0000000 --- a/software/CPM/CPM22_MTPUG_10/FACT2K.PAS +++ /dev/null @@ -1,104 +0,0 @@ - - PROGRAM FACT2K(INFILE,INPUT,OUTPUT); - -CONST k = 4; - n = 16; {n=2**k} - -TYPE VECTOR = ARRAY[1..n] OF REAL; - -VAR M : ARRAY[1..n,1..k] OF INTEGER; - I,J,L : INTEGER; - COUNT1 : INTEGER; - COUNT2 : INTEGER; - INDEX : INTEGER; - COUNT : INTEGER; - IORESULT : INTEGER; - Y : VECTOR; - SSQ : REAL; - SSQ_YI : REAL; - INFILE : TEXT; - -PROCEDURE YATES( INDEX : INTEGER; X : VECTOR; VAR Y : VECTOR); - {performs Yates' algorithm for the 2**k factorial design.} - {See p. 461 of Guttman, Wilks, & Hunter for details. } - - VAR I,J : INTEGER; - BEGIN - J:=0; - FOR I:=1 TO INDEX DO - BEGIN - J:=J+2; - Y[I ]:=X[J] + X[J-1]; - Y[I+INDEX]:=X[J] - X[J-1] - END - END; - - - -BEGIN -OPEN(INFILE,'FACT2K.IN',IORESULT); -RESET(INFILE); - -COUNT1:=n DIV 2; -COUNT2:=1; -FOR J:=1 TO k DO - BEGIN - INDEX:=1; - FOR I:=1 TO COUNT1 DO - BEGIN - FOR L:=1 TO COUNT2 DO - BEGIN - M[INDEX ,J]:=-1; - M[INDEX+COUNT2,J]:=+1; - INDEX:=INDEX+1 - END; - INDEX:=INDEX+COUNT2 - END; - COUNT2:=2*COUNT2; - COUNT1:=COUNT1 DIV 2 - END; - -WRITELN(' Data in Yates Order'); -WRITELN(' *************************'); -FOR I:=1 TO n DO - BEGIN - READLN(INFILE,Y[I]); - WRITE(Y[I]:10:2,' ':5); - FOR J:=1 TO K DO - BEGIN - IF M[I,J]=1 THEN - WRITE('+') - ELSE WRITE('-'); - WRITE(' ':2) - END; - WRITELN - END; - -COUNT:=n DIV 2; -FOR J:=1 TO k DO - YATES(COUNT,Y,Y); - -WRITELN; WRITELN; -WRITELN(' Average = ',Y[1]/n:10:2); WRITELN; - -SSQ:=Y[1]*Y[1]; -WRITELN(' ':5,' Estimated Effect Contrib. to Identification'); -WRITELN(' ':5,' Effects Treatment Sum of Squares of Effects' ); -WRITELN(' ':5,'***********************************************************'); -WRITELN; - -FOR I:=2 TO n DO - BEGIN - SSQ_YI:=Y[I]*Y[I]; - WRITE(' ':2,Y[I]/COUNT:10:2, ' ':11,SSQ_YI/n:10:2, ' ':21); - FOR J:=1 TO k DO - IF M[I,J]=1 THEN WRITE(J:1); - WRITELN; - SSQ:=SSQ + SSQ_YI - END; - -WRITELN; -WRITELN(' Sum of Squares = ',SSQ:10:2) - -END. - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/FFT.DOC b/software/CPM/CPM22_MTPUG_10/FFT.DOC deleted file mode 100644 index dd00517..0000000 --- a/software/CPM/CPM22_MTPUG_10/FFT.DOC +++ /dev/null @@ -1,135 +0,0 @@ - - - The Pascal programs PASFFT1.SRC to - PASFFT4.SRC are programs which use several - different techniques to calculate the Fast Fourier - Transform. These techniques are taken directly from - the book: - - 'Introduction to Digital Filtering' by - R.E Bogner and A.G Constantinides, Wiley, 1975 - - This book is one of the better references to - the FFT. The heart of the programs given here is - the procedure, 'easy', which is a direct translation - of the FORTRAN subroutines given by the authors. - They actually give two versions and I wrote another - two in the hope that they might prove to be faster. - - These were originally written on an Apple II - using their version of UCSD Pascal. This code - represents a minimum change version which runs on - Pascal MT+. - - There are 4 programs each of which contains - the procedure 'easy' which does the FFT. The - various implementations differ only in the way in - which the cosine and sine terms are derived. - - PASFFT2 is the most straight forward and uses - the calculated values of sine and cosine using the - 'cos' and 'sin' functions. This version is the - slowest. - - PASFFT1 is an improved ( from the speed point - of view ) version in which the incremental values - of the sine and cosine are derived from the - equation for the sum of cosines and sines. Since - the transcendental functions are not used as - frequently, the procedure executes considerably - faster. - - PASFFT3 is a version in which a table of - cosines is first precalulated and passed to the - procedure 'easy'. Then the values used are first - just looked up and then incremental values are - calculated as in PASFFT1. - - PASFFT4 is similar except that only the - lookup table is used - there is no 'incremental' - calculation. If table lookup is done very - efficiently, this version probably ought to be the - fastest. - - I have tried all the versions shown using - both the AMD9511 floating point chip and just using - the 'normal' MT+ TRANCEND and FPREALS relocatable - modules. - - The following table shows the results of - these tests on a 5 MHz Z80 machine using the $Z - - - 1 - - - - - - - - - option during compilation. The times shown are in - seconds and are the average of two runs of the - program. The probable accuracy is not much better - than about a quarter of a second. NOTE - these are - the times for procedure 'easy' ONLY. - - - --------------------------------------------------- - - Procedure | AMD 9511 | without | Comment - ___________________________________________________ - - PASFFT1 | 7.6 | 11.3 | just passes - _____________________________________ the array - - PASFFT2 | 18.8 | 72.1 | - ___________________________________________________ - - PASFFT3 | 8.2 | 11.4 | passes the - _____________________________________ array and a - precalcul- - PASFFT4 | 7.4 | 10.6 | ated cosine - table - --------------------------------------------------- - - - - My general conclusion is that PASFFT1 is the - easiest to use ( you don't have to precalculate the - table and hence use the memory space ). The speed - penalties for it compared to PASFFT4 are negligible - anyway. - - The AMD9511 floating point chip doesn't - produce an appreciable increase in speed with - PASFFT1 since there are only simple multiplications - being used. It's great advantage is shown in the - PASFFT2 test where the transcendental functions are - used frequently. - - Finally, I hope its obvious that the - procedure 'easy' can be easily changed to handle - any ( limited by memory size ) size array by re- - defining the data type 'data'. - - - - - - - - - - - - - - 2 - - - - - - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/FFTKF.DOC b/software/CPM/CPM22_MTPUG_10/FFTKF.DOC deleted file mode 100644 index 5dd0e70..0000000 --- a/software/CPM/CPM22_MTPUG_10/FFTKF.DOC +++ /dev/null @@ -1,48 +0,0 @@ - - - FFT.PAS is an implementation of the radix-2, fast Fourier trans- -form algorithm with decimation in time (Cooley-Tukey method). This -program is essentially the same as that found in J.W. Cooper, "Intro- -duction to Pascal for Scientists," (Wiley:1981) pp. 211-216. I do -not particularly recommend this book in general, but the FFT program -is solid and in the author's area of expertise. Also, variable names -and program structure follow closely to the discussion in the text. -There were, however, several blunders in Cooper's post-processing pro- -cedure which I have corrected. Furthermore, I incorporated more effi- -cient code in a number of places (for example, the required sines and -cosines are computed recursively using only the SQRT function). - - By rearranging the procedure calls in the main body, you can -perform other calculations. Some common usages are: - - - Forward Transform -----> FFT(FORWRD); - Complex Vector - - Inverse Transform -----> FFT(INVERSE); - Complex Vector - - Inverse Transform -----> POST_PROCESS(INVERSE); - Real Vector FFT(INVERSE); - SHUFFLE(INVERSE); - - - There are many methods of computing discrete Fourier transforms -in order (N log N) floating point operations. The differences can -usually be attributed to various ways the data are accessed or to -the optimal computational structure as dictated by the available -hardware. FFT.PAS represents an efficient, but relatively straight- -forward approach well suited to microprocessors. - - For those interested in studying FFT's further, I suggest: - - - J.D. Lipson, "Elements of Algebra and Algebraic - Computing," (Addison-Wesley:1981). - - H. Nussbaumer, "Fast Fourier Transform and Convolution - Algorithms," (Springer-Verlag:1982). - - E.O. Brigham, "The Fast Fourier Transform," (Prentice- - Hall:1974). - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/FFTKF.IN b/software/CPM/CPM22_MTPUG_10/FFTKF.IN deleted file mode 100644 index 227313b..0000000 Binary files a/software/CPM/CPM22_MTPUG_10/FFTKF.IN and /dev/null differ diff --git a/software/CPM/CPM22_MTPUG_10/FFTKF.OUT b/software/CPM/CPM22_MTPUG_10/FFTKF.OUT deleted file mode 100644 index 315601d..0000000 Binary files a/software/CPM/CPM22_MTPUG_10/FFTKF.OUT and /dev/null differ diff --git a/software/CPM/CPM22_MTPUG_10/FFTKF.PAS b/software/CPM/CPM22_MTPUG_10/FFTKF.PAS deleted file mode 100644 index f62d5b7..0000000 --- a/software/CPM/CPM22_MTPUG_10/FFTKF.PAS +++ /dev/null @@ -1,64 +0,0 @@ - - - -PROGRAM FOURIER(INPUT,OUTPUT,INFILE,OUTFILE); -{Real FFT with single sine look-up per pass} - -CONST ARRAY_SIZE = 2048; - pi = 3.141592654; - -TYPE TRANSFORM_TYPE = (FORWRD,INVERSE); - XARRAY = ARRAY[1..ARRAY_SIZE] OF REAL; - -VAR I : INTEGER; - N : INTEGER; - NU : INTEGER; - N_2 : INTEGER; - N_4 : INTEGER; - DUMMY : INTEGER; - IORESULT : INTEGER; - INFILE : TEXT; - OUTFILE : TEXT; - X : XARRAY; - MODE : TRANSFORM_TYPE; - - {*** found in FFTLIB.ERL ***} -EXTERNAL PROCEDURE DEBUG; - -EXTERNAL FUNCTION LOG2( FACTOR : INTEGER) : INTEGER; - -EXTERNAL PROCEDURE POST_PROCESS(MODE : TRANSFORM_TYPE); - -EXTERNAL PROCEDURE SHUFFLE(MODE : TRANSFORM_TYPE); - -EXTERNAL PROCEDURE FFT(MODE : TRANSFORM_TYPE); - - -BEGIN -OPEN(INFILE,'FFT.IN',IORESULT); -RESET(INFILE); - -write('Input n: '); readln(n); -for i:=1 to n do - read(infile,x[i]); - - -writeln('Initial'); writeln; -debug; - -N_2:=N DIV 2; {Definition of N_2 = # of complex data points, n/2} -N_4:=N_2 DIV 2; -NU:=LOG2(N_2); - -SHUFFLE(FORWRD); -writeln('Shuffle'); writeln; -debug; - -FFT(FORWRD); -writeln('FFT'); writeln; -debug; - -POST_PROCESS(FORWRD); -writeln('Post'); writeln; -debug -END. diff --git a/software/CPM/CPM22_MTPUG_10/FFTLIB.PAS b/software/CPM/CPM22_MTPUG_10/FFTLIB.PAS deleted file mode 100644 index 17d4145..0000000 --- a/software/CPM/CPM22_MTPUG_10/FFTLIB.PAS +++ /dev/null @@ -1,360 +0,0 @@ - - - -MODULE FFTLIB; -{Library of routines used in the computation of discrete} -{Fourier transforms } - -{$M DEBUG } -{$M LOG2 } -{$M POST_PROCESS } -{$M SHUFFLE } -{$M FFT } - -{$M *} - -CONST ARRAY_SIZE = 2048; - pi = 3.141592654; - -TYPE TRANSFORM_TYPE = (FORWRD,INVERSE); - XARRAY = ARRAY[1..ARRAY_SIZE] OF REAL; - -VAR N : EXTERNAL INTEGER; - NU : EXTERNAL INTEGER; - N_2 : EXTERNAL INTEGER; - N_4 : EXTERNAL INTEGER; - X : EXTERNAL XARRAY; - MODE : EXTERNAL TRANSFORM_TYPE; - - -PROCEDURE DEBUG; - VAR I : INTEGER; - BEGIN - WRITELN; - FOR I:=1 TO N DO WRITELN('X[',I:2,']=',X[I]:8:2); - WRITELN; WRITELN - END; - - - -FUNCTION LOG2( FACTOR : INTEGER) : INTEGER; - VAR LOG : INTEGER; - BEGIN - LOG:=0; - WHILE FACTOR>=2 DO - BEGIN - LOG:=LOG+1; - FACTOR:=FACTOR DIV 2 - END; - LOG2:=LOG - END; - - - - -PROCEDURE POST_PROCESS(MODE : TRANSFORM_TYPE); - { Post-processing for forward real transforms } - { Pre-processing for inverse real transform } - { } - { When using POST, the method of storage follows the } - { following pattern: } - { } - { } - { } - { Action Locations of array X[i] } - { -------------- -------------------------- } - { } - { Post-Processing first (N/2+1) are real } - { (Forward Real FT) next (N/2-1) are imaginary } - { } - { } - { Pre-Processing first (N/2) are real } - { (Inverse Real FT) next (N/2) are imaginary } - { } - { } - { This storage scheme is necessary to insure that the } - { composition of the inverse FT with a forward FT re- } - { turns the original input array. If one desires the } - { results of the forward FT, then output a zero instead} - { of X[N/2+1]; this is because the imaginary component } - { of the first Fourier coefficient is always zero for } - { real data. With the zero in place, however, the } - { array is not invertible (i.e., the N/2+1 real compo- } - { nent is necessary for the inverse computation). } - -VAR L,M,I : INTEGER; - IPN2 : INTEGER; - MPN2 : INTEGER; - ARG : REAL; - DELTA_ARG : REAL; - IPCOS_RMSIN : REAL; - IPSIN_RMCOS : REAL; - IC0,IC1 : REAL; - IS0,IS1 : REAL; - RP,RM : REAL; - IP,IM : REAL; - - BEGIN - ARG:=pi/N_2; - IC0:=COS(ARG); - IS0:=SIN(ARG); - IC1:=1.0; - IS1:=0.0; - - CASE MODE OF - - FORWRD : BEGIN - RP := X[1] + X[N_2+1]; - X[N_2+1]:= X[1] - X[N_2+1] - END; - - INVERSE : BEGIN - IS0:=-IS0; - IC1:=-1.0; - RP :=( X[1] + X[N_2+1] )/2; - X[N_2+1]:=( X[1] - X[N_2+1] )/2 - END - END; - - X[1]:=RP; - X[N_2+N_4+1]:=-X[N_2+N_4+1]; - - FOR I:=2 TO N_4 DO - BEGIN - M:=N_2 - I + 2; - IPN2:=I + N_2; - MPN2:=M + N_2; - - RP :=IC1*IC0 - IS1*IS0; {compute sine and cosine for next} - IS1:=IC1*IS0 + IS1*IC0; {angles using de Moivre's Theorem} - IC1:=RP; - - RP:=( X[ I ] + X[ M ] )/2; - RM:=( X[ I ] - X[ M ] )/2; - - IP:=( X[IPN2] + X[MPN2] )/2; - IM:=( X[IPN2] - X[MPN2] )/2; - - IPCOS_RMSIN:=IP*IC1 - RM*IS1; { IP*COS(Y) - RM*SIN(Y) } - IPSIN_RMCOS:=IP*IS1 + RM*IC1; { IP*SIN(Y) + RM*COS(Y) } - - X[ I ]:= RP + IPCOS_RMSIN; - X[ M ]:= RP - IPCOS_RMSIN; - - X[IPN2]:= IM - IPSIN_RMCOS; - X[MPN2]:=-IM - IPSIN_RMCOS; - - END - END; - - - -PROCEDURE SHUFFLE(MODE : TRANSFORM_TYPE); - {Shuffle points from alternate real-imaginary to 1st-half real,} - {2nd-half imaginary if MODE=FORWRD. The procedure is reversed } - {if MODE=INVERSE. } - - VAR I,J,K,L : INTEGER; - IPCM1 : INTEGER; - CELL_DISTANCE : INTEGER; - CELL_COUNT : INTEGER; - POINT_COUNT : INTEGER; - XTEMP : REAL; - - BEGIN - {choose whether to start with large cells and go down or start} - {with small cells and increase. } - - CASE MODE OF - - FORWRD : BEGIN - CELL_DISTANCE:=N DIV 2; - CELL_COUNT:=1; - POINT_COUNT:=N DIV 4 - END; - - INVERSE : BEGIN - CELL_DISTANCE:=2; - CELL_COUNT:=N DIV 4; - POINT_COUNT:=1 - END - END; - - FOR L:=1 TO NU DO - BEGIN - I:=2; - FOR J:=1 TO CELL_COUNT DO - BEGIN - FOR K:=1 TO POINT_COUNT DO - BEGIN - IPCM1:=I + CELL_DISTANCE - 1; - XTEMP:=X[I]; - X[I]:=X[IPCM1]; - X[IPCM1]:=XTEMP; - I:=I+2 - END; - I:=I + CELL_DISTANCE - END; - - CASE MODE OF - - FORWRD : BEGIN - CELL_DISTANCE:=CELL_DISTANCE DIV 2; - CELL_COUNT:=CELL_COUNT*2; - POINT_COUNT:=POINT_COUNT DIV 2 - END; - - INVERSE : BEGIN - CELL_DISTANCE:=CELL_DISTANCE*2; - CELL_COUNT:=CELL_COUNT DIV 2; - POINT_COUNT:=POINT_COUNT*2 - END - END - END - END; - - - -PROCEDURE FFT(MODE : TRANSFORM_TYPE); - {FFT algorithm--operates on n/2 complex data points.} - {The i-th complex data value is assumed to be stored} - {in the array X[1..n] such that: } - { } - { X[ i ] = real component } - { X[ i + n/2 ] = imaginary component } - { } - {FFT returns the complex result in the same fashion.} - -VAR CELL_COUNT : INTEGER; - CELL_DISTANCE : INTEGER; - POINT_COUNT : INTEGER; - IPN2,JPN2,KPN2 : INTEGER; - I,J,K,L : INTEGER; - I2 : INTEGER; - IMAX : INTEGER; - INDEX : INTEGER; - COS0,SIN0 : REAL; - COSY,SINY : REAL; - R2COS_I2SIN : REAL; - I2COS_R2SIN : REAL; - TEMP_R : REAL; - TEMP_I : REAL; - XTEMP : REAL; - K1 : REAL; - - FUNCTION BIT_REVERSAL( J,NU : INTEGER) : INTEGER; - {bit invert the number J by NU bits} - VAR I,IB : INTEGER; - BEGIN - IB:=J MOD 2; - FOR I:=2 TO NU DO - BEGIN - J:=J DIV 2; - IB:=IB*2 + J MOD 2 - END; - BIT_REVERSAL:=IB - END; - - BEGIN - {shuffle the complex data (n/2 entries) into bit-inverted order} - FOR I:=2 TO N_2-1 DO - BEGIN - K:=BIT_REVERSAL(I-1,NU) + 1; - IF I>K THEN {swap the real and imaginary components} - BEGIN - IPN2:=I + N_2; {imaginary} - KPN2:=K + N_2; { indices } - - TEMP_R:=X[ K ]; - TEMP_I:=X[KPN2]; - - X[ K ]:=X[ I ]; - X[KPN2]:=X[IPN2]; - - X[ I ]:=TEMP_R; - X[IPN2]:=TEMP_I - END - END; - - - {do first pass specially, since it has no multiplication} - I:=1; - FOR J:=1 TO N_4 DO - BEGIN - K:=I+1; - IPN2:=I+N_2; - KPN2:=IPN2+1; - K1:= X[ I ] + X[ K ]; - X[ K ]:=X[ I ] - X[ K ]; - X[ I ]:=K1; - K1:= X[IPN2] + X[KPN2]; - X[KPN2]:=X[IPN2] - X[KPN2]; - X[IPN2]:=K1; - I:=I+2 - END; - - {set up for 2nd pass ARG = pi/2} - COS0:=0.0; - IF MODE=FORWRD THEN SIN0:= 1.0 - ELSE SIN0:=-1.0; - CELL_COUNT:=N_2 DIV 4; - POINT_COUNT:=2; - CELL_DISTANCE:=4; - - {each pass after the 1st starts here} - FOR I2:=2 TO NU DO - BEGIN - COSY:=1.0; - SINY:=0.0; - FOR INDEX:=1 TO POINT_COUNT DO - BEGIN - I:=INDEX; - - FOR L:=1 TO CELL_COUNT DO - BEGIN - J:=I + POINT_COUNT; - IPN2:=I + N_2; - JPN2:=J + N_2; - - IF INDEX=1 THEN {no sine or cosine terms} - BEGIN - R2COS_I2SIN:=X[ J ]; - I2COS_R2SIN:=X[JPN2] - END - ELSE - BEGIN - R2COS_I2SIN:=X[ J ]*COSY + X[JPN2]*SINY; - I2COS_R2SIN:=X[JPN2]*COSY - X[ J ]*SINY - END; - - X[ J ]:=X[ I ] - R2COS_I2SIN; {Note: these assignments} - X[ I ]:=X[ I ] + R2COS_I2SIN; {must be in this order if} - X[JPN2]:=X[IPN2] - I2COS_R2SIN; {temporary variables are } - X[IPN2]:=X[IPN2] + I2COS_R2SIN; {to be avoided. } - I:=I + CELL_DISTANCE - END; - - K1 :=COSY*COS0 - SINY*SIN0; {using de Moivre's Theorem} - SINY:=SINY*COS0 + COSY*SIN0; - COSY:=K1; - - END; - - {pass done--change cell distance and number of cells} - CELL_COUNT:=CELL_COUNT DIV 2; - POINT_COUNT:=POINT_COUNT*2; - CELL_DISTANCE:=CELL_DISTANCE*2; - - SIN0:=SQRT((1.0 - COS0)/2.0); {use half-angle formulas to compute} - COS0:=SQRT((1.0 + COS0)/2.0); {sin & cos of ARG:=ARG/2 } - - IF MODE=INVERSE THEN SIN0:= -SIN0 - END; - - IF MODE=INVERSE THEN - FOR I:=1 TO N DO X[I]:=X[I]/N_2 - END; - - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/LAB.PAS b/software/CPM/CPM22_MTPUG_10/LAB.PAS deleted file mode 100644 index e5f0499..0000000 --- a/software/CPM/CPM22_MTPUG_10/LAB.PAS +++ /dev/null @@ -1,387 +0,0 @@ - - - -MODULE LAB; -{$M AD1_CONVERT } -{$M AD2_CONVERT } -{$M DA_CONVERT } -{$M TIMER } -{$M TIME_OUT } -{$M READ_CLOCK } -{$M PRINT_TIME } -{$M CONTROL } -{$M HYDROGEN } -{$M OXYGEN } -{$M AIR } -{$M STRIP_CHART } -{$M LOGIN_DISK } - -{$M *} - -TYPE AD1_CHAN = 0..7; - AD2_CHAN = 0..15; - DA_CHAN = 0..3; - NIBBLE = 0..15; - DEVICE_CODE = RECORD - HOUSE : 'A'..'P'; - UNIT : 0..15; - END; - CONTROL_ACTION = (ON,OFF,ALL_ON,ALL_OFF,BRIGHTEN,DIM,CLR_STOP); - - TIME_OF_DAY = RECORD - YEAR : 1982..2000; - MONTH : 1..12; - DAY : 1..31; - HOUR : 0..23; - MINUTE : 0..59; - SECOND : 0..59; - END; - - FILE_NAME = STRING; - - - -EXTERNAL FUNCTION @BDOS(FUNC,PARM : INTEGER) : INTEGER; - -FUNCTION AD1_CONVERT(CHANNEL : AD1_CHAN; N : NIBBLE) : INTEGER; - {Access the CDC 12-bit A/D converter board set at +/-5 volts} - CONST AD1_PORT = $A0; - MASK = $20; - BEGIN - {GAIN = 2**N. However we must adjust N so that the proper gain} - {switching is inputted to the programmable gain amplifier. See} - {p. 7 of the 3606 IC manual. } - CASE N OF - 0, 1, 2 : N:=N; - 3, 4 : N:=N+2; - 5, 6, 7 : N:=N+3; - 8, 9, 10 : N:=N+4; - ELSE BEGIN - WRITELN('Gain of 1024 (2**10) is a maximum bound.'); - N:=14 - END - END; - - OUT[ AD1_PORT ]:=N; {input gain switch} - OUT[(AD1_PORT+1)]:=CHANNEL; - OUT[(AD1_PORT+2)]:=0; {start A/D conversion} - - WAIT(AD1_PORT,MASK,TRUE); {wait until the 5th bit goes low} - - AD1_CONVERT:=SWAP(INP[(AD1_PORT+3)]) ! INP[(AD1_PORT+2)] - END; - - - -FUNCTION AD2_CONVERT(CHANNEL : AD2_CHAN) : INTEGER; - {Access the Techmar 12-bit A/D converter board set at +/-10 volts} - CONST AD2_PORT = $B0; - MASK = $01; - BEGIN - - OUT[ AD2_PORT ]:=CHANNEL; - OUT[(AD2_PORT+1)]:=0; {start A/D conversion} - - WAIT(AD2_PORT+1,MASK,FALSE); {wait until the LSB bit goes high} - - AD2_CONVERT:=SWAP(INP[(AD2_PORT+3)]) ! INP[(AD2_PORT+2)] - END; - - - -PROCEDURE DA_CONVERT(CHANNEL : DA_CHAN; DA_OUTPUT : INTEGER); - {Access the CDC 12-bit D/A converter board set at +/-10 volts} - CONST DA_PORT = $C0; - - VAR DAC_PORT : BYTE; - - BEGIN - IF ( CHANNEL>3 ) OR ( CHANNEL<0 ) THEN - WRITELN('D/A CHANNEL',CHANNEL,' does not exist.'); - DAC_PORT:=DA_PORT + 2*CHANNEL; - OUT[(DAC_PORT )]:=HI(DA_OUTPUT); - OUT[(DAC_PORT + 1)]:=LO(DA_OUTPUT) - END; - - - -PROCEDURE TIMER(SECONDS : INTEGER); - {Access the SciTronics RTC-100 Real Time Clock board} - {and wait a specified number of seconds. } - - VAR I : INTEGER; - NOW : TIME_OF_DAY; - OLD_SEC : INTEGER; - - BEGIN - READ_CLOCK(NOW); - FOR I:=SECONDS DOWNTO 1 DO - BEGIN - OLD_SEC:=NOW.SECOND; - REPEAT - READ_CLOCK(NOW) - UNTIL NOW.SECOND<>OLD_SEC - END - END; - - -PROCEDURE TIME_OUT(HOURS,MINUTES,SECONDS : INTEGER); - {Access the RTC-100 Real Time Clock board and wait a specified} - {block of time (accurate only to the nearest second). } - - CONST RTC0 = $18; - RTC1 = $19; - RTC2 = $1A; - RTC3 = $1B; - - VAR I : INTEGER; - NOW : TIME_OF_DAY; - TARGET : TIME_OF_DAY; - SUM_SECONDS : INTEGER; - SUM_MINUTES : INTEGER; - SUM_HOURS : INTEGER; - MINUTE_CARRY : INTEGER; - HOUR_CARRY : INTEGER; - READY : BOOLEAN; - - BEGIN - READ_CLOCK(NOW); - READY:=FALSE; - - SUM_SECONDS := NOW.SECOND + SECONDS; - - MINUTE_CARRY := SUM_SECONDS DIV 60; - SUM_MINUTES := NOW.MINUTE + MINUTES + MINUTE_CARRY; - - HOUR_CARRY := SUM_MINUTES DIV 60; - SUM_HOURS := NOW.HOUR + HOURS + HOUR_CARRY; - - TARGET.SECOND:= SUM_SECONDS MOD 60; - TARGET.MINUTE:= SUM_MINUTES MOD 60; - TARGET.HOUR := SUM_HOURS MOD 24; - - REPEAT - READ_CLOCK(NOW); - IF NOW.HOUR=TARGET.HOUR THEN - IF NOW.MINUTE=TARGET.MINUTE THEN - READY:=TARGET.SECOND=NOW.SECOND - UNTIL READY - END; - - - -PROCEDURE READ_CLOCK(VAR NOW : TIME_OF_DAY); - {Read the RTC-100 Real Time Clock} - VAR TIME : ARRAY[0..12] OF BYTE; - - PROCEDURE RTC_READ; - CONST RTC0 = $18; - RTC1 = $19; - RTC2 = $1A; - RTC3 = $1B; - - VAR I : INTEGER; - - BEGIN - OUT[RTC1]:=$F0; - OUT[RTC0]:=$0F; - OUT[RTC3]:=$FC; - OUT[RTC1]:=$F4; - - FOR I:=0 TO 12 DO - BEGIN - OUT[RTC0]:=I; - TIME[I]:=SHR( INP[RTC0], 4) - END; - - OUT[RTC1]:=$F8; - OUT[RTC0]:=$0F; - OUT[RTC3]:=$F8; - OUT[RTC1]:=$FC; - OUT[RTC0]:=$0F - END; - - BEGIN - RTC_READ; - WITH NOW DO - BEGIN - YEAR:=TIME[12]*10 + TIME[11] + 1900; - MONTH:=(TIME[10] & 3)*10 + TIME[9]; - DAY:=TIME[8]*10 + TIME[7]; - HOUR:=(TIME[5] & 3)*10 + TIME[4]; - MINUTE:=TIME[3]*10 + TIME[2]; - SECOND:=TIME[1]*10 + TIME[0] - END - END; - - - - -PROCEDURE PRINT_TIME(F_NAME : FILE_NAME); - VAR TIME : TIME_OF_DAY; - - BEGIN - READ_CLOCK(TIME); - WITH TIME DO - IF F_NAME='SCREEN' THEN - WRITE('Time is: ',HOUR:2,':',MINUTE:2,':',SECOND:2) - ELSE WRITE(F_NAME, HOUR:2,':',MINUTE:2,':',SECOND:2) - END; - - - - -PROCEDURE CONTROL(TRIAC : DEVICE_CODE; COMMAND : CONTROL_ACTION); - {Works in conjunction with the SciTronics Remote Controller } - {board. This procedure accesses and performs the appropriate} - {command for a BSR control module. It takes approximately } - {3 seconds to execute. } - - CONST RC_PORT = $40; - MASK = $80; - - VAR STR : STRING; - I : INTEGER; - - BEGIN - WITH TRIAC DO - BEGIN - STR:='JBHPLDFNIAGOKCEM'; - {output the device code --> see p.8 of RC-100 manual} - OUT[RC_PORT]:=SHL(UNIT,4)!( POS(HOUSE,STR) - 1 ); - CASE COMMAND OF - - ON : OUT[(RC_PORT + 1)]:=$93; - - OFF : OUT[(RC_PORT + 1)]:=$9B; - - ALL_ON : OUT[(RC_PORT + 1)]:=$95; - - ALL_OFF : OUT[(RC_PORT + 1)]:=$9D; - - BRIGHTEN : OUT[(RC_PORT + 1)]:=$C7; - - DIM : OUT[(RC_PORT + 1)]:=$CF; - - CLR_STOP : OUT[(RC_PORT + 1)]:=$A1 - - END; - - - FOR I:=1 TO 100 DO; {a short delay before reading status} - - {wait until controller has stopped transmitting} - WAIT(RC_PORT,MASK,TRUE) - END - END; - - - -FUNCTION KEYPRESSED : BOOLEAN; - BEGIN - KEYPRESSED:=( @BDOS(11,0) <> 0 ) - END; - - - -PROCEDURE HYDROGEN(FLOWRATE : INTEGER); - {This procedure activates the appropriate solenoid valve to } - {the gas regulator and inputs a voltage to the flow controller} - {which will correspond to the given flowrate requested. } - - CONST H2_FLOW_CONTROLLER = 3; {D/A channel 3} - MAX_FLOW = 300; {cm**3/minute} - MIN_FLOW = 13; - - VAR H2_VALVE : DEVICE_CODE; - FLOW_I : INTEGER; - BEGIN - H2_VALVE.HOUSE:='P'; {If using BSR appliance} - H2_VALVE.UNIT:=2; {modules, dial in "P3" } - - IF FLOWRATE<=0 THEN - CONTROL(H2_VALVE,OFF) - ELSE IF FLOWRATE<=MAX_FLOW THEN - BEGIN - CONTROL(H2_VALVE,ON); - {Generate a positve DAC voltage <= 5.0 volts for proper flowrate} - FLOW_I:=ROUND(1024.0*FLOWRATE/MAX_FLOW); - DA_CONVERT(H2_FLOW_CONTROLLER,FLOW_I) - END - ELSE WRITELN('Error *** Hydrogen flowrate exceeds controller max.') - - END; - - - -PROCEDURE OXYGEN(FLOWRATE : INTEGER); - {This procedure activates the appropriate solenoid valve to } - {the gas regulator and inputs a voltage to the flow controller} - {which will correspond to the given flowrate requested. } - - CONST O2_FLOW_CONTROLLER = 2; {D/A channel 2} - MAX_FLOW = 2000; {cm**3/minute} - MIN_FLOW = 0; - - VAR O2_VALVE : DEVICE_CODE; - FLOW_I : INTEGER; - BEGIN - O2_VALVE.HOUSE:='P'; {If using BSR appliance} - O2_VALVE.UNIT:=3; {modules, dial in "P4" } - - IF FLOWRATE<=0 THEN - CONTROL(O2_VALVE,OFF) - ELSE IF FLOWRATE<=MAX_FLOW THEN - BEGIN - CONTROL(O2_VALVE,ON); - {Generate a positve DAC voltage <= 5.0 volts for proper flowrate} - FLOW_I:=ROUND(1024.0*FLOWRATE/MAX_FLOW); - DA_CONVERT(O2_FLOW_CONTROLLER,FLOW_I) - END - ELSE WRITELN('Error *** Oxygen flowrate exceeds controller max.') - - END; - - -PROCEDURE AIR(FLOWRATE : INTEGER); - {This is used when a 21% oxygen/79% nitrogen mixture flows} - {through the flow controller calibrated for pure oxygen. } - BEGIN - OXYGEN( ROUND(1.00*FLOWRATE) ) {Correction factor given} - END; {in Tylan manual, p. 19 } - - - -PROCEDURE STRIP_CHART(ACTION : CONTROL_ACTION); - {This procedure turns the Houston Instrument strip chart recorder} - {on or off. No pen control is needed since it automatically goes} - {up when power is curtailed. } - - VAR CHART : DEVICE_CODE; - BEGIN - CHART.HOUSE:='P'; {If using BSR appliance} - CHART.UNIT:=4; {modules, dial in "P5" } - - CASE ACTION OF - ON,OFF : CONTROL(CHART,ACTION); - ELSE BEGIN - WRITELN('***> Control action requested is not available'); - WRITELN(' for the strip chart recorder.') - END - END - END; - - -PROCEDURE LOGIN_DISK(DISK : CHAR); - {logs in the given floppy disk drive (A,B,C,...)} - CONST DISK_DRIVE_LOGIN = 14; - - VAR DUMMY : INTEGER; - BEGIN - DUMMY:=@BDOS( DISK_DRIVE_LOGIN, ORD(DISK)-ORD('A') ) - END; - - - -MODEND. - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PASFFT1.SRC b/software/CPM/CPM22_MTPUG_10/PASFFT1.SRC deleted file mode 100644 index 2ec40bc..0000000 Binary files a/software/CPM/CPM22_MTPUG_10/PASFFT1.SRC and /dev/null differ diff --git a/software/CPM/CPM22_MTPUG_10/PASFFT2.SRC b/software/CPM/CPM22_MTPUG_10/PASFFT2.SRC deleted file mode 100644 index 5806592..0000000 Binary files a/software/CPM/CPM22_MTPUG_10/PASFFT2.SRC and /dev/null differ diff --git a/software/CPM/CPM22_MTPUG_10/PASFFT3.SRC b/software/CPM/CPM22_MTPUG_10/PASFFT3.SRC deleted file mode 100644 index a780ff4..0000000 Binary files a/software/CPM/CPM22_MTPUG_10/PASFFT3.SRC and /dev/null differ diff --git a/software/CPM/CPM22_MTPUG_10/PASFFT4.SRC b/software/CPM/CPM22_MTPUG_10/PASFFT4.SRC deleted file mode 100644 index 17b5ebc..0000000 Binary files a/software/CPM/CPM22_MTPUG_10/PASFFT4.SRC and /dev/null differ diff --git a/software/CPM/CPM22_MTPUG_10/PASMAT.CMD b/software/CPM/CPM22_MTPUG_10/PASMAT.CMD deleted file mode 100644 index 9457705..0000000 --- a/software/CPM/CPM22_MTPUG_10/PASMAT.CMD +++ /dev/null @@ -1,4 +0,0 @@ -B:PASMAT=B:PASMAT -B:PMINIT,B:PMCOMENT,B:PMPARSE,B:PMFILEIO -B:CPMNAME,B:RNB,B:PASLIB/S/E/W - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PASMAT.KMD b/software/CPM/CPM22_MTPUG_10/PASMAT.KMD deleted file mode 100644 index 56497c5..0000000 --- a/software/CPM/CPM22_MTPUG_10/PASMAT.KMD +++ /dev/null @@ -1,2 +0,0 @@ -PASMAT,PMINIT,PMCOMENT,PMPARSE,PMFILEIO,CPMNAME,PASLIB/S - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PASMAT.PAS b/software/CPM/CPM22_MTPUG_10/PASMAT.PAS deleted file mode 100644 index e280585..0000000 --- a/software/CPM/CPM22_MTPUG_10/PASMAT.PAS +++ /dev/null @@ -1,955 +0,0 @@ - {*-----------------------------------* - | PASMAT: PAScal source code forMAT | - *-----------------------------------*} -{$K0} {$K7} {$K12} {$K13} {$K14} {$K15} -(* {$Q2 for parser recursion} *) -program pasmat; -{$p---------------------* - | Labels and Constants | - *----------------------*} - - const - titleheader = 'Pasmat 3.15, revised 22 Mar 83'; - maxlinelen = 132; {max output line length} - bufsize = 134; {output buffer size, > maxlinelen} - maxwordlen = 9; {reserved words char size} - noreswords = 53; {number of reserved words} - defaultoutline = 72; {default output line length} - defaulttabspaces = 2; {logical indentation increments} - defaultcomentspaces = 1; {spacing before and after comments} - tab = 9; {ord of tab character} - tabinterval = 8; {standard tab interval for CP/M} - stacksize = 256; {extra hardware stack size} - ibufsize = 2047; {size of input buffer - 1} -{$p------* - | Types | - *-------*} - - type - symbols = (abslutesy, andsy, arraysy, beginsy, casesy, constsy, - divsy, dosy, downtosy, elsesy, endsy, externsy, filesy, - forsy, forwardsy, funcsy, gotosy, ifsy, insy, intruptsy, - labelsy, modsy, modendsy, modulesy, nilsy, notsy, ofsy, - orsy, othwisesy, packedsy, procsy, programsy, recordsy, - repeatsy, setsy, stringsy, thensy, tosy, typesy, untilsy, - varsy, whilesy, withsy, plus, minus, mult, divide, - becomes, period, comma, semicolon, colon, equal, - notequal, lessthan, lessequal, greatequal, greatthan, - pointer, subrange, apostrophy, openparen, closeparen, - openbrack, closebrack, identifier, number, stringcon, - coment, textend, dummysy); - {basic symbol enumeration} - setofsyms = set of symbols; {set ops on basic symbols} - wordtype = packed array [1..maxwordlen] of char; - {reserved} - lentabletype = {index into reserved word table by length} - record - lowindex, hiindex: 1..noreswords; - end; - lineindex = 0..maxlinelen; - actions = (graphic, spaces, beginline); - bufferindex = 0..bufsize; {output buffer index} - charbuffer = array [bufferindex] of - record - case actionis: actions of - spaces, beginline: - (spacing: lineindex); - graphic: - (character: char) - end; - collog = - record - logchar: integer; {charcount at time of log} - logcol: lineindex; {writecol at time of log} - logline: integer; {currentline at time of log} - end; - abortkind = (syntax, nesting, comformat); {error types} - stringp = ^string; -{$p----------* - | Variables | - *-----------*} - - var - {CP/M interface control variables} - @sfp: external integer; {initial stack pointer} - strptr: stringp; - clinearg: string[127]; - - {Structured Constants} - stdsyms: setofsyms; {symbols valid in standard pascal} - validdirectives: set of char; {valid formatter directives} - spacebefore, spaceafter: setofsyms; {individual symbol spacing} - alphanumerics: setofsyms; {alpha symbols} - resvwrd: array [1..noreswords] of wordtype; {reserved word table} - ressymbol: array [1..noreswords] of symbols; {symbols for resvwrd} - reslen: array [2..maxwordlen] of lentabletype; { length index} - digits, letters: set of char; - uppercase: array [char] of char; - lowercase: array [char] of char; {case conversion tables} - progset, blockbegsys, statset: setofsyms; {syntactic symbol types} - cnstnts: setofsyms; {symbols which can be constants} - headingbegsys: setofsyms; {symbols which begin a block heading} - typebegsys: setofsyms; {type beginning symbols} - exprbegsys: setofsyms; {expression beginning symbols} - relops: setofsyms; {relational operators} - arithops: setofsyms; {arithmetic operators} - - {Formatting variables} - indent: integer; {current number of indentation spaces} - statindent: integer; {indentation for major statement} - writecol: integer; {current output column} - symbolbreak: integer; {break symbol for putsym} - breakcol: integer; {output column for putsym} - lastsym: symbols; {last symbol processed} - symwritten: boolean; {last symbol was written} - indentstate: array [lineindex] of lineindex; - indentlevel: lineindex; {these make a stack of indent levels} - - {comment formatting} - statbreak: integer; {character where line can be broken} - statblanks: boolean; {set if blank was last char} - firstinputline: boolean; {set if first input line} - - {miscellaneous} - outputline: integer; {line numbers for output} - currentline: integer; {line number being written} - inputline: integer; {input line number} - linenumber: integer; - - {Formatting Control Values} - outlinelen: integer; {current output line length} - onehalfline: integer; {significant point upon line} - fiveeighthline: integer; { "} - threefourthline: integer; {"} - tabspaces: integer; {spaces to indent for each level} - continuespaces: integer; {spaces to indent continuation line} - comentspaces: integer; {spaces before statement comment} - statsperline: integer; {statements per line} - - {Flags to direct formatting} - ucreswords: boolean; {convert reserved words to UC} - ucidents: boolean; {convert identifiers to UC} - litcopy: boolean; {copy identifiers and reserved words literally} - portabilitymode: boolean; {eliminate underscores} - formatting: boolean; {do formatting (otherwise, copy)} - newformatting: boolean; {start formatting at end of comment} - bunching: boolean; {bunch statements on one line} - silentmode: boolean; {don't even generate error messages} - - {lexical scanner variables} - symbolfound: boolean; {success from lexical analysis} - newinputline: boolean; {true when no chars as yet on new line} - endfile: boolean; {eof read} - blankline: boolean; {true when blank line is ok to output} - ch: char; {current character for lexical analysis} - doubleperiod: boolean; {set if double period found} - column: integer; {input column for last char input} - sym: symbols; {current basic symbol from lex} - symbol: array [lineindex] of char; {workspace for lex analysis} - symlen: 0..maxlinelen; {index into WINDOW array} - {output character buffering} - unwritten: charbuffer; {unwritten characters} - charcount: integer; {characters written so far} - oldest: bufferindex; {oldest char in buffer} - - {error handling variables} - overflows: 0..maxint; {number of line overflows} - firstoverflow: 0..maxint; {line where first overflow occured} - comoverflows: 0..maxint; {number of comment overflows} - firstcomoverflow: 0..maxint; {line of first comment overflow} - - external function @cmd: stringp; - external procedure initialize; - - {file i/o entry points} - external procedure abort(line: integer; - kind: abortkind); - external procedure comentoverflow; - external procedure finaldata; - external procedure flushbuffer; - external procedure getchar; - external function getfiles: boolean; - external procedure lineoverflow; - external procedure writea(ch: char); - - {comment entry points} - external procedure comentchar; - external procedure commanddirectives; - - {parser entry points} - external procedure doprogram; - external procedure doblock; - external procedure statlist; - -{$p-----------------* - | Output Utilities | - *------------------*} - - - procedure newline(indent: lineindex); - - begin {start a new line and indent it as specified} - {fake a character, then change it} - writea(' '); - with unwritten[oldest] do - begin - actionis := beginline; - spacing := indent; - end; - writecol := indent; - currentline := currentline + 1; - end; {newline} - - - procedure printline(indent: integer); - - begin {print a line for formatting} - if formatting then - begin - if blankline and (currentline > 0) then - newline(0); - newline(indent); - end; - blankline := false; - symbolbreak := 0; - end; {printline} - - - procedure space(n: integer); - - begin {space n characters} - if formatting then - begin - writea(' '); - with unwritten[oldest] do - begin - actionis := spaces; - if n > 0 then - spacing := n - else - spacing := 0; - end; - writecol := writecol + n - 1; - end; - end; {space} - - - procedure flushsymbol; - - var - p: lineindex; {induction var} - - begin {flush any accumulated characters in the buffer} - if not symwritten then - begin - symwritten := true; - newline(writecol); - for p := 1 to symlen do - writea(symbol[p]); - end; - flushbuffer; - newline(column); - end; {flushsymbol} - -{$p--------------------* - | Indentation Control | - *---------------------*} - - - procedure indentplus(delta: integer; - line: integer); - - begin {increment indentation and check for overflow} - if indentlevel > maxlinelen then - abort(line, nesting); - indentlevel := indentlevel + 1; - indentstate[indentlevel] := indent; - indent := indent + delta; - if indent > outlinelen then - indent := outlinelen - else if indent < 0 then - indent := 0; - end; {indentplus} - - - procedure undent; - - begin {reset indent to the last value} - indent := indentstate[indentlevel]; - indentlevel := indentlevel - 1; - end; {undent} - -{$p-------------------------* - | Lexical Scanner, Utility | - *--------------------------*} - {Place characters of current basic symbol on output TARGET line. - Invoke lexical analysis to assemble next basic symbol in WINDOW - and determine type. SYM is set equal to symbol type. Comments - are transparent to the analysis. } - - - procedure symbolput(thischar: char); - - begin {ch to symbol} - symlen := symlen + 1; - symbol[symlen] := thischar; - getchar; - end {symbolput} ; - -{*------------* - | print char | - *------------*} - - - procedure printchar; - - begin {print ASCII chars not belonging to Pascal} - if writecol >= outlinelen then - printline(indent + continuespaces); - if formatting then - writea(ch); - getchar; - end {printchar} ; - -{*-------------* - | scanblanks | - *-------------*} - - - procedure scanblanks; - - begin {scan off blanks in the input} - while ((ch = ' ') or (ch = chr(tab))) and not endfile do - getchar; - end; - -{$p----------------* - | String Constant | - *-----------------*} - - - procedure stringcnstnt; - - var - stringend: boolean; - - begin {character string to symbol} - newinputline := false; - symbolfound := true; - sym := stringcon; - stringend := false; - repeat - symbolput(ch); - if ch = '''' then - begin - symbolput(ch); - stringend := ch <> '''' - end; - until newinputline or stringend; - if not stringend then - abort(linenumber, syntax); - end {stringcnstnt} ; - -{$p------------------------* - | Test for Reserved Words | - *-------------------------*} - - - procedure testresvwrd; - - var - id: wordtype; - index: 1..noreswords; - p: 1..maxwordlen; - - begin {$R- test for reserved word} - sym := identifier; {default} - if (2 <= symlen) and (symlen <= maxwordlen) then - begin {possible length} - for p := 1 to maxwordlen do - if p > symlen then - id[p] := ' ' - else - id[p] := lowercase[symbol[p]]; - with reslen[symlen] do - begin {length index search} - index := lowindex; - while index <= hiindex do - if resvwrd[index] = id then - begin - sym := ressymbol[index]; - exit - end - else - index := index + 1; - end {length index search} ; - end {possible length} - end { $ R + testresvwrd} ; - -{$p----------------------------* - | Identifier or Reserved Word | - *-----------------------------*} - - - procedure alphachar; - - var - p: lineindex; {induction var} - lastunderscore: boolean; {true if last char underscore} - - begin {identifier or reserved word to symbol} - newinputline := false; - symbolfound := true; - lastunderscore := true; - while ch in letters + digits do - begin - if portabilitymode then - begin - if ch = '_' then - begin - lastunderscore := true; - getchar; - end - else if lastunderscore then - begin - lastunderscore := false; - symbolput(uppercase[ch]); - end - else - symbolput(lowercase[ch]) - end - else - symbolput(ch); - end; {while} - testresvwrd; - if sym = identifier then - begin - if not (litcopy or portabilitymode) then - if ucidents then - for p := 1 to symlen do - symbol[p] := uppercase[symbol[p]] - else - for p := 1 to symlen do - symbol[p] := lowercase[symbol[p]] - end - else {reserved word} - begin - if portabilitymode or (not litcopy) then - if ucreswords then - for p := 1 to symlen do - symbol[p] := uppercase[symbol[p]] - else - for p := 1 to symlen do - symbol[p] := lowercase[symbol[p]]; - end; - end {alpha char} ; - -{$p-------* - | Number | - *--------*} - - - procedure hexcnstnt; - - begin {hexadecimal number to symbol} - newinputline := false; - symbolfound := true; - sym := number; - symbolput(ch); { '$' } - while ch in ['0'..'9', 'A'..'F', 'a'..'f'] do - symbolput(uppercase[ch]); - end {hexcnstnt} ; - - - procedure numericchar; - - begin {unsigned number to symbol} - newinputline := false; - symbolfound := true; - sym := number; - if ch = '#' then - symbolput(ch); - while ch in digits do {integer or fractional portion} - symbolput(ch); - if ch = '.' then - begin - symbolput(ch); - if ch = '.' then - begin {actually subrange, must fudge} - symlen := symlen - 1; {erase period} - doubleperiod := true; - end - else - while ch in digits do - symbolput(ch); - end; - if (ch = 'E') or (ch = 'e') then - begin {exponential portion} - symbolput('E'); - if (ch = '+') or (ch = '-') then {sign} - symbolput(ch); - while ch in digits do {characteristic} - symbolput(ch); - end {exponential} - else if ch = '$' then - hexcnstnt; - end {numeric char} ; - -{$p------------------* - | Special Character | - *-------------------*} - - - procedure specialchar; - - begin {operators or delimiters to symbol} - symbolfound := true; {untrue only for comments} - newinputline := false; - case ch of {special symbols} - '+': - begin {plus} - sym := plus; - symbolput(ch); - end; - '-': - begin {minus} - sym := minus; - symbolput(ch); - end; - '*': - begin {multiply} - sym := mult; - symbolput(ch); - end; - '/': - begin {divide} - sym := divide; - symbolput(ch); - end; - '.': - begin {subrange or period} - sym := period; - symbolput(ch); - if doubleperiod then - begin {fudge a subrange} - symbol[2] := '.'; - symlen := 2; - sym := subrange; - end - else if ch = '.' then - begin {subrange} - sym := subrange; - symbolput(ch); - end; {subrange} - doubleperiod := false; - end; - ',': - begin {comma} - sym := comma; - symbolput(ch); - end; - ';': - begin {semicolon} - sym := semicolon; - symbolput(ch); - end; - ':': - begin {becomes, or colon} - sym := colon; - symbolput(ch); - if ch = '=' then - begin {becomes} - sym := becomes; - symbolput(ch); - end - end; - '=': - begin {equals} - sym := equal; - symbolput(ch); - end; - '<': - begin {less than, less equal, not equal} - sym := lessthan; - symbolput(ch); - if ch = '=' then - begin {less than or equal} - sym := lessequal; - symbolput(ch); - end - else if ch = '>' then - begin {not equal} - sym := notequal; - symbolput(ch); - end - end; - '>': - begin {greater equal, greater than} - sym := greatthan; - symbolput(ch); - if ch = '=' then - begin {greater than or equals} - sym := greatequal; - symbolput(ch); - end - end; - '^': - begin {pointer} - sym := pointer; - symbolput('^'); - end; - '''': - stringcnstnt; - ')': - begin {close parenthesis} - sym := closeparen; - symbolput(ch); - end; - '[': - begin {open bracket} - sym := openbrack; - symbolput(ch); - end; - ']': - begin {close bracket} - sym := closebrack; - symbolput(ch); - end; - '~', '?': - begin {bitwise 'not'} - sym := notsy; - symbolput(ch); - end; - '!', '|': - begin {bitwise 'or'} - sym := orsy; - symbolput(ch); - end; - '&': - begin {bitwise 'and'} - sym := andsy; - symbolput(ch); - end; - end {case} ; - end {specialchar} ; - -{$p--------------------------* - | Get Next Symbol (getsym) | - *---------------------------*} - - - procedure getsym; - - begin {extract next basic sym from text} - symlen := 0; - symbolfound := false; - symwritten := false; - repeat - scanblanks; - if endfile then - begin - sym := textend; - symbolfound := true - end - else if ((ord(ch) >= 0) and (ord(ch) <= 31)) or (ord(ch) = - 127) then - getchar - else - case ch of {lexical analysis} - - '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '$', '#': - numericchar; - - 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', - 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', - 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', - 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', - 'w', 'x', 'y', 'z', '@', '_': - alphachar; - - ')', '*', '+', ',', '-', '.', '/', ':', ';', '<', '=', '>', - '[', ']', '^', '''', '~', '?', '!', '|', '&': - specialchar; - - '(', '{': - comentchar; - - '%', '\', '`', '}', '"': - printchar; - end {case} - until symbolfound - end {getsym} ; - -{$p-------* - | Putsym | - *--------*} - - - procedure putsym; - - var - before: lineindex; {spaces before this character} - symindent: integer; {indentation before this symbol} - i: lineindex; {induction var} - overflowerror: boolean; {delays error message till symbol - printed} - - - function spacesbefore(thissym, oldsym: symbols): lineindex; - - var - spbefore: lineindex; - - begin {determine the number of spaces before a symbol} - if ((thissym in alphanumerics) and (oldsym in alphanumerics)) or - (thissym in spacebefore) or (oldsym in spaceafter) then - spbefore := 1 - else - spbefore := 0; - spacesbefore := spbefore; - end; {spacesbefore} - - begin {putsym: put the current symbol to the output, taking care of - spaces before the symbol. This also handles full lines, and - tries to break lines at a convenient place} - overflowerror := false; - before := spacesbefore(sym, lastsym); - if before + symlen + writecol > outlinelen then - begin {must handle an end of line} - if formatting and (symbolbreak > 0) and (charcount - - symbolbreak < bufsize) and (before + symlen + - indent + writecol - breakcol <= outlinelen) then - begin - with unwritten[symbolbreak mod bufsize] do - begin - actionis := beginline; - spacing := indent - end; - writecol := writecol - breakcol + indent; - currentline := currentline + 1; - end - else - begin {no good break spot, break it here} - symindent := outlinelen - symlen; - if symindent > indent then - symindent := indent - else if symindent < 0 then - begin - symindent := 0; - overflowerror := true; - end; - printline(symindent); - end; - symbolbreak := 0; - end; {if line overflow} - if unwritten[oldest].actionis = beginline then - before := 0; - if before > 0 then - if formatting and (symbolbreak = charcount) then - with unwritten[symbolbreak mod bufsize] do - begin - writecol := writecol - spacing + before; - spacing := before; - end - else - space(before); - if formatting then - for i := 1 to symlen do - writea(symbol[i]); - lastsym := sym; - symwritten := true; - if overflowerror then - lineoverflow; - end; {putsym} - -{$p------------------------* - | Parser Utility Routines | - *-------------------------*} - -{*---------* - | nextsym | - *---------*} - - - procedure nextsym; - - begin {output current sym and input next} - if sym <> textend then - begin {symbol} - if not symwritten then - putsym; - getsym; - end {symbol} - end {nextsym} ; - -{*-----------* - | Check sym | - *-----------*} - - - procedure checksym(desired: symbols; - line: integer); - - begin - if sym = desired then - nextsym - else - abort(line, syntax); - end; {checksym} - -{*-----------------* - | Next on newline | - *-----------------*} - - - procedure nextonnewline(spacing, delta: integer); - - begin {space "spacing" lines, indent, put new symbol, and increment - indent by "delta"} - if blankline or (currentline = 0) then - spacing := spacing - 1; - repeat - if spacing > 0 then - printline(0) - else - printline(indent); - spacing := spacing - 1; - until spacing < 0; - indentplus(delta, linenumber); - statindent := indent; - nextsym; - end; {nextonnewline} - -{*------------------* - | Set symbol break | - *------------------*} - - - procedure setsymbolbreak; - - begin {mark a good spot to break a line} - space(0); - symbolbreak := charcount; - breakcol := writecol; - end; {setsymbolbreak} - -{*------------------* - | Log symbol start | - *------------------*} - - - procedure logsymbolstart(var log: collog); - - begin {log the starting loc of the next symbol} - with log do - begin - logchar := charcount + 1; - logcol := writecol + 1; - logline := currentline; - end; - end; {logsymbolstart} - -{$p-------------------* - | Statement bunching | - *--------------------*} - - - procedure bunch(start: collog; {start of statement} - var success: boolean); - - begin {move a statement up to the previous line if it will fit} - with start do - if formatting and (charcount - logchar < bufsize) and (logline + - 1 = currentline) and (writecol - indent + logcol < - outlinelen) then - begin {move it up, adjusting things as we go} - with unwritten[logchar mod bufsize] do - begin - actionis := spaces; - spacing := 1; - writecol := writecol - indent + logcol + 1; - end; - currentline := currentline - 1; - success := true; - end - else - success := false; - end; {bunch} - -{*-----------------* - | Bunchstatements | - *-----------------*} - - - procedure bunchstatement(start: collog); - - var - tabint: integer; {tab interval} - nexttab: integer; {next tab location} - - begin {see if we can put multiple statements on a line} - if formatting then - with start do - begin - tabint := (outlinelen - indent) div statsperline; - if tabint = 0 then - tabint := 1; - if logcol = indent + 1 then - logcol := indent; - {fudge for start} - nexttab := (logcol - indent + tabint - 1) div - tabint * tabint + indent; - if (nexttab > indent) and (logline + 1 = currentline) and - (charcount - logchar < bufsize) and (nexttab + - writecol - indent <= outlinelen) then - begin {move up to prior line and fiddle pointers} - with unwritten[logchar mod bufsize] do - begin - actionis := spaces; - spacing := nexttab - logcol + 1; - end; - writecol := nexttab + writecol - indent; - currentline := currentline - 1; - end; - end; - end; {bunchstatement} - -{$P--------------------------* - | PROGRAM LOOP: processtext | - *---------------------------*} - - - procedure processtext; - - begin {processtext} - if sym in progset then - doprogram - else if sym in blockbegsys then - repeat - doblock - until sym <> semicolon - else if sym in statset then - statlist; - if sym <> textend then - abort(linenumber, syntax); - flushbuffer; - end {processtext} ; - -{*--------------* - | BEGIN PASMAT | - *--------------*} - - begin {pasmat} -(* @sfp := @sfp - stacksize; {more stack space} *) - strptr := @cmd; {get command line} - clinearg := strptr^; - initialize; - commanddirectives; - if not silentmode then - writeln(titleheader); - getchar; {lead one char} - getsym; {lead one symbol} - processtext; - finaldata; - end {pasmat} . - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PASMAT.SRC b/software/CPM/CPM22_MTPUG_10/PASMAT.SRC deleted file mode 100644 index 05c419b..0000000 --- a/software/CPM/CPM22_MTPUG_10/PASMAT.SRC +++ /dev/null @@ -1,955 +0,0 @@ - {*-----------------------------------* - | PASMAT: PAScal source code forMAT | - *-----------------------------------*} -{$K0} {$K7} {$K12} {$K13} {$K14} {$K15} -{$Q2 for parser recursion} -program pasmat; -{$p---------------------* - | Labels and Constants | - *----------------------*} - - const - titleheader = 'Pasmat 3.14, revised 14 Dec 82'; - maxlinelen = 132; {max output line length} - bufsize = 134; {output buffer size, > maxlinelen} - maxwordlen = 9; {reserved words char size} - noreswords = 53; {number of reserved words} - defaultoutline = 72; {default output line length} - defaulttabspaces = 2; {logical indentation increments} - defaultcomentspaces = 1; {spacing before and after comments} - tab = 9; {ord of tab character} - tabinterval = 8; {standard tab interval for CP/M} - stacksize = 256; {extra hardware stack size} - ibufsize = 2047; {size of input buffer - 1} -{$p------* - | Types | - *-------*} - - type - symbols = (abslutesy, andsy, arraysy, beginsy, casesy, constsy, - divsy, dosy, downtosy, elsesy, endsy, externsy, filesy, - forsy, forwardsy, funcsy, gotosy, ifsy, insy, intruptsy, - labelsy, modsy, modendsy, modulesy, nilsy, notsy, ofsy, - orsy, othwisesy, packedsy, procsy, programsy, recordsy, - repeatsy, setsy, stringsy, thensy, tosy, typesy, untilsy, - varsy, whilesy, withsy, plus, minus, mult, divide, - becomes, period, comma, semicolon, colon, equal, - notequal, lessthan, lessequal, greatequal, greatthan, - pointer, subrange, apostrophy, openparen, closeparen, - openbrack, closebrack, identifier, number, stringcon, - coment, textend, dummysy); - {basic symbol enumeration} - setofsyms = set of symbols; {set ops on basic symbols} - wordtype = packed array [1..maxwordlen] of char; - {reserved} - lentabletype = {index into reserved word table by length} - record - lowindex, hiindex: 1..noreswords; - end; - lineindex = 0..maxlinelen; - actions = (graphic, spaces, beginline); - bufferindex = 0..bufsize; {output buffer index} - charbuffer = array [bufferindex] of - record - case actionis: actions of - spaces, beginline: - (spacing: lineindex); - graphic: - (character: char) - end; - collog = - record - logchar: integer; {charcount at time of log} - logcol: lineindex; {writecol at time of log} - logline: integer; {currentline at time of log} - end; - abortkind = (syntax, nesting, comformat); {error types} - stringp = ^string; -{$p----------* - | Variables | - *-----------*} - - var - {CP/M interface control variables} - @sfp: external integer; {initial stack pointer} - strptr: stringp; - clinearg: string[127]; - - {Structured Constants} - stdsyms: setofsyms; {symbols valid in standard pascal} - validdirectives: set of char; {valid formatter directives} - spacebefore, spaceafter: setofsyms; {individual symbol spacing} - alphanumerics: setofsyms; {alpha symbols} - resvwrd: array [1..noreswords] of wordtype; {reserved word table} - ressymbol: array [1..noreswords] of symbols; {symbols for resvwrd} - reslen: array [2..maxwordlen] of lentabletype; { length index} - digits, letters: set of char; - uppercase: array [char] of char; - lowercase: array [char] of char; {case conversion tables} - progset, blockbegsys, statset: setofsyms; {syntactic symbol types} - cnstnts: setofsyms; {symbols which can be constants} - headingbegsys: setofsyms; {symbols which begin a block heading} - typebegsys: setofsyms; {type beginning symbols} - exprbegsys: setofsyms; {expression beginning symbols} - relops: setofsyms; {relational operators} - arithops: setofsyms; {arithmetic operators} - - {Formatting variables} - indent: integer; {current number of indentation spaces} - statindent: integer; {indentation for major statement} - writecol: integer; {current output column} - symbolbreak: integer; {break symbol for putsym} - breakcol: integer; {output column for putsym} - lastsym: symbols; {last symbol processed} - symwritten: boolean; {last symbol was written} - indentstate: array [lineindex] of lineindex; - indentlevel: lineindex; {these make a stack of indent levels} - - {comment formatting} - statbreak: integer; {character where line can be broken} - statblanks: boolean; {set if blank was last char} - firstinputline: boolean; {set if first input line} - - {miscellaneous} - outputline: integer; {line numbers for output} - currentline: integer; {line number being written} - inputline: integer; {input line number} - linenumber: integer; - - {Formatting Control Values} - outlinelen: integer; {current output line length} - onehalfline: integer; {significant point upon line} - fiveeighthline: integer; { "} - threefourthline: integer; {"} - tabspaces: integer; {spaces to indent for each level} - continuespaces: integer; {spaces to indent continuation line} - comentspaces: integer; {spaces before statement comment} - statsperline: integer; {statements per line} - - {Flags to direct formatting} - ucreswords: boolean; {convert reserved words to UC} - ucidents: boolean; {convert identifiers to UC} - litcopy: boolean; {copy identifiers and reserved words literally} - portabilitymode: boolean; {eliminate underscores} - formatting: boolean; {do formatting (otherwise, copy)} - newformatting: boolean; {start formatting at end of comment} - bunching: boolean; {bunch statements on one line} - silentmode: boolean; {don't even generate error messages} - - {lexical scanner variables} - symbolfound: boolean; {success from lexical analysis} - newinputline: boolean; {true when no chars as yet on new line} - endfile: boolean; {eof read} - blankline: boolean; {true when blank line is ok to output} - ch: char; {current character for lexical analysis} - doubleperiod: boolean; {set if double period found} - column: integer; {input column for last char input} - sym: symbols; {current basic symbol from lex} - symbol: array [lineindex] of char; {workspace for lex analysis} - symlen: 0..maxlinelen; {index into WINDOW array} - {output character buffering} - unwritten: charbuffer; {unwritten characters} - charcount: integer; {characters written so far} - oldest: bufferindex; {oldest char in buffer} - - {error handling variables} - overflows: 0..maxint; {number of line overflows} - firstoverflow: 0..maxint; {line where first overflow occured} - comoverflows: 0..maxint; {number of comment overflows} - firstcomoverflow: 0..maxint; {line of first comment overflow} - - external function @cmd: stringp; - external procedure initialize; - - {file i/o entry points} - external procedure abort(line: integer; - kind: abortkind); - external procedure comentoverflow; - external procedure finaldata; - external procedure flushbuffer; - external procedure getchar; - external function getfiles: boolean; - external procedure lineoverflow; - external procedure writea(ch: char); - - {comment entry points} - external procedure comentchar; - external procedure commanddirectives; - - {parser entry points} - external procedure doprogram; - external procedure doblock; - external procedure statlist; - -{$p-----------------* - | Output Utilities | - *------------------*} - - - procedure newline(indent: lineindex); - - begin {start a new line and indent it as specified} - {fake a character, then change it} - writea(' '); - with unwritten[oldest] do - begin - actionis := beginline; - spacing := indent; - end; - writecol := indent; - currentline := currentline + 1; - end; {newline} - - - procedure printline(indent: integer); - - begin {print a line for formatting} - if formatting then - begin - if blankline and (currentline > 0) then - newline(0); - newline(indent); - end; - blankline := false; - symbolbreak := 0; - end; {printline} - - - procedure space(n: integer); - - begin {space n characters} - if formatting then - begin - writea(' '); - with unwritten[oldest] do - begin - actionis := spaces; - if n > 0 then - spacing := n - else - spacing := 0; - end; - writecol := writecol + n - 1; - end; - end; {space} - - - procedure flushsymbol; - - var - p: lineindex; {induction var} - - begin {flush any accumulated characters in the buffer} - if not symwritten then - begin - symwritten := true; - newline(writecol); - for p := 1 to symlen do - writea(symbol[p]); - end; - flushbuffer; - newline(column); - end; {flushsymbol} - -{$p--------------------* - | Indentation Control | - *---------------------*} - - - procedure indentplus(delta: integer; - line: integer); - - begin {increment indentation and check for overflow} - if indentlevel > maxlinelen then - abort(line, nesting); - indentlevel := indentlevel + 1; - indentstate[indentlevel] := indent; - indent := indent + delta; - if indent > outlinelen then - indent := outlinelen - else if indent < 0 then - indent := 0; - end; {indentplus} - - - procedure undent; - - begin {reset indent to the last value} - indent := indentstate[indentlevel]; - indentlevel := indentlevel - 1; - end; {undent} - -{$p-------------------------* - | Lexical Scanner, Utility | - *--------------------------*} - {Place characters of current basic symbol on output TARGET line. - Invoke lexical analysis to assemble next basic symbol in WINDOW - and determine type. SYM is set equal to symbol type. Comments - are transparent to the analysis. } - - - procedure symbolput(thischar: char); - - begin {ch to symbol} - symlen := symlen + 1; - symbol[symlen] := thischar; - getchar; - end {symbolput} ; - -{*------------* - | print char | - *------------*} - - - procedure printchar; - - begin {print ASCII chars not belonging to Pascal} - if writecol >= outlinelen then - printline(indent + continuespaces); - if formatting then - writea(ch); - getchar; - end {printchar} ; - -{*-------------* - | scanblanks | - *-------------*} - - - procedure scanblanks; - - begin {scan off blanks in the input} - while ((ch = ' ') or (ch = chr(tab))) and not endfile do - getchar; - end; - -{$p----------------* - | String Constant | - *-----------------*} - - - procedure stringcnstnt; - - var - stringend: boolean; - - begin {character string to symbol} - newinputline := false; - symbolfound := true; - sym := stringcon; - stringend := false; - repeat - symbolput(ch); - if ch = '''' then - begin - symbolput(ch); - stringend := ch <> '''' - end; - until newinputline or stringend; - if not stringend then - abort(linenumber, syntax); - end {stringcnstnt} ; - -{$p------------------------* - | Test for Reserved Words | - *-------------------------*} - - - procedure testresvwrd; - - var - id: wordtype; - index: 1..noreswords; - p: 1..maxwordlen; - - begin {$R- test for reserved word} - sym := identifier; {default} - if (2 <= symlen) and (symlen <= maxwordlen) then - begin {possible length} - for p := 1 to maxwordlen do - if p > symlen then - id[p] := ' ' - else - id[p] := lowercase[symbol[p]]; - with reslen[symlen] do - begin {length index search} - index := lowindex; - while index <= hiindex do - if resvwrd[index] = id then - begin - sym := ressymbol[index]; - exit - end - else - index := index + 1; - end {length index search} ; - end {possible length} - end { $ R + testresvwrd} ; - -{$p----------------------------* - | Identifier or Reserved Word | - *-----------------------------*} - - - procedure alphachar; - - var - p: lineindex; {induction var} - lastunderscore: boolean; {true if last char underscore} - - begin {identifier or reserved word to symbol} - newinputline := false; - symbolfound := true; - lastunderscore := true; - while ch in letters + digits do - begin - if portabilitymode then - begin - if ch = '_' then - begin - lastunderscore := true; - getchar; - end - else if lastunderscore then - begin - lastunderscore := false; - symbolput(uppercase[ch]); - end - else - symbolput(lowercase[ch]) - end - else - symbolput(ch); - end; {while} - testresvwrd; - if sym = identifier then - begin - if not (litcopy or portabilitymode) then - if ucidents then - for p := 1 to symlen do - symbol[p] := uppercase[symbol[p]] - else - for p := 1 to symlen do - symbol[p] := lowercase[symbol[p]] - end - else {reserved word} - begin - if portabilitymode or (not litcopy) then - if ucreswords then - for p := 1 to symlen do - symbol[p] := uppercase[symbol[p]] - else - for p := 1 to symlen do - symbol[p] := lowercase[symbol[p]]; - end; - end {alpha char} ; - -{$p-------* - | Number | - *--------*} - - - procedure hexcnstnt; - - begin {hexadecimal number to symbol} - newinputline := false; - symbolfound := true; - sym := number; - symbolput(ch); { '$' } - while ch in ['0'..'9', 'A'..'F', 'a'..'f'] do - symbolput(uppercase[ch]); - end {hexcnstnt} ; - - - procedure numericchar; - - begin {unsigned number to symbol} - newinputline := false; - symbolfound := true; - sym := number; - if ch = '#' then - symbolput(ch); - while ch in digits do {integer or fractional portion} - symbolput(ch); - if ch = '.' then - begin - symbolput(ch); - if ch = '.' then - begin {actually subrange, must fudge} - symlen := symlen - 1; {erase period} - doubleperiod := true; - end - else - while ch in digits do - symbolput(ch); - end; - if (ch = 'E') or (ch = 'e') then - begin {exponential portion} - symbolput('E'); - if (ch = '+') or (ch = '-') then {sign} - symbolput(ch); - while ch in digits do {characteristic} - symbolput(ch); - end {exponential} - else if ch = '$' then - hexcnstnt; - end {numeric char} ; - -{$p------------------* - | Special Character | - *-------------------*} - - - procedure specialchar; - - begin {operators or delimiters to symbol} - symbolfound := true; {untrue only for comments} - newinputline := false; - case ch of {special symbols} - '+': - begin {plus} - sym := plus; - symbolput(ch); - end; - '-': - begin {minus} - sym := minus; - symbolput(ch); - end; - '*': - begin {multiply} - sym := mult; - symbolput(ch); - end; - '/': - begin {divide} - sym := divide; - symbolput(ch); - end; - '.': - begin {subrange or period} - sym := period; - symbolput(ch); - if doubleperiod then - begin {fudge a subrange} - symbol[2] := '.'; - symlen := 2; - sym := subrange; - end - else if ch = '.' then - begin {subrange} - sym := subrange; - symbolput(ch); - end; {subrange} - doubleperiod := false; - end; - ',': - begin {comma} - sym := comma; - symbolput(ch); - end; - ';': - begin {semicolon} - sym := semicolon; - symbolput(ch); - end; - ':': - begin {becomes, or colon} - sym := colon; - symbolput(ch); - if ch = '=' then - begin {becomes} - sym := becomes; - symbolput(ch); - end - end; - '=': - begin {equals} - sym := equal; - symbolput(ch); - end; - '<': - begin {less than, less equal, not equal} - sym := lessthan; - symbolput(ch); - if ch = '=' then - begin {less than or equal} - sym := lessequal; - symbolput(ch); - end - else if ch = '>' then - begin {not equal} - sym := notequal; - symbolput(ch); - end - end; - '>': - begin {greater equal, greater than} - sym := greatthan; - symbolput(ch); - if ch = '=' then - begin {greater than or equals} - sym := greatequal; - symbolput(ch); - end - end; - '^': - begin {pointer} - sym := pointer; - symbolput('^'); - end; - '''': - stringcnstnt; - ')': - begin {close parenthesis} - sym := closeparen; - symbolput(ch); - end; - '[': - begin {open bracket} - sym := openbrack; - symbolput(ch); - end; - ']': - begin {close bracket} - sym := closebrack; - symbolput(ch); - end; - '~', '?': - begin {bitwise 'not'} - sym := notsy; - symbolput(ch); - end; - '!', '|': - begin {bitwise 'or'} - sym := orsy; - symbolput(ch); - end; - '&': - begin {bitwise 'and'} - sym := andsy; - symbolput(ch); - end; - end {case} ; - end {specialchar} ; - -{$p--------------------------* - | Get Next Symbol (getsym) | - *---------------------------*} - - - procedure getsym; - - begin {extract next basic sym from text} - symlen := 0; - symbolfound := false; - symwritten := false; - repeat - scanblanks; - if endfile then - begin - sym := textend; - symbolfound := true - end - else if ((ord(ch) >= 0) and (ord(ch) <= 31)) or (ord(ch) = - 127) then - getchar - else - case ch of {lexical analysis} - - '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '$', '#': - numericchar; - - 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', - 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', - 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', - 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', - 'w', 'x', 'y', 'z', '@', '_': - alphachar; - - ')', '*', '+', ',', '-', '.', '/', ':', ';', '<', '=', '>', - '[', ']', '^', '''', '~', '?', '!', '|', '&': - specialchar; - - '(', '{': - comentchar; - - '%', '\', '`', '}', '"': - printchar; - end {case} - until symbolfound - end {getsym} ; - -{$p-------* - | Putsym | - *--------*} - - - procedure putsym; - - var - before: lineindex; {spaces before this character} - symindent: integer; {indentation before this symbol} - i: lineindex; {induction var} - overflowerror: boolean; {delays error message till symbol - printed} - - - function spacesbefore(thissym, oldsym: symbols): lineindex; - - var - spbefore: lineindex; - - begin {determine the number of spaces before a symbol} - if ((thissym in alphanumerics) and (oldsym in alphanumerics)) or - (thissym in spacebefore) or (oldsym in spaceafter) then - spbefore := 1 - else - spbefore := 0; - spacesbefore := spbefore; - end; {spacesbefore} - - begin {putsym: put the current symbol to the output, taking care of - spaces before the symbol. This also handles full lines, and - tries to break lines at a convenient place} - overflowerror := false; - before := spacesbefore(sym, lastsym); - if before + symlen + writecol > outlinelen then - begin {must handle an end of line} - if formatting and (symbolbreak > 0) and (charcount - - symbolbreak < bufsize) and (before + symlen + - indent + writecol - breakcol <= outlinelen) then - begin - with unwritten[symbolbreak mod bufsize] do - begin - actionis := beginline; - spacing := indent - end; - writecol := writecol - breakcol + indent; - currentline := currentline + 1; - end - else - begin {no good break spot, break it here} - symindent := outlinelen - symlen; - if symindent > indent then - symindent := indent - else if symindent < 0 then - begin - symindent := 0; - overflowerror := true; - end; - printline(symindent); - end; - symbolbreak := 0; - end; {if line overflow} - if unwritten[oldest].actionis = beginline then - before := 0; - if before > 0 then - if formatting and (symbolbreak = charcount) then - with unwritten[symbolbreak mod bufsize] do - begin - writecol := writecol - spacing + before; - spacing := before; - end - else - space(before); - if formatting then - for i := 1 to symlen do - writea(symbol[i]); - lastsym := sym; - symwritten := true; - if overflowerror then - lineoverflow; - end; {putsym} - -{$p------------------------* - | Parser Utility Routines | - *-------------------------*} - -{*---------* - | nextsym | - *---------*} - - - procedure nextsym; - - begin {output current sym and input next} - if sym <> textend then - begin {symbol} - if not symwritten then - putsym; - getsym; - end {symbol} - end {nextsym} ; - -{*-----------* - | Check sym | - *-----------*} - - - procedure checksym(desired: symbols; - line: integer); - - begin - if sym = desired then - nextsym - else - abort(line, syntax); - end; {checksym} - -{*-----------------* - | Next on newline | - *-----------------*} - - - procedure nextonnewline(spacing, delta: integer); - - begin {space "spacing" lines, indent, put new symbol, and increment - indent by "delta"} - if blankline or (currentline = 0) then - spacing := spacing - 1; - repeat - if spacing > 0 then - printline(0) - else - printline(indent); - spacing := spacing - 1; - until spacing < 0; - indentplus(delta, linenumber); - statindent := indent; - nextsym; - end; {nextonnewline} - -{*------------------* - | Set symbol break | - *------------------*} - - - procedure setsymbolbreak; - - begin {mark a good spot to break a line} - space(0); - symbolbreak := charcount; - breakcol := writecol; - end; {setsymbolbreak} - -{*------------------* - | Log symbol start | - *------------------*} - - - procedure logsymbolstart(var log: collog); - - begin {log the starting loc of the next symbol} - with log do - begin - logchar := charcount + 1; - logcol := writecol + 1; - logline := currentline; - end; - end; {logsymbolstart} - -{$p-------------------* - | Statement bunching | - *--------------------*} - - - procedure bunch(start: collog; {start of statement} - var success: boolean); - - begin {move a statement up to the previous line if it will fit} - with start do - if formatting and (charcount - logchar < bufsize) and (logline + - 1 = currentline) and (writecol - indent + logcol < - outlinelen) then - begin {move it up, adjusting things as we go} - with unwritten[logchar mod bufsize] do - begin - actionis := spaces; - spacing := 1; - writecol := writecol - indent + logcol + 1; - end; - currentline := currentline - 1; - success := true; - end - else - success := false; - end; {bunch} - -{*-----------------* - | Bunchstatements | - *-----------------*} - - - procedure bunchstatement(start: collog); - - var - tabint: integer; {tab interval} - nexttab: integer; {next tab location} - - begin {see if we can put multiple statements on a line} - if formatting then - with start do - begin - tabint := (outlinelen - indent) div statsperline; - if tabint = 0 then - tabint := 1; - if logcol = indent + 1 then - logcol := indent; - {fudge for start} - nexttab := (logcol - indent + tabint - 1) div - tabint * tabint + indent; - if (nexttab > indent) and (logline + 1 = currentline) and - (charcount - logchar < bufsize) and (nexttab + - writecol - indent <= outlinelen) then - begin {move up to prior line and fiddle pointers} - with unwritten[logchar mod bufsize] do - begin - actionis := spaces; - spacing := nexttab - logcol + 1; - end; - writecol := nexttab + writecol - indent; - currentline := currentline - 1; - end; - end; - end; {bunchstatement} - -{$P--------------------------* - | PROGRAM LOOP: processtext | - *---------------------------*} - - - procedure processtext; - - begin {processtext} - if sym in progset then - doprogram - else if sym in blockbegsys then - repeat - doblock - until sym <> semicolon - else if sym in statset then - statlist; - if sym <> textend then - abort(linenumber, syntax); - flushbuffer; - end {processtext} ; - -{*--------------* - | BEGIN PASMAT | - *--------------*} - - begin {pasmat} - @sfp := @sfp - stacksize; {more stack space} - strptr := @cmd; {get command line} - clinearg := strptr^; - initialize; - commanddirectives; - if not silentmode then - writeln(titleheader); - getchar; {lead one char} - getsym; {lead one symbol} - processtext; - finaldata; - end {pasmat} . - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PASMAT.SU b/software/CPM/CPM22_MTPUG_10/PASMAT.SU deleted file mode 100644 index 6b41546..0000000 --- a/software/CPM/CPM22_MTPUG_10/PASMAT.SU +++ /dev/null @@ -1,8 +0,0 @@ -mt+86 cpmname.src -mt+86 pasmat.src -mt+86 pminit.src -mt+86 pmcoment.src -mt+86 pmparse.src -mt+86 pmfileio.src -linkmt pasmat/f - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PASMAT.SUB b/software/CPM/CPM22_MTPUG_10/PASMAT.SUB deleted file mode 100644 index 21417e2..0000000 --- a/software/CPM/CPM22_MTPUG_10/PASMAT.SUB +++ /dev/null @@ -1,9 +0,0 @@ -mtplus b:cpmname.src -mtplus b:rnb.src -mtplus b:pasmat.src -mtplus b:pminit.src -mtplus b:pmcoment.src -mtplus b:pmparse.src -mtplus b:pmfileio.src -linkmt pasmat/f - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PMCOMENT.PAS b/software/CPM/CPM22_MTPUG_10/PMCOMENT.PAS deleted file mode 100644 index 7161b7f..0000000 --- a/software/CPM/CPM22_MTPUG_10/PMCOMENT.PAS +++ /dev/null @@ -1,494 +0,0 @@ -{*--------------------------------------* - | Pasmat Comment Formatting Procedures | - *--------------------------------------*} -{$K0} {$K7} {$K12} {$K13} {$K14} {$K15} -module comment; - {$L-} - {$I PMDEFS.INC} - {$L+} - - external procedure abort(line: integer; - kind: abortkind); - external procedure comentoverflow; - external procedure getchar; - external procedure getfiles; - external procedure indentplus(delta, line: integer); - external procedure printline(indent: integer); - external procedure space(n: integer); - external procedure symbolput(thischar: char); - external procedure undent; - external procedure writea(ch: char); - -{$p------------------------* - | Block Comment Character | - *-------------------------*} - - - procedure blkcomchar(character: char); - - begin {Write a character for a block comment. The comment - formatting must be terminated with a call to - adjustblkcoment. The comment is copied exactly, and if it - will not fit within the outlinelen a message will be - printed.} - if endfile then - abort(linenumber, syntax); - if formatting then - if newinputline then - begin - if writecol > outlinelen then - comentoverflow; - printline(column); - firstinputline := false; - newinputline := false; - end - else - writea(character); - end; {blkcomchar} -{$p----------------------------* - | Statement Comment Character | - *-----------------------------*} - - - procedure breakstatcoment; - - var - extralen: integer; {length from last break} - comindent: integer; {amount to indent the extra} - - begin {Break a statement comment at the last break. Assumes - (statbreak <> 0) and (charcount - statbreak < bufsize)} - extralen := charcount - statbreak + 1; - if writecol - extralen > maxlinelen then - abort(linenumber, comformat) - else - begin {we can at least write it} - if writecol - extralen > outlinelen then - comentoverflow; - comindent := outlinelen - extralen; - if comindent < 0 then - comindent := 0 - else if comindent > indent then - comindent := indent; - with unwritten[statbreak mod bufsize] do - begin - actionis := beginline; - spacing := comindent; - end; - currentline := currentline + 1; - writecol := comindent + extralen; - end; - end; {breakstatcoment} - - - procedure statcomchar(character: char); - - begin {Take a statement character and format it. assumes that - statbreak and statblank are initialized before the first - character and are unchanged thereafter. The procedure - adjuststatcoment must be called after the comment is done} - if endfile then - abort(linenumber, syntax); - if formatting then - if (character = ' ') or (character = chr(tab)) then - begin - if not statblanks then - begin - if (writecol > outlinelen) and (statbreak <> 0) then - breakstatcoment; - writea(' '); - statbreak := charcount; - statblanks := true; - end; - end - else - begin - writea(character); - statblanks := false; - end; - end; {statcomchar} -{$p-----------------------* - | Do compiler directives | - *------------------------*} - - - procedure docompilerdirectives(block: boolean); - - begin {scan off compiler directives} - while (ch <> '[') and (ch <> '*') and (ch <> '}') do - begin - if block then - blkcomchar(ch) - else - statcomchar(ch); - getchar; - end; - end; {docompilerdirectives} -{$p----------------------* - | doformatterdirectives | - *-----------------------*} - - - procedure doformatterdirectives(block: boolean {block comment} ; - cline: boolean {control line} ); - - var - optchar: char; {which option specified} - - - procedure copyachar; - - begin {copy a character and get a new one} - if cline then - begin - if length(clinearg) = 0 then - ch := '}' - else - begin - ch := clinearg[1]; - delete(clinearg, 1, 1) - end - end - else - begin - if block then - blkcomchar(ch) - else - statcomchar(ch); - getchar; - end; - end; {copyachar} - - - procedure switchdir(var switch: boolean); - - begin {read and set a switch directive, if char is not + or -, - the value is unchanged} - if ch = '+' then - begin - switch := true; - copyachar - end - else if ch = '-' then - begin - switch := false; - copyachar - end; - end; {switchdir} - - - procedure numdir(var value: integer; - min, max: integer {limits} ); - - var - tempval: integer; {value being accumulated} - - begin {Read a numeric directive and set value. If the value is - out of bounds it is set to the limit value} - if ch = '=' then - copyachar; - if (ch >= '0') and (ch <= '9') then - begin - tempval := 0; - repeat - if tempval <= (maxint - 9) div 10 then - tempval := tempval * 10 + (ord(ch) - ord('0')); - copyachar; - until (ch < '0') or (ch > '9'); - if tempval < min then - tempval := min; - if tempval > max then - tempval := max; - value := tempval; - end; - end; {numdir} - - begin {doformatterdirectives: read a formatter directive and set - flags and value appropriately} - copyachar; - repeat - if ch in validdirectives then - begin - optchar := ch; - copyachar; - case optchar of - 'b', 'B': - switchdir(bunching); - 'c', 'C': - numdir(comentspaces, 0, maxlinelen); - 'f', 'F': - switchdir(newformatting); - 'l', 'L': - switchdir(litcopy); - 'o', 'O': - begin - numdir(outlinelen, 1, maxlinelen); - onehalfline := outlinelen div 2; - fiveeighthline := (5 * outlinelen) div 8; - threefourthline := (3 * outlinelen) div 4; - end; - 'p', 'P': - switchdir(portabilitymode); - 'q', 'Q': - switchdir(silentmode); - 'r', 'R': - switchdir(ucreswords); - 's', 'S': - numdir(statsperline, 1, maxlinelen); - 't', 'T': - begin - numdir(tabspaces, 0, maxlinelen); - continuespaces := (tabspaces + 1) div 2; - end; - 'u', 'U': - switchdir(ucidents); - end; {case} - end - else if not (ch in [']', '*', '}']) then - copyachar; - until ch in [']', '*', '}']; - if ch = ']' then - copyachar; - end; {doformatterdirectives} - -{$P------------------------* - | Command Line Directives | - *-------------------------*} - - - procedure commanddirectives; - - begin {read a command line and process directives} - getfiles; - if length(clinearg) > 0 then - doformatterdirectives(false, true); - end; {commanddirectives} - -{$P-----------------* - | Comment Handling | - *------------------*} - - - procedure docoment(block: boolean; {true if block comment} - initcol: lineindex; {starting column} - initchar: char {starting char} ); - {Handles all comments. - Comments are split into two classes which are handled separately. - Comments which begin a line are treated as "block comments" and - are not formatted. At most, it will be folded to fit on the - output line. - Comments which follow other statements on a line are formatted - like any other statement.} - -{$p---------------------* - | Adjust Block Comment | - *----------------------*} - - - procedure adjustblkcoment(startcol, startchar: integer); - - var - comlength: integer; {length of comment if on one line} - comindent: integer; {amount to indent comment} - - begin {if the comment is all on one line, adjust it to line up - with the indentation if possible, otherwise just try to - fit it somehow. In any case, if the comment extends - beyond the allowable length, bitch about it.} - if formatting then - begin - if firstinputline then - begin - comlength := writecol - startcol; - comindent := outlinelen - comlength; - if comindent < 0 then - comindent := 0 - else if comindent > statindent then - comindent := statindent; - unwritten[startchar mod bufsize].spacing := comindent; - writecol := comindent + comlength; - end; - if writecol > outlinelen then - comentoverflow; - end; {if formatting} - end; {adjustblkcoment} - -{$p------------------------* - | Adjust Statment Comment | - *-------------------------*} - - - procedure adjuststatcoment; - - begin {called after the last character of a statment comment has - been written to ensure that it all fits on a line} - if formatting then - if writecol > outlinelen then - if statbreak = 0 then - if writecol <= maxlinelen then - comentoverflow - else - abort(linenumber, comformat) - else - breakstatcoment; - end; {adjuststatcoment} - -{$p--------------* - | Block Comment | - *---------------*} - - - procedure blkcoment; - - var - comcolstart: integer; {start of comment} - comcharstart: integer; {start of comment in buffer} - - begin {format a block comment: If the comment is all on one input - line it will be indented to the current statement level - unless it won't fit, in which case it is shifted left - until it will fit. If any part of a block comment will - not fit in the output line, the output line will be - extended and a message printed.} - printline(initcol - 1); - comcolstart := writecol; - comcharstart := charcount; - firstinputline := true; - blkcomchar('{'); - getchar; - if ch = '$' then - docompilerdirectives(true); - if ch = '[' then - doformatterdirectives(true, false); - if initchar = '{' then - while ch <> '}' do - begin - blkcomchar(ch); - getchar - end - else - repeat - while ch <> '*' do - begin - blkcomchar(ch); - getchar - end; - getchar; - if ch <> ')' then - blkcomchar('*'); - until ch = ')'; - blkcomchar('}'); - adjustblkcoment(comcolstart, comcharstart); - end; {blkcoment} - -{$p-----------* - | Statcoment | - *------------*} - - - procedure statcoment; - - begin {Format a statement comment: These are inserted in the line - at the place found, and subsequent lines are indented to - the start of the comment. If the start of the comment is - too far to the right, it will be indented on the next - line. Text will be moved as necessary to fill lines. All - breaks will be at blanks, and if it is not possible to - break a comment properly the output line will be extended - and a message printed} - {initialize statcomchar} - statbreak := 0; - statblanks := false; - indentplus(writecol + comentspaces + 1 - indent, linenumber); - if (indent > threefourthline) and (tabspaces < - comentspaces) then - begin - undent; - indentplus(tabspaces, linenumber); - end; - if writecol < (outlinelen - comentspaces - 1) then - space(comentspaces); - statcomchar('{'); - getchar; - if ch = '$' then - docompilerdirectives(false); - if ch = '[' then - doformatterdirectives(false, false); - if initchar = '{' then - while ch <> '}' do - begin - statcomchar(ch); - getchar - end - else - repeat - while ch <> '*' do - begin - statcomchar(ch); - getchar - end; - getchar; - if ch <> ')' then - statcomchar('*'); - until ch = ')'; - statcomchar('}'); - adjuststatcoment; - undent; - blankline := false; - end; {statcoment} - -{$p----------------------* - | Main Body of Docoment | - *-----------------------*} - - begin {docoment} - newinputline := false; - if block then - blkcoment - else - statcoment; - formatting := newformatting; - newinputline := false; - getchar; - while ((ch = ' ') or (ch = chr(tab))) and not newinputline do - getchar; - if newinputline then {start new line if comment is last on line} - if formatting then - begin - space(0); - writecol := outlinelen; - symbolbreak := 0; - end {comment at end of line} ; - symbolfound := false; - lastsym := coment; - end; {docoment} - -{$p-----------------* - | Start of Comment | - *------------------*} - - - procedure comentchar; - - begin {possible start of comment} - if ch = '(' then - begin {see if comment or just open paren} - symbolput('('); - if ch = '*' then - begin - symlen := 0; - docoment(newinputline, column - 1, ch) - end - else - begin - newinputline := false; - sym := openparen; - symbolfound := true - end; - end - else - docoment(newinputline, column, ch); - end; {comentchar} - -modend . - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PMCOMENT.SRC b/software/CPM/CPM22_MTPUG_10/PMCOMENT.SRC deleted file mode 100644 index 7161b7f..0000000 --- a/software/CPM/CPM22_MTPUG_10/PMCOMENT.SRC +++ /dev/null @@ -1,494 +0,0 @@ -{*--------------------------------------* - | Pasmat Comment Formatting Procedures | - *--------------------------------------*} -{$K0} {$K7} {$K12} {$K13} {$K14} {$K15} -module comment; - {$L-} - {$I PMDEFS.INC} - {$L+} - - external procedure abort(line: integer; - kind: abortkind); - external procedure comentoverflow; - external procedure getchar; - external procedure getfiles; - external procedure indentplus(delta, line: integer); - external procedure printline(indent: integer); - external procedure space(n: integer); - external procedure symbolput(thischar: char); - external procedure undent; - external procedure writea(ch: char); - -{$p------------------------* - | Block Comment Character | - *-------------------------*} - - - procedure blkcomchar(character: char); - - begin {Write a character for a block comment. The comment - formatting must be terminated with a call to - adjustblkcoment. The comment is copied exactly, and if it - will not fit within the outlinelen a message will be - printed.} - if endfile then - abort(linenumber, syntax); - if formatting then - if newinputline then - begin - if writecol > outlinelen then - comentoverflow; - printline(column); - firstinputline := false; - newinputline := false; - end - else - writea(character); - end; {blkcomchar} -{$p----------------------------* - | Statement Comment Character | - *-----------------------------*} - - - procedure breakstatcoment; - - var - extralen: integer; {length from last break} - comindent: integer; {amount to indent the extra} - - begin {Break a statement comment at the last break. Assumes - (statbreak <> 0) and (charcount - statbreak < bufsize)} - extralen := charcount - statbreak + 1; - if writecol - extralen > maxlinelen then - abort(linenumber, comformat) - else - begin {we can at least write it} - if writecol - extralen > outlinelen then - comentoverflow; - comindent := outlinelen - extralen; - if comindent < 0 then - comindent := 0 - else if comindent > indent then - comindent := indent; - with unwritten[statbreak mod bufsize] do - begin - actionis := beginline; - spacing := comindent; - end; - currentline := currentline + 1; - writecol := comindent + extralen; - end; - end; {breakstatcoment} - - - procedure statcomchar(character: char); - - begin {Take a statement character and format it. assumes that - statbreak and statblank are initialized before the first - character and are unchanged thereafter. The procedure - adjuststatcoment must be called after the comment is done} - if endfile then - abort(linenumber, syntax); - if formatting then - if (character = ' ') or (character = chr(tab)) then - begin - if not statblanks then - begin - if (writecol > outlinelen) and (statbreak <> 0) then - breakstatcoment; - writea(' '); - statbreak := charcount; - statblanks := true; - end; - end - else - begin - writea(character); - statblanks := false; - end; - end; {statcomchar} -{$p-----------------------* - | Do compiler directives | - *------------------------*} - - - procedure docompilerdirectives(block: boolean); - - begin {scan off compiler directives} - while (ch <> '[') and (ch <> '*') and (ch <> '}') do - begin - if block then - blkcomchar(ch) - else - statcomchar(ch); - getchar; - end; - end; {docompilerdirectives} -{$p----------------------* - | doformatterdirectives | - *-----------------------*} - - - procedure doformatterdirectives(block: boolean {block comment} ; - cline: boolean {control line} ); - - var - optchar: char; {which option specified} - - - procedure copyachar; - - begin {copy a character and get a new one} - if cline then - begin - if length(clinearg) = 0 then - ch := '}' - else - begin - ch := clinearg[1]; - delete(clinearg, 1, 1) - end - end - else - begin - if block then - blkcomchar(ch) - else - statcomchar(ch); - getchar; - end; - end; {copyachar} - - - procedure switchdir(var switch: boolean); - - begin {read and set a switch directive, if char is not + or -, - the value is unchanged} - if ch = '+' then - begin - switch := true; - copyachar - end - else if ch = '-' then - begin - switch := false; - copyachar - end; - end; {switchdir} - - - procedure numdir(var value: integer; - min, max: integer {limits} ); - - var - tempval: integer; {value being accumulated} - - begin {Read a numeric directive and set value. If the value is - out of bounds it is set to the limit value} - if ch = '=' then - copyachar; - if (ch >= '0') and (ch <= '9') then - begin - tempval := 0; - repeat - if tempval <= (maxint - 9) div 10 then - tempval := tempval * 10 + (ord(ch) - ord('0')); - copyachar; - until (ch < '0') or (ch > '9'); - if tempval < min then - tempval := min; - if tempval > max then - tempval := max; - value := tempval; - end; - end; {numdir} - - begin {doformatterdirectives: read a formatter directive and set - flags and value appropriately} - copyachar; - repeat - if ch in validdirectives then - begin - optchar := ch; - copyachar; - case optchar of - 'b', 'B': - switchdir(bunching); - 'c', 'C': - numdir(comentspaces, 0, maxlinelen); - 'f', 'F': - switchdir(newformatting); - 'l', 'L': - switchdir(litcopy); - 'o', 'O': - begin - numdir(outlinelen, 1, maxlinelen); - onehalfline := outlinelen div 2; - fiveeighthline := (5 * outlinelen) div 8; - threefourthline := (3 * outlinelen) div 4; - end; - 'p', 'P': - switchdir(portabilitymode); - 'q', 'Q': - switchdir(silentmode); - 'r', 'R': - switchdir(ucreswords); - 's', 'S': - numdir(statsperline, 1, maxlinelen); - 't', 'T': - begin - numdir(tabspaces, 0, maxlinelen); - continuespaces := (tabspaces + 1) div 2; - end; - 'u', 'U': - switchdir(ucidents); - end; {case} - end - else if not (ch in [']', '*', '}']) then - copyachar; - until ch in [']', '*', '}']; - if ch = ']' then - copyachar; - end; {doformatterdirectives} - -{$P------------------------* - | Command Line Directives | - *-------------------------*} - - - procedure commanddirectives; - - begin {read a command line and process directives} - getfiles; - if length(clinearg) > 0 then - doformatterdirectives(false, true); - end; {commanddirectives} - -{$P-----------------* - | Comment Handling | - *------------------*} - - - procedure docoment(block: boolean; {true if block comment} - initcol: lineindex; {starting column} - initchar: char {starting char} ); - {Handles all comments. - Comments are split into two classes which are handled separately. - Comments which begin a line are treated as "block comments" and - are not formatted. At most, it will be folded to fit on the - output line. - Comments which follow other statements on a line are formatted - like any other statement.} - -{$p---------------------* - | Adjust Block Comment | - *----------------------*} - - - procedure adjustblkcoment(startcol, startchar: integer); - - var - comlength: integer; {length of comment if on one line} - comindent: integer; {amount to indent comment} - - begin {if the comment is all on one line, adjust it to line up - with the indentation if possible, otherwise just try to - fit it somehow. In any case, if the comment extends - beyond the allowable length, bitch about it.} - if formatting then - begin - if firstinputline then - begin - comlength := writecol - startcol; - comindent := outlinelen - comlength; - if comindent < 0 then - comindent := 0 - else if comindent > statindent then - comindent := statindent; - unwritten[startchar mod bufsize].spacing := comindent; - writecol := comindent + comlength; - end; - if writecol > outlinelen then - comentoverflow; - end; {if formatting} - end; {adjustblkcoment} - -{$p------------------------* - | Adjust Statment Comment | - *-------------------------*} - - - procedure adjuststatcoment; - - begin {called after the last character of a statment comment has - been written to ensure that it all fits on a line} - if formatting then - if writecol > outlinelen then - if statbreak = 0 then - if writecol <= maxlinelen then - comentoverflow - else - abort(linenumber, comformat) - else - breakstatcoment; - end; {adjuststatcoment} - -{$p--------------* - | Block Comment | - *---------------*} - - - procedure blkcoment; - - var - comcolstart: integer; {start of comment} - comcharstart: integer; {start of comment in buffer} - - begin {format a block comment: If the comment is all on one input - line it will be indented to the current statement level - unless it won't fit, in which case it is shifted left - until it will fit. If any part of a block comment will - not fit in the output line, the output line will be - extended and a message printed.} - printline(initcol - 1); - comcolstart := writecol; - comcharstart := charcount; - firstinputline := true; - blkcomchar('{'); - getchar; - if ch = '$' then - docompilerdirectives(true); - if ch = '[' then - doformatterdirectives(true, false); - if initchar = '{' then - while ch <> '}' do - begin - blkcomchar(ch); - getchar - end - else - repeat - while ch <> '*' do - begin - blkcomchar(ch); - getchar - end; - getchar; - if ch <> ')' then - blkcomchar('*'); - until ch = ')'; - blkcomchar('}'); - adjustblkcoment(comcolstart, comcharstart); - end; {blkcoment} - -{$p-----------* - | Statcoment | - *------------*} - - - procedure statcoment; - - begin {Format a statement comment: These are inserted in the line - at the place found, and subsequent lines are indented to - the start of the comment. If the start of the comment is - too far to the right, it will be indented on the next - line. Text will be moved as necessary to fill lines. All - breaks will be at blanks, and if it is not possible to - break a comment properly the output line will be extended - and a message printed} - {initialize statcomchar} - statbreak := 0; - statblanks := false; - indentplus(writecol + comentspaces + 1 - indent, linenumber); - if (indent > threefourthline) and (tabspaces < - comentspaces) then - begin - undent; - indentplus(tabspaces, linenumber); - end; - if writecol < (outlinelen - comentspaces - 1) then - space(comentspaces); - statcomchar('{'); - getchar; - if ch = '$' then - docompilerdirectives(false); - if ch = '[' then - doformatterdirectives(false, false); - if initchar = '{' then - while ch <> '}' do - begin - statcomchar(ch); - getchar - end - else - repeat - while ch <> '*' do - begin - statcomchar(ch); - getchar - end; - getchar; - if ch <> ')' then - statcomchar('*'); - until ch = ')'; - statcomchar('}'); - adjuststatcoment; - undent; - blankline := false; - end; {statcoment} - -{$p----------------------* - | Main Body of Docoment | - *-----------------------*} - - begin {docoment} - newinputline := false; - if block then - blkcoment - else - statcoment; - formatting := newformatting; - newinputline := false; - getchar; - while ((ch = ' ') or (ch = chr(tab))) and not newinputline do - getchar; - if newinputline then {start new line if comment is last on line} - if formatting then - begin - space(0); - writecol := outlinelen; - symbolbreak := 0; - end {comment at end of line} ; - symbolfound := false; - lastsym := coment; - end; {docoment} - -{$p-----------------* - | Start of Comment | - *------------------*} - - - procedure comentchar; - - begin {possible start of comment} - if ch = '(' then - begin {see if comment or just open paren} - symbolput('('); - if ch = '*' then - begin - symlen := 0; - docoment(newinputline, column - 1, ch) - end - else - begin - newinputline := false; - sym := openparen; - symbolfound := true - end; - end - else - docoment(newinputline, column, ch); - end; {comentchar} - -modend . - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PMDEFS.IN b/software/CPM/CPM22_MTPUG_10/PMDEFS.IN deleted file mode 100644 index 65acf56..0000000 --- a/software/CPM/CPM22_MTPUG_10/PMDEFS.IN +++ /dev/null @@ -1,155 +0,0 @@ -{$p----------* - | Constants | - *-----------*} - - const - maxlinelen = 132; {max output line length} - bufsize = 134; {output buffer size, > maxlinelen} - maxwordlen = 9; {reserved words char size} - noreswords = 53; {number of reserved words} - defaultoutline = 72; {default output line length} - defaulttabspaces = 2; {logical indentation increments} - defaultcomentspaces = 1; {spacing before and after comments} - tab = 9; {ord of tab character} - tabinterval = 8; {standard tab interval for CP/M} - ibufsize = 2047; {size of input file buffer} - -{$p------* - | Types | - *-------*} - - type - symbols = (abslutesy, andsy, arraysy, beginsy, casesy, constsy, - divsy, dosy, downtosy, elsesy, endsy, externsy, filesy, - forsy, forwardsy, funcsy, gotosy, ifsy, insy, intruptsy, - labelsy, modsy, modendsy, modulesy, nilsy, notsy, ofsy, - orsy, othwisesy, packedsy, procsy, programsy, recordsy, - repeatsy, setsy, stringsy, thensy, tosy, typesy, untilsy, - varsy, whilesy, withsy, plus, minus, mult, divide, - becomes, period, comma, semicolon, colon, equal, - notequal, lessthan, lessequal, greatequal, greatthan, - pointer, subrange, apostrophy, openparen, closeparen, - openbrack, closebrack, identifier, number, stringcon, - coment, textend, dummysy); - - {basic symbol enumeration} - setofsyms = set of symbols; {set ops on basic symbols} - wordtype = packed array [1..maxwordlen] of char; - - {reserved} - lentabletype = {index into reserved word table by length} - record - lowindex, hiindex: 1..noreswords; - end; - - lineindex = 0..maxlinelen; - actions = (graphic, spaces, beginline); - bufferindex = 0..bufsize; {output buffer index} - charbuffer = array [bufferindex] of - record - case actionis: actions of - spaces, beginline: - (spacing: lineindex); - graphic: - (character: char) - end; - collog = - record - logchar: integer; {charcount at time of log} - logcol: lineindex; {writecol at time of log} - logline: integer; {currentline at time of log} - end; - abortkind = (syntax, nesting, comformat); {error types} - stringp = ^string; - -{$p----------* - | Variables | - *-----------*} - - var - {CP/M interface variables} - clinearg: external string[127]; - - {Structured Constants} - stdsyms: external setofsyms; {symbols valid in standard pascal} - validdirectives: external set of char; {valid formatter directives} - spacebefore, spaceafter: external setofsyms; {individual symbol spacing} - alphanumerics: external setofsyms; {alpha symbols} - resvwrd: external array [1..noreswords] of wordtype; {reserved word table} - ressymbol: external array [1..noreswords] of symbols; {symbols for resvwrd} - reslen: external array [2..maxwordlen] of lentabletype; { length index} - digits, letters: external set of char; - uppercase: external array [char] of char; - lowercase: external array [char] of char; {case conversion tables} - progset, blockbegsys, statset: external setofsyms; {syntactic symbol types} - cnstnts: external setofsyms; {symbols which can be constants} - headingbegsys: external setofsyms; {symbols which begin a block heading} - typebegsys: external setofsyms; {type beginning symbols} - exprbegsys: external setofsyms; {expression beginning symbols} - relops: external setofsyms; {relational operators} - arithops: external setofsyms; {arithmetic operators} - - {Formatting variables} - indent: external integer; {current number of indentation spaces} - statindent: external integer; {indentation for major statement} - writecol: external integer; {current output column} - symbolbreak: external integer; {break symbol for putsym} - breakcol: external integer; {output column for putsym} - lastsym: external symbols; {last symbol processed} - symwritten: external boolean; {last symbol was written} - indentstate: external array [lineindex] of lineindex; - indentlevel: external lineindex; {these make a stack of indent levels} - - {comment formatting} - statbreak: external integer; {character where line can be broken} - statblanks: external boolean; {set if blank was last char} - firstinputline: external boolean; {set if first input line} - - {miscellaneous} - outputline: external integer; {line numbers for output} - currentline: external integer; {line number being written} - inputline: external integer; {input line number} - linenumber: external integer; - - {Formatting Control Values} - outlinelen: external integer; {current output line length} - onehalfline: external integer; {significant point upon line} - fiveeighthline: external integer; { "} - threefourthline: external integer; {"} - tabspaces: external integer; {spaces to indent for each level} - continuespaces: external integer; {spaces to indent continuation line} - comentspaces: external integer; {spaces before statement comment} - statsperline: external integer; {statements per line} - - {Flags to direct formatting} - ucreswords: external boolean; {convert reserved words to UC} - ucidents: external boolean; {convert identifiers to UC} - litcopy: external boolean; {copy identifiers and reserved words literally} - portabilitymode: external boolean; {eliminate underscores} - formatting: external boolean; {do formatting (otherwise, copy)} - newformatting: external boolean; {start formatting at end of comment} - bunching: external boolean; {bunch statements on one line} - silentmode: external boolean; {don't even generate error messages} - - {lexical scanner variables} - symbolfound: external boolean; {success from lexical analysis} - newinputline: external boolean; {true when no chars as yet on new line} - endfile: external boolean; {eof read} - blankline: external boolean; {true when blank line is ok to output} - ch: external char; {current character for lexical analysis} - doubleperiod: external boolean; {set if double period found} - column: external integer; {input column for last char input} - sym: external symbols; {current basic symbol from lex} - symbol: external array [lineindex] of char; {workspace for lex analysis} - symlen: external 0..maxlinelen; {index into WINDOW array} - {output character buffering} - unwritten: external charbuffer; {unwritten characters} - charcount: external integer; {characters written so far} - oldest: external bufferindex; {oldest char in buffer} - - {error handling variables} - overflows: external 0..maxint; {number of line overflows} - firstoverflow: external 0..maxint; {line where first overflow occured} - comoverflows: external 0..maxint; {number of comment overflows} - firstcomoverflow: external 0..maxint; {line of first comment overflow} - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PMDEFS.INC b/software/CPM/CPM22_MTPUG_10/PMDEFS.INC deleted file mode 100644 index 65acf56..0000000 --- a/software/CPM/CPM22_MTPUG_10/PMDEFS.INC +++ /dev/null @@ -1,155 +0,0 @@ -{$p----------* - | Constants | - *-----------*} - - const - maxlinelen = 132; {max output line length} - bufsize = 134; {output buffer size, > maxlinelen} - maxwordlen = 9; {reserved words char size} - noreswords = 53; {number of reserved words} - defaultoutline = 72; {default output line length} - defaulttabspaces = 2; {logical indentation increments} - defaultcomentspaces = 1; {spacing before and after comments} - tab = 9; {ord of tab character} - tabinterval = 8; {standard tab interval for CP/M} - ibufsize = 2047; {size of input file buffer} - -{$p------* - | Types | - *-------*} - - type - symbols = (abslutesy, andsy, arraysy, beginsy, casesy, constsy, - divsy, dosy, downtosy, elsesy, endsy, externsy, filesy, - forsy, forwardsy, funcsy, gotosy, ifsy, insy, intruptsy, - labelsy, modsy, modendsy, modulesy, nilsy, notsy, ofsy, - orsy, othwisesy, packedsy, procsy, programsy, recordsy, - repeatsy, setsy, stringsy, thensy, tosy, typesy, untilsy, - varsy, whilesy, withsy, plus, minus, mult, divide, - becomes, period, comma, semicolon, colon, equal, - notequal, lessthan, lessequal, greatequal, greatthan, - pointer, subrange, apostrophy, openparen, closeparen, - openbrack, closebrack, identifier, number, stringcon, - coment, textend, dummysy); - - {basic symbol enumeration} - setofsyms = set of symbols; {set ops on basic symbols} - wordtype = packed array [1..maxwordlen] of char; - - {reserved} - lentabletype = {index into reserved word table by length} - record - lowindex, hiindex: 1..noreswords; - end; - - lineindex = 0..maxlinelen; - actions = (graphic, spaces, beginline); - bufferindex = 0..bufsize; {output buffer index} - charbuffer = array [bufferindex] of - record - case actionis: actions of - spaces, beginline: - (spacing: lineindex); - graphic: - (character: char) - end; - collog = - record - logchar: integer; {charcount at time of log} - logcol: lineindex; {writecol at time of log} - logline: integer; {currentline at time of log} - end; - abortkind = (syntax, nesting, comformat); {error types} - stringp = ^string; - -{$p----------* - | Variables | - *-----------*} - - var - {CP/M interface variables} - clinearg: external string[127]; - - {Structured Constants} - stdsyms: external setofsyms; {symbols valid in standard pascal} - validdirectives: external set of char; {valid formatter directives} - spacebefore, spaceafter: external setofsyms; {individual symbol spacing} - alphanumerics: external setofsyms; {alpha symbols} - resvwrd: external array [1..noreswords] of wordtype; {reserved word table} - ressymbol: external array [1..noreswords] of symbols; {symbols for resvwrd} - reslen: external array [2..maxwordlen] of lentabletype; { length index} - digits, letters: external set of char; - uppercase: external array [char] of char; - lowercase: external array [char] of char; {case conversion tables} - progset, blockbegsys, statset: external setofsyms; {syntactic symbol types} - cnstnts: external setofsyms; {symbols which can be constants} - headingbegsys: external setofsyms; {symbols which begin a block heading} - typebegsys: external setofsyms; {type beginning symbols} - exprbegsys: external setofsyms; {expression beginning symbols} - relops: external setofsyms; {relational operators} - arithops: external setofsyms; {arithmetic operators} - - {Formatting variables} - indent: external integer; {current number of indentation spaces} - statindent: external integer; {indentation for major statement} - writecol: external integer; {current output column} - symbolbreak: external integer; {break symbol for putsym} - breakcol: external integer; {output column for putsym} - lastsym: external symbols; {last symbol processed} - symwritten: external boolean; {last symbol was written} - indentstate: external array [lineindex] of lineindex; - indentlevel: external lineindex; {these make a stack of indent levels} - - {comment formatting} - statbreak: external integer; {character where line can be broken} - statblanks: external boolean; {set if blank was last char} - firstinputline: external boolean; {set if first input line} - - {miscellaneous} - outputline: external integer; {line numbers for output} - currentline: external integer; {line number being written} - inputline: external integer; {input line number} - linenumber: external integer; - - {Formatting Control Values} - outlinelen: external integer; {current output line length} - onehalfline: external integer; {significant point upon line} - fiveeighthline: external integer; { "} - threefourthline: external integer; {"} - tabspaces: external integer; {spaces to indent for each level} - continuespaces: external integer; {spaces to indent continuation line} - comentspaces: external integer; {spaces before statement comment} - statsperline: external integer; {statements per line} - - {Flags to direct formatting} - ucreswords: external boolean; {convert reserved words to UC} - ucidents: external boolean; {convert identifiers to UC} - litcopy: external boolean; {copy identifiers and reserved words literally} - portabilitymode: external boolean; {eliminate underscores} - formatting: external boolean; {do formatting (otherwise, copy)} - newformatting: external boolean; {start formatting at end of comment} - bunching: external boolean; {bunch statements on one line} - silentmode: external boolean; {don't even generate error messages} - - {lexical scanner variables} - symbolfound: external boolean; {success from lexical analysis} - newinputline: external boolean; {true when no chars as yet on new line} - endfile: external boolean; {eof read} - blankline: external boolean; {true when blank line is ok to output} - ch: external char; {current character for lexical analysis} - doubleperiod: external boolean; {set if double period found} - column: external integer; {input column for last char input} - sym: external symbols; {current basic symbol from lex} - symbol: external array [lineindex] of char; {workspace for lex analysis} - symlen: external 0..maxlinelen; {index into WINDOW array} - {output character buffering} - unwritten: external charbuffer; {unwritten characters} - charcount: external integer; {characters written so far} - oldest: external bufferindex; {oldest char in buffer} - - {error handling variables} - overflows: external 0..maxint; {number of line overflows} - firstoverflow: external 0..maxint; {line where first overflow occured} - comoverflows: external 0..maxint; {number of comment overflows} - firstcomoverflow: external 0..maxint; {line of first comment overflow} - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PMFILEIO.PAS b/software/CPM/CPM22_MTPUG_10/PMFILEIO.PAS deleted file mode 100644 index 4ffcc0b..0000000 --- a/software/CPM/CPM22_MTPUG_10/PMFILEIO.PAS +++ /dev/null @@ -1,284 +0,0 @@ -{*-------------------------------------------* - | Pasmat - All Direct I/O is in this Module | - *-------------------------------------------*} -{$K0} {$K7} {$K12} {$K14} {$K15} -module pmfileio; - {$L-} - {$I PMDEFS.INC} - {$L+} - - var - finp: file of packed array [0..ibufsize] of char; - fout: text; - - external procedure @hlt; - {check file name for legality} - external function cpmname(str: string): boolean; - {pasmat entry points} - external procedure flushsymbol; - external procedure newline(indent: lineindex); - -{$p----------------------------* - | Terminate and Print Message | - *-----------------------------*} - - - procedure finaldata; - - var - fstatus: integer; - - begin {print summary data} - if not silentmode then - begin - if (overflows > 0) or (comoverflows > 0) then - writeln; - writeln(inputline - 1: 1, ' lines input, ', currentline: 1, - ' lines output'); - if overflows = 1 then - writeln('Token too wide for output at output line ', - firstoverflow: 1) - else if overflows > 1 then - writeln('Token too wide for output in ', overflows: 1, - ' places, first at output line ', firstoverflow: 1); - if comoverflows = 1 then - writeln('Comment too wide for output at output line ', - firstcomoverflow: 1) - else if comoverflows > 1 then - writeln('Comment too wide for output in ', comoverflows: 1, - ' places, first at output line ', firstcomoverflow: - 1); - end; - close(fout, fstatus); - if fstatus = 255 then - writeln('Unable to close output file'); - end; {finaldata} -{$p-----------------* - | Character output | - *------------------*} - - - procedure writea(ch: char); - - var - i: lineindex; - - begin {Write a character to the output buffer. If necessary (which - it always is after the buffer is filled), write the - previous contents of the buffer} - charcount := charcount + 1; - oldest := charcount mod bufsize; - with unwritten[oldest] do - begin - if charcount > bufsize then - if actionis = graphic then - write(fout, character) - else if actionis = spaces then - begin - for i := 1 to spacing do - write(fout, ' '); - end - else {actionis = beginline} - begin - if outputline > 1 then {not initial begin} - begin - writeln(fout); - end; - outputline := outputline + 1; - for i := 1 to spacing div tabinterval do - write(fout, chr(tab)); - for i := 1 to spacing mod tabinterval do - write(fout, ' '); - end; - actionis := graphic; - character := ch; - writecol := writecol + 1; - if ch = chr(tab) then - writecol := writecol + tabinterval - (writecol mod - tabinterval); - end; {with} - end; {writea} - - - procedure flushbuffer; - - var - i: 0..bufsize; - - begin {flush any unwritten buffer} - for i := 1 to bufsize do - writea(' '); - charcount := 0; - writeln(fout); - end; {flushbuffer} - -{$P----------------* - | Character Input | - *-----------------*} - - - procedure getchar; - - begin {read next character from input file} - repeat - if endfile then - ch := chr($1A) - else - ch := gnb(finp); - if (ch = chr($1A)) or (ch = chr($FF)) then - begin {eof} - ch := ' '; - endfile := true; - exit - end; {eof} - ch := chr(ord(ch) & $7F); {strip hi bit} - until ch <> chr($0A); {skip over line feeds} - if ch = chr($0D) then - begin {eoln} - if newinputline then - blankline := true - else - newinputline := true; - column := 0; - inputline := inputline + 1; - if not formatting then - newline(0); - ch := ' '; - end {eoln} - else - begin {normal} - column := column + 1; - if not formatting then - writea(ch); - if ch = chr(tab) then - column := column + tabinterval - (column mod tabinterval); - end {normal} - end {getchar} ; - -{$p---------------* - | Error Handling | - *----------------*} - - - procedure lineoverflow; - - begin {token too long for output line, note it} - flushbuffer; - overflows := overflows + 1; - if overflows = 1 then - firstoverflow := currentline - 1; - if not silentmode then - begin - writeln(' '); {put following message on separate line} - writeln('Warning - token too wide for output: ', 'input line ', - inputline: 1, ', output line ', currentline - 1: 1); - end {not silentmode} ; - end; {lineoverflow} - - - procedure comentoverflow; - - begin {block comment too long for output line, note it} - comoverflows := comoverflows + 1; - if comoverflows = 1 then - firstcomoverflow := currentline; - if not silentmode then - begin - writeln(' '); {put following message on separate line} - writeln('Warning - comment too wide for output: ', - 'input line ', inputline: 1, ', output line ', - currentline: 1); - end {not silentmode} ; - end; {comentoverflow} - - - procedure abort(line: integer; - kind: abortkind); - - {the argument 'line' is not used in CP/M version} - - begin {abort formatting} - flushsymbol; - newformatting := false; - formatting := false; - if not silentmode then - begin - writeln(' '); - if kind = syntax then - writeln('Syntax error: input line ', inputline: 1, - ', output line ', currentline - 2: 1) - else if kind = nesting then - writeln('Too many levels: input line ', inputline: 1, - ', output line', currentline - 1: 1) - else - writeln('Bad comment: input line ', inputline: 1, - ', output line ', currentline - 1: 1); - end {not silentmode} ; - writea(ch); - while not endfile do - getchar; - flushbuffer; - finaldata; - @hlt; - end; {abort} - -{$p-----------------------* - | Get input/output files | - *------------------------*} - - - procedure getfiles; - - var - name: string; - ch: char; - - - procedure gname; - - var - i: integer; - - begin {gname} - name := ''; - i := 1; - while (i <= length(clinearg)) and (clinearg[i] = ' ') do - i := i + 1; {skip leading blanks} - while (i <= length(clinearg)) and (clinearg[i] <> ' ') do - begin {copy up to next blank} - ch := clinearg[i]; - i := i + 1; - if ch in ['a'..'z'] then - ch := chr(ord(ch) - $20); {ensure upper case} - name := concat(name, ch); - end; - if i > 1 then {remove name} - delete(clinearg, 1, i - 1); - end {gname} ; - - - procedure usage(str: string); - - begin {print error message and abort} - writeln(str); - writeln('Usage: pasmat infile outfile options'); - @hlt - end {usage} ; - - begin {getfiles} - gname; - assign(finp, name); - reset(finp); - if ioresult = 255 then - usage(concat('Unable to open ', name, ' for input')); - gname; - if not cpmname(name) then - usage(concat('Illegal CP/M name: ', name)); - assign(fout, name); - rewrite(fout); - if ioresult = 255 then - usage(concat('Unable to open ', name, ' for output')); - end; {getfiles} - -modend . - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PMFILEIO.SRC b/software/CPM/CPM22_MTPUG_10/PMFILEIO.SRC deleted file mode 100644 index 4ffcc0b..0000000 --- a/software/CPM/CPM22_MTPUG_10/PMFILEIO.SRC +++ /dev/null @@ -1,284 +0,0 @@ -{*-------------------------------------------* - | Pasmat - All Direct I/O is in this Module | - *-------------------------------------------*} -{$K0} {$K7} {$K12} {$K14} {$K15} -module pmfileio; - {$L-} - {$I PMDEFS.INC} - {$L+} - - var - finp: file of packed array [0..ibufsize] of char; - fout: text; - - external procedure @hlt; - {check file name for legality} - external function cpmname(str: string): boolean; - {pasmat entry points} - external procedure flushsymbol; - external procedure newline(indent: lineindex); - -{$p----------------------------* - | Terminate and Print Message | - *-----------------------------*} - - - procedure finaldata; - - var - fstatus: integer; - - begin {print summary data} - if not silentmode then - begin - if (overflows > 0) or (comoverflows > 0) then - writeln; - writeln(inputline - 1: 1, ' lines input, ', currentline: 1, - ' lines output'); - if overflows = 1 then - writeln('Token too wide for output at output line ', - firstoverflow: 1) - else if overflows > 1 then - writeln('Token too wide for output in ', overflows: 1, - ' places, first at output line ', firstoverflow: 1); - if comoverflows = 1 then - writeln('Comment too wide for output at output line ', - firstcomoverflow: 1) - else if comoverflows > 1 then - writeln('Comment too wide for output in ', comoverflows: 1, - ' places, first at output line ', firstcomoverflow: - 1); - end; - close(fout, fstatus); - if fstatus = 255 then - writeln('Unable to close output file'); - end; {finaldata} -{$p-----------------* - | Character output | - *------------------*} - - - procedure writea(ch: char); - - var - i: lineindex; - - begin {Write a character to the output buffer. If necessary (which - it always is after the buffer is filled), write the - previous contents of the buffer} - charcount := charcount + 1; - oldest := charcount mod bufsize; - with unwritten[oldest] do - begin - if charcount > bufsize then - if actionis = graphic then - write(fout, character) - else if actionis = spaces then - begin - for i := 1 to spacing do - write(fout, ' '); - end - else {actionis = beginline} - begin - if outputline > 1 then {not initial begin} - begin - writeln(fout); - end; - outputline := outputline + 1; - for i := 1 to spacing div tabinterval do - write(fout, chr(tab)); - for i := 1 to spacing mod tabinterval do - write(fout, ' '); - end; - actionis := graphic; - character := ch; - writecol := writecol + 1; - if ch = chr(tab) then - writecol := writecol + tabinterval - (writecol mod - tabinterval); - end; {with} - end; {writea} - - - procedure flushbuffer; - - var - i: 0..bufsize; - - begin {flush any unwritten buffer} - for i := 1 to bufsize do - writea(' '); - charcount := 0; - writeln(fout); - end; {flushbuffer} - -{$P----------------* - | Character Input | - *-----------------*} - - - procedure getchar; - - begin {read next character from input file} - repeat - if endfile then - ch := chr($1A) - else - ch := gnb(finp); - if (ch = chr($1A)) or (ch = chr($FF)) then - begin {eof} - ch := ' '; - endfile := true; - exit - end; {eof} - ch := chr(ord(ch) & $7F); {strip hi bit} - until ch <> chr($0A); {skip over line feeds} - if ch = chr($0D) then - begin {eoln} - if newinputline then - blankline := true - else - newinputline := true; - column := 0; - inputline := inputline + 1; - if not formatting then - newline(0); - ch := ' '; - end {eoln} - else - begin {normal} - column := column + 1; - if not formatting then - writea(ch); - if ch = chr(tab) then - column := column + tabinterval - (column mod tabinterval); - end {normal} - end {getchar} ; - -{$p---------------* - | Error Handling | - *----------------*} - - - procedure lineoverflow; - - begin {token too long for output line, note it} - flushbuffer; - overflows := overflows + 1; - if overflows = 1 then - firstoverflow := currentline - 1; - if not silentmode then - begin - writeln(' '); {put following message on separate line} - writeln('Warning - token too wide for output: ', 'input line ', - inputline: 1, ', output line ', currentline - 1: 1); - end {not silentmode} ; - end; {lineoverflow} - - - procedure comentoverflow; - - begin {block comment too long for output line, note it} - comoverflows := comoverflows + 1; - if comoverflows = 1 then - firstcomoverflow := currentline; - if not silentmode then - begin - writeln(' '); {put following message on separate line} - writeln('Warning - comment too wide for output: ', - 'input line ', inputline: 1, ', output line ', - currentline: 1); - end {not silentmode} ; - end; {comentoverflow} - - - procedure abort(line: integer; - kind: abortkind); - - {the argument 'line' is not used in CP/M version} - - begin {abort formatting} - flushsymbol; - newformatting := false; - formatting := false; - if not silentmode then - begin - writeln(' '); - if kind = syntax then - writeln('Syntax error: input line ', inputline: 1, - ', output line ', currentline - 2: 1) - else if kind = nesting then - writeln('Too many levels: input line ', inputline: 1, - ', output line', currentline - 1: 1) - else - writeln('Bad comment: input line ', inputline: 1, - ', output line ', currentline - 1: 1); - end {not silentmode} ; - writea(ch); - while not endfile do - getchar; - flushbuffer; - finaldata; - @hlt; - end; {abort} - -{$p-----------------------* - | Get input/output files | - *------------------------*} - - - procedure getfiles; - - var - name: string; - ch: char; - - - procedure gname; - - var - i: integer; - - begin {gname} - name := ''; - i := 1; - while (i <= length(clinearg)) and (clinearg[i] = ' ') do - i := i + 1; {skip leading blanks} - while (i <= length(clinearg)) and (clinearg[i] <> ' ') do - begin {copy up to next blank} - ch := clinearg[i]; - i := i + 1; - if ch in ['a'..'z'] then - ch := chr(ord(ch) - $20); {ensure upper case} - name := concat(name, ch); - end; - if i > 1 then {remove name} - delete(clinearg, 1, i - 1); - end {gname} ; - - - procedure usage(str: string); - - begin {print error message and abort} - writeln(str); - writeln('Usage: pasmat infile outfile options'); - @hlt - end {usage} ; - - begin {getfiles} - gname; - assign(finp, name); - reset(finp); - if ioresult = 255 then - usage(concat('Unable to open ', name, ' for input')); - gname; - if not cpmname(name) then - usage(concat('Illegal CP/M name: ', name)); - assign(fout, name); - rewrite(fout); - if ioresult = 255 then - usage(concat('Unable to open ', name, ' for output')); - end; {getfiles} - -modend . - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PMINIT.PAS b/software/CPM/CPM22_MTPUG_10/PMINIT.PAS deleted file mode 100644 index ec26e02..0000000 --- a/software/CPM/CPM22_MTPUG_10/PMINIT.PAS +++ /dev/null @@ -1,220 +0,0 @@ -{*-----------------------* - | Pasmat Initialization | - *-----------------------*} -{$K0} {$K2} {$K7} {$K12} {$K13} {$K14} {$K15} -module pminit; - {$L-} - {$I PMDEFS.INC} - {$L+} -{$p-------------------------* - | Initialize Set Constants | - *--------------------------*} - - - procedure init1sets; - - begin {initialize set constants, part 1} - stdsyms := [abslutesy, andsy, arraysy, beginsy, casesy, constsy, - divsy, dosy, downtosy, elsesy, endsy, externsy, filesy, - forsy, forwardsy, funcsy, gotosy, ifsy, insy, - intruptsy, labelsy, modsy, modendsy, modulesy, nilsy, - notsy, ofsy, orsy, othwisesy, packedsy, procsy, - programsy, recordsy, repeatsy, setsy, stringsy, thensy, - tosy, typesy, untilsy, varsy, whilesy, withsy, plus, - minus, mult, divide, becomes, period, comma, semicolon, - colon, equal, notequal, lessthan, lessequal, - greatequal, greatthan, pointer, subrange, apostrophy, - openparen, closeparen, openbrack, closebrack, - identifier, number, stringcon, coment, textend, - dummysy]; - {constants used by putsym} - spacebefore := [abslutesy, andsy, divsy, dosy, downtosy, insy, - intruptsy, modsy, ofsy, orsy, thensy, tosy, plus, - minus, mult, divide, becomes, equal, notequal, - lessthan, lessequal, greatequal, greatthan]; - spaceafter := [abslutesy, andsy, arraysy, casesy, divsy, downtosy, - externsy, filesy, forsy, funcsy, gotosy, ifsy, insy, - intruptsy, modsy, modendsy, modulesy, notsy, ofsy, - orsy, othwisesy, packedsy, procsy, programsy, tosy, - untilsy, whilesy, withsy, plus, minus, mult, divide, - becomes, comma, semicolon, colon, equal, notequal, - lessthan, lessequal, greatequal, greatthan, coment]; - alphanumerics := [abslutesy..withsy, identifier, number]; - digits := ['0'..'9']; - letters := ['a'..'z', 'A'..'Z', '_', '@']; - progset := [programsy, modulesy]; - end {init1sets} ; - - - procedure init2sets; - - begin {initialize set constants, part 2} - headingbegsys := [labelsy, constsy, typesy, varsy, procsy, funcsy, - externsy]; - blockbegsys := headingbegsys + [beginsy]; - statset := [beginsy, ifsy, casesy, whilesy, repeatsy, forsy, - withsy, gotosy, number, identifier]; - cnstnts := [number, identifier, stringcon, plus, minus, nilsy]; - exprbegsys := cnstnts + [notsy, nilsy, openbrack, openparen]; - relops := [equal, notequal, lessthan, lessequal, greatthan, - greatequal, insy]; - arithops := [plus, minus, mult, divide, divsy, modsy]; - typebegsys := cnstnts + [pointer, setsy, recordsy, filesy, - arraysy, openparen, stringsy]; - validdirectives := ['b', 'B', 'c', 'C', 'f', 'F', 'l', 'L', 'o', - 'O', 'p', 'P', 'q', 'Q', 'r', 'R', 's', 'S', - 't', 'T', 'u', 'U']; - end {init2sets} ; -{$p--------------------------* - | initialize reserved words | - *---------------------------*} - - - procedure init1resvwrd; - - begin {[s=2] initialize reserved word length indices into reserved - word array for length keyed search} - reslen[2].lowindex := 1; reslen[2].hiindex := 6; - reslen[3].lowindex := 7; reslen[3].hiindex := 15; - reslen[4].lowindex := 17; reslen[4].hiindex := 23; - reslen[5].lowindex := 31; reslen[5].hiindex := 36; - reslen[6].lowindex := 37; reslen[6].hiindex := 43; - reslen[7].lowindex := 45; reslen[7].hiindex := 46; - reslen[8].lowindex := 47; reslen[8].hiindex := 49; - reslen[9].lowindex := 51; reslen[9].hiindex := 53; - end {[s=1] init1resvwrd} ; - - - procedure init2resvwrd; - - begin {[s=2] initialize reserved word array} - resvwrd[1] := 'do '; ressymbol[1] := dosy; - resvwrd[2] := 'if '; ressymbol[2] := ifsy; - resvwrd[3] := 'in '; ressymbol[3] := insy; - resvwrd[4] := 'of '; ressymbol[4] := ofsy; - resvwrd[5] := 'or '; ressymbol[5] := orsy; - resvwrd[6] := 'to '; ressymbol[6] := tosy; - resvwrd[7] := 'and '; ressymbol[7] := andsy; - resvwrd[8] := 'div '; ressymbol[8] := divsy; - resvwrd[9] := 'end '; ressymbol[9] := endsy; - resvwrd[10] := 'for '; ressymbol[10] := forsy; - resvwrd[11] := 'mod '; ressymbol[11] := modsy; - resvwrd[12] := 'nil '; ressymbol[12] := nilsy; - resvwrd[13] := 'not '; ressymbol[13] := notsy; - resvwrd[14] := 'set '; ressymbol[14] := setsy; - resvwrd[15] := 'var '; ressymbol[15] := varsy; - {resvwrd[16] := '*********'; ressymbol[16] := dummysy; } - resvwrd[17] := 'case '; ressymbol[17] := casesy; - resvwrd[18] := 'else '; ressymbol[18] := elsesy; - resvwrd[19] := 'file '; ressymbol[19] := filesy; - resvwrd[20] := 'goto '; ressymbol[20] := gotosy; - resvwrd[21] := 'then '; ressymbol[21] := thensy; - resvwrd[22] := 'type '; ressymbol[22] := typesy; - resvwrd[23] := 'with '; ressymbol[23] := withsy; - {resvwrd[24] := '*********'; ressymbol[24] := dummysy; } - {resvwrd[25] := '*********'; ressymbol[25] := dummysy; } - {resvwrd[26] := '*********'; ressymbol[26] := dummysy; } - {resvwrd[27] := '*********'; ressymbol[27] := dummysy; } - end {[s=1] init2resvwrd} ; - - - procedure init3resvwrd; - - begin {[s=2] initialize reserved word array} - {resvwrd[28] := '*********'; ressymbol[28] := dummysy; } - {resvwrd[29] := '*********'; ressymbol[29] := dummysy; } - {resvwrd[30] := '*********'; ressymbol[30] := dummysy; } - resvwrd[31] := 'array '; ressymbol[31] := arraysy; - resvwrd[32] := 'begin '; ressymbol[32] := beginsy; - resvwrd[33] := 'const '; ressymbol[33] := constsy; - resvwrd[34] := 'label '; ressymbol[34] := labelsy; - resvwrd[35] := 'until '; ressymbol[35] := untilsy; - resvwrd[36] := 'while '; ressymbol[36] := whilesy; - resvwrd[37] := 'downto '; ressymbol[37] := downtosy; - resvwrd[38] := 'modend '; ressymbol[38] := modendsy; - resvwrd[39] := 'module '; ressymbol[39] := modulesy; - resvwrd[40] := 'packed '; ressymbol[40] := packedsy; - resvwrd[41] := 'record '; ressymbol[41] := recordsy; - resvwrd[42] := 'repeat '; ressymbol[42] := repeatsy; - resvwrd[43] := 'string '; ressymbol[43] := stringsy; - {resvwrd[44] := '*********'; ressymbol[44] := dummysy; } - resvwrd[45] := 'forward '; ressymbol[45] := forwardsy; - resvwrd[46] := 'program '; ressymbol[46] := programsy; - resvwrd[47] := 'absolute '; ressymbol[47] := abslutesy; - resvwrd[48] := 'external '; ressymbol[48] := externsy; - resvwrd[49] := 'function '; ressymbol[49] := funcsy; - {resvwrd[50] := '*********'; ressymbol[50] := dummysy; } - resvwrd[51] := 'interrupt'; ressymbol[51] := intruptsy; - resvwrd[52] := 'otherwise'; ressymbol[52] := othwisesy; - resvwrd[53] := 'procedure'; ressymbol[53] := procsy; - end {[s=1] init3resvwrd} ; -{$p-----------* - | initialize | - *------------*} - - - procedure initialize; - - var - p: integer; - c: char; {induction var} - - begin {initialize all global variables} - linenumber := - 1; {not used in this version} - init1sets; - init2sets; - for c := chr(0) to chr(127) do - begin - lowercase[c] := c; - uppercase[c] := c; - end; - for c := 'A' to 'Z' do - begin - lowercase[c] := chr(ord(c) + ord('a') - ord('A')); - uppercase[chr(ord(c) + ord('a') - ord('A'))] := c; - end; - outlinelen := defaultoutline; - tabspaces := defaulttabspaces; - continuespaces := (tabspaces + 1) div 2; - comentspaces := defaultcomentspaces; - indentlevel := 0; - onehalfline := outlinelen div 2; - fiveeighthline := (5 * outlinelen) div 8; - threefourthline := (3 * outlinelen) div 4; - statsperline := 1; - for p := 1 to outlinelen do - symbol[p] := ' '; - symlen := 0; - indent := 0; - statindent := 0; - writecol := 0; - column := 0; - outputline := 1; - currentline := 0; - inputline := 1; - newinputline := true; - blankline := false; - charcount := 0; - sym := period; - symbolbreak := 0; - lastsym := period; - symwritten := false; - ch := ' '; - doubleperiod := false; - ucreswords := false {'R' in options} ; - ucidents := false {'U' in options} ; - litcopy := false {'L' in options} ; - portabilitymode := false {'P' in options} ; - bunching := false {'B' in options} ; - silentmode := false; {'Q' in options} ; - formatting := true; - newformatting := true; - overflows := 0; - comoverflows := 0; - init1resvwrd; - init2resvwrd; - init3resvwrd; - end {initialize} ; - -modend . - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PMINIT.SRC b/software/CPM/CPM22_MTPUG_10/PMINIT.SRC deleted file mode 100644 index ec26e02..0000000 --- a/software/CPM/CPM22_MTPUG_10/PMINIT.SRC +++ /dev/null @@ -1,220 +0,0 @@ -{*-----------------------* - | Pasmat Initialization | - *-----------------------*} -{$K0} {$K2} {$K7} {$K12} {$K13} {$K14} {$K15} -module pminit; - {$L-} - {$I PMDEFS.INC} - {$L+} -{$p-------------------------* - | Initialize Set Constants | - *--------------------------*} - - - procedure init1sets; - - begin {initialize set constants, part 1} - stdsyms := [abslutesy, andsy, arraysy, beginsy, casesy, constsy, - divsy, dosy, downtosy, elsesy, endsy, externsy, filesy, - forsy, forwardsy, funcsy, gotosy, ifsy, insy, - intruptsy, labelsy, modsy, modendsy, modulesy, nilsy, - notsy, ofsy, orsy, othwisesy, packedsy, procsy, - programsy, recordsy, repeatsy, setsy, stringsy, thensy, - tosy, typesy, untilsy, varsy, whilesy, withsy, plus, - minus, mult, divide, becomes, period, comma, semicolon, - colon, equal, notequal, lessthan, lessequal, - greatequal, greatthan, pointer, subrange, apostrophy, - openparen, closeparen, openbrack, closebrack, - identifier, number, stringcon, coment, textend, - dummysy]; - {constants used by putsym} - spacebefore := [abslutesy, andsy, divsy, dosy, downtosy, insy, - intruptsy, modsy, ofsy, orsy, thensy, tosy, plus, - minus, mult, divide, becomes, equal, notequal, - lessthan, lessequal, greatequal, greatthan]; - spaceafter := [abslutesy, andsy, arraysy, casesy, divsy, downtosy, - externsy, filesy, forsy, funcsy, gotosy, ifsy, insy, - intruptsy, modsy, modendsy, modulesy, notsy, ofsy, - orsy, othwisesy, packedsy, procsy, programsy, tosy, - untilsy, whilesy, withsy, plus, minus, mult, divide, - becomes, comma, semicolon, colon, equal, notequal, - lessthan, lessequal, greatequal, greatthan, coment]; - alphanumerics := [abslutesy..withsy, identifier, number]; - digits := ['0'..'9']; - letters := ['a'..'z', 'A'..'Z', '_', '@']; - progset := [programsy, modulesy]; - end {init1sets} ; - - - procedure init2sets; - - begin {initialize set constants, part 2} - headingbegsys := [labelsy, constsy, typesy, varsy, procsy, funcsy, - externsy]; - blockbegsys := headingbegsys + [beginsy]; - statset := [beginsy, ifsy, casesy, whilesy, repeatsy, forsy, - withsy, gotosy, number, identifier]; - cnstnts := [number, identifier, stringcon, plus, minus, nilsy]; - exprbegsys := cnstnts + [notsy, nilsy, openbrack, openparen]; - relops := [equal, notequal, lessthan, lessequal, greatthan, - greatequal, insy]; - arithops := [plus, minus, mult, divide, divsy, modsy]; - typebegsys := cnstnts + [pointer, setsy, recordsy, filesy, - arraysy, openparen, stringsy]; - validdirectives := ['b', 'B', 'c', 'C', 'f', 'F', 'l', 'L', 'o', - 'O', 'p', 'P', 'q', 'Q', 'r', 'R', 's', 'S', - 't', 'T', 'u', 'U']; - end {init2sets} ; -{$p--------------------------* - | initialize reserved words | - *---------------------------*} - - - procedure init1resvwrd; - - begin {[s=2] initialize reserved word length indices into reserved - word array for length keyed search} - reslen[2].lowindex := 1; reslen[2].hiindex := 6; - reslen[3].lowindex := 7; reslen[3].hiindex := 15; - reslen[4].lowindex := 17; reslen[4].hiindex := 23; - reslen[5].lowindex := 31; reslen[5].hiindex := 36; - reslen[6].lowindex := 37; reslen[6].hiindex := 43; - reslen[7].lowindex := 45; reslen[7].hiindex := 46; - reslen[8].lowindex := 47; reslen[8].hiindex := 49; - reslen[9].lowindex := 51; reslen[9].hiindex := 53; - end {[s=1] init1resvwrd} ; - - - procedure init2resvwrd; - - begin {[s=2] initialize reserved word array} - resvwrd[1] := 'do '; ressymbol[1] := dosy; - resvwrd[2] := 'if '; ressymbol[2] := ifsy; - resvwrd[3] := 'in '; ressymbol[3] := insy; - resvwrd[4] := 'of '; ressymbol[4] := ofsy; - resvwrd[5] := 'or '; ressymbol[5] := orsy; - resvwrd[6] := 'to '; ressymbol[6] := tosy; - resvwrd[7] := 'and '; ressymbol[7] := andsy; - resvwrd[8] := 'div '; ressymbol[8] := divsy; - resvwrd[9] := 'end '; ressymbol[9] := endsy; - resvwrd[10] := 'for '; ressymbol[10] := forsy; - resvwrd[11] := 'mod '; ressymbol[11] := modsy; - resvwrd[12] := 'nil '; ressymbol[12] := nilsy; - resvwrd[13] := 'not '; ressymbol[13] := notsy; - resvwrd[14] := 'set '; ressymbol[14] := setsy; - resvwrd[15] := 'var '; ressymbol[15] := varsy; - {resvwrd[16] := '*********'; ressymbol[16] := dummysy; } - resvwrd[17] := 'case '; ressymbol[17] := casesy; - resvwrd[18] := 'else '; ressymbol[18] := elsesy; - resvwrd[19] := 'file '; ressymbol[19] := filesy; - resvwrd[20] := 'goto '; ressymbol[20] := gotosy; - resvwrd[21] := 'then '; ressymbol[21] := thensy; - resvwrd[22] := 'type '; ressymbol[22] := typesy; - resvwrd[23] := 'with '; ressymbol[23] := withsy; - {resvwrd[24] := '*********'; ressymbol[24] := dummysy; } - {resvwrd[25] := '*********'; ressymbol[25] := dummysy; } - {resvwrd[26] := '*********'; ressymbol[26] := dummysy; } - {resvwrd[27] := '*********'; ressymbol[27] := dummysy; } - end {[s=1] init2resvwrd} ; - - - procedure init3resvwrd; - - begin {[s=2] initialize reserved word array} - {resvwrd[28] := '*********'; ressymbol[28] := dummysy; } - {resvwrd[29] := '*********'; ressymbol[29] := dummysy; } - {resvwrd[30] := '*********'; ressymbol[30] := dummysy; } - resvwrd[31] := 'array '; ressymbol[31] := arraysy; - resvwrd[32] := 'begin '; ressymbol[32] := beginsy; - resvwrd[33] := 'const '; ressymbol[33] := constsy; - resvwrd[34] := 'label '; ressymbol[34] := labelsy; - resvwrd[35] := 'until '; ressymbol[35] := untilsy; - resvwrd[36] := 'while '; ressymbol[36] := whilesy; - resvwrd[37] := 'downto '; ressymbol[37] := downtosy; - resvwrd[38] := 'modend '; ressymbol[38] := modendsy; - resvwrd[39] := 'module '; ressymbol[39] := modulesy; - resvwrd[40] := 'packed '; ressymbol[40] := packedsy; - resvwrd[41] := 'record '; ressymbol[41] := recordsy; - resvwrd[42] := 'repeat '; ressymbol[42] := repeatsy; - resvwrd[43] := 'string '; ressymbol[43] := stringsy; - {resvwrd[44] := '*********'; ressymbol[44] := dummysy; } - resvwrd[45] := 'forward '; ressymbol[45] := forwardsy; - resvwrd[46] := 'program '; ressymbol[46] := programsy; - resvwrd[47] := 'absolute '; ressymbol[47] := abslutesy; - resvwrd[48] := 'external '; ressymbol[48] := externsy; - resvwrd[49] := 'function '; ressymbol[49] := funcsy; - {resvwrd[50] := '*********'; ressymbol[50] := dummysy; } - resvwrd[51] := 'interrupt'; ressymbol[51] := intruptsy; - resvwrd[52] := 'otherwise'; ressymbol[52] := othwisesy; - resvwrd[53] := 'procedure'; ressymbol[53] := procsy; - end {[s=1] init3resvwrd} ; -{$p-----------* - | initialize | - *------------*} - - - procedure initialize; - - var - p: integer; - c: char; {induction var} - - begin {initialize all global variables} - linenumber := - 1; {not used in this version} - init1sets; - init2sets; - for c := chr(0) to chr(127) do - begin - lowercase[c] := c; - uppercase[c] := c; - end; - for c := 'A' to 'Z' do - begin - lowercase[c] := chr(ord(c) + ord('a') - ord('A')); - uppercase[chr(ord(c) + ord('a') - ord('A'))] := c; - end; - outlinelen := defaultoutline; - tabspaces := defaulttabspaces; - continuespaces := (tabspaces + 1) div 2; - comentspaces := defaultcomentspaces; - indentlevel := 0; - onehalfline := outlinelen div 2; - fiveeighthline := (5 * outlinelen) div 8; - threefourthline := (3 * outlinelen) div 4; - statsperline := 1; - for p := 1 to outlinelen do - symbol[p] := ' '; - symlen := 0; - indent := 0; - statindent := 0; - writecol := 0; - column := 0; - outputline := 1; - currentline := 0; - inputline := 1; - newinputline := true; - blankline := false; - charcount := 0; - sym := period; - symbolbreak := 0; - lastsym := period; - symwritten := false; - ch := ' '; - doubleperiod := false; - ucreswords := false {'R' in options} ; - ucidents := false {'U' in options} ; - litcopy := false {'L' in options} ; - portabilitymode := false {'P' in options} ; - bunching := false {'B' in options} ; - silentmode := false; {'Q' in options} ; - formatting := true; - newformatting := true; - overflows := 0; - comoverflows := 0; - init1resvwrd; - init2resvwrd; - init3resvwrd; - end {initialize} ; - -modend . - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PMPARSE.PAS b/software/CPM/CPM22_MTPUG_10/PMPARSE.PAS deleted file mode 100644 index 755eeb7..0000000 --- a/software/CPM/CPM22_MTPUG_10/PMPARSE.PAS +++ /dev/null @@ -1,1087 +0,0 @@ -{*---------------------------------* - | Pasmat Recursive Descent Parser | - *---------------------------------*} -{$K0} {$K2} {$K7} {$K12} {$K13} {$K14} {$K15} -(* {$S+} {$Q2} *) -module pmparse; - {$L-} - {$I PMDEFS.INC} - {$L+} - - external procedure abort(line: integer; - kind: abortkind); - external procedure bunch(start: collog; - var success: boolean); - external procedure bunchstatement(start: collog); - external procedure checksym(desired: symbols; - line: integer); - external procedure getsym; - external procedure indentplus(delta: integer; - line: integer); - external procedure logsymbolstart(var log: collog); - external procedure nextonnewline(spacing, delta: integer); - external procedure nextsym; - external procedure printline(indent: integer); - external procedure putsym; - external procedure setsymbolbreak; - external procedure space(n: integer); - external procedure undent; - -{$p----------------* - | Identifier list | - *-----------------*} - - - procedure identlist; - - begin {scan a list of identifiers separated by commas} - while sym = identifier do - begin - nextsym; - if sym = comma then - begin - nextsym; - setsymbolbreak; - end; - end; - end; {identlist} -{$p---------* - | Constant | - *----------*} - - - procedure cnstnt; - - begin {scan a constant} - if (sym = plus) or (sym = minus) then - nextsym; - if not (sym in (cnstnts - [plus, minus])) then - abort(linenumber, syntax); - nextsym; - end; {cnstnt} -{$p---------* - | Variable | - *----------*} - - - procedure variable; - - begin {scan off a variable, doesn't check much} - while sym in [identifier, period, pointer, openbrack] do - begin - if sym = openbrack then - begin - nextsym; - exprlist; - checksym(closebrack, linenumber); - end - else - nextsym; - end; - end; {variable} -{$p--------------* - | Constant list | - *---------------*} - - - procedure constlist; - - begin {scan a list of constants, as for case labels} - while sym in cnstnts do - begin - cnstnt; - if sym = comma then - begin - nextsym; - setsymbolbreak; - end; - end; - end; {constlist} -{$p-------* - | Factor | - *--------*} - - - procedure factor; - - begin {scan a factor in an expression, ignores precedence} - if sym = openparen then - begin - setsymbolbreak; - nextsym; - expression; - checksym(closeparen, linenumber); - end - else if sym = openbrack then - begin {set expression} - setsymbolbreak; - nextsym; - while sym in exprbegsys do - begin - exprlist; - if sym = subrange then - nextsym; - end; - checksym(closebrack, linenumber); - end - else if sym = identifier then - begin - variable; - if sym = openparen then - begin - if writecol <= threefourthline then - indentplus(writecol - indent, linenumber) - else - indentplus(0, linenumber); - nextsym; - exprlist; - checksym(closeparen, linenumber); - undent; - end - end - else - cnstnt; - end; {factor} -{$p-----------* - | Expression | - *------------*} - - - procedure expression; - - var - exprbroken: boolean; {break point already found} - - begin {scan an expression} - exprbroken := false; - while sym in exprbegsys do - begin - if sym in [plus, minus, notsy] then - nextsym; - if (sym = plus) or (sym = minus) or (sym = notsy) then - nextsym; - factor; - if (sym = andsy) or (sym = orsy) then - begin - nextsym; - setsymbolbreak; - exprbroken := true; - end - else if sym in relops then - begin - nextsym; - if not exprbroken and (writecol > fiveeighthline) then - begin - setsymbolbreak; - exprbroken := true; - end; - end - else if sym in arithops then - begin - nextsym; - if not exprbroken and (writecol > threefourthline) then - begin - setsymbolbreak; - exprbroken := true; - end; - end; - end; {while} - end; {expression} -{$p----------------* - | Expression list | - *-----------------*} - - - procedure exprlist; - - begin {scan a list of expressions} - while sym in exprbegsys do - begin - expression; - if (sym = comma) or (sym = colon) then - begin - nextsym; - setsymbolbreak; - end; - end; - end; {exprlist} -{$p--------------------------* - | Statement List (statlist) | - *---------------------------*} - - - procedure statlist; - - var - statterms: setofsyms; - statstart: collog; - firststat: boolean; - - begin {process a list of statements} - statterms := statset + [semicolon]; - firststat := true; - repeat - logsymbolstart(statstart); - statement; - {note: may or may not have semicolon} - if (sym = semicolon) and not symwritten then - putsym; - if (statsperline > 1) and not firststat then - bunchstatement(statstart); - {split like this so following comments don't screw up} - if sym = semicolon then - getsym; - firststat := false; - until not (sym in statterms); - end; {statelist} -{$p---------------------------* - | Compound statement (begin) | - *----------------------------*} - - - procedure dobegin(procblock: boolean); - - var - trim: integer; {amount to indent} - - begin {handle a begin - end block, indenting if requested by - setting procblock true} - if procblock then - trim := tabspaces - else - trim := 0; - nextonnewline(0, trim); - statlist; - undent; - printline(indent); - checksym(endsy, linenumber); - end; {dobegin} -{$p------------------------------* - | Assignment and Procedure Call | - *-------------------------------*} - - - procedure doassigncall; - - begin {either assignment or call} - printline(indent); - indentplus(continuespaces, linenumber); - variable; - if sym = becomes then - begin - nextsym; - if writecol < threefourthline then - indentplus(writecol - indent + 1, linenumber) - else - indentplus(0, linenumber); - expression; - undent; - end - else if sym = openparen then - begin - nextsym; - if writecol <= threefourthline then - indentplus(writecol - indent, linenumber) - else - indentplus(0, linenumber); - exprlist; - undent; - checksym(closeparen, linenumber); - end; - if sym = semicolon then - putsym; - undent; - end; {doassigncall} -{$p---------------* - | Goto statement | - *----------------*} - - - procedure dogoto; - - begin {goto statement} - printline(indent); - nextsym; - checksym(number, linenumber); - if sym = semicolon then - putsym; - end; {dogoto} -{$p----------------* - | While statement | - *-----------------*} - - - procedure dowhile; - - begin {while statement} - printline(indent); - nextsym; - if writecol < threefourthline then - indentplus(writecol - indent + 1, linenumber) - else - indentplus(continuespaces, linenumber); - expression; - checksym(dosy, linenumber); - undent; - indentplus(tabspaces, linenumber); - statindent := indent; - statement; - undent; - end; {dowhile} -{$p---------------* - | With statement | - *----------------*} - - - procedure dowith; - - begin {withstatement} - printline(indent); - nextsym; - if writecol < threefourthline then - indentplus(writecol - indent + 1, linenumber) - else - indentplus(continuespaces, linenumber); - exprlist; - checksym(dosy, linenumber); - undent; - indentplus(tabspaces, linenumber); - statindent := indent; - statement; - undent; - end; {dowith} -{$p-------------* - | If statement | - *--------------*} - - - procedure doif(prevelse: boolean {set if previous sym was else} ); - - var - ifstart: collog; {start of if statement} - startline, endline: integer; {statement lines} - successful: boolean; {bunching went} - - begin {if statement} - if not prevelse then - printline(indent); - nextsym; - if writecol < threefourthline then - indentplus(writecol - indent + 1, linenumber) - else - indentplus(continuespaces, linenumber); - startline := currentline; - expression; - checksym(thensy, linenumber); - undent; - indentplus(tabspaces, linenumber); - endline := currentline; - logsymbolstart(ifstart); - statement; - if bunching and (startline = endline) then - bunch(ifstart, successful); - undent; - statindent := indent; - if sym = elsesy then - begin - printline(indent); - nextsym; - if sym = ifsy then - doif(true) - else - begin - indentplus(tabspaces, linenumber); - logsymbolstart(ifstart); - statement; - if bunching then - bunch(ifstart, successful); - undent; - end; - end; - end; {doif} -{$p---------------* - | Case statement | - *----------------*} - - - procedure docase; - - var - casestart: collog; {start of case} - successful: boolean; {bunching successful} - labstart, labend: integer; {label list lines} - - begin {casestatement} - printline(indent); - nextsym; - if writecol < threefourthline then - indentplus(writecol - indent + 1, linenumber) - else - indentplus(continuespaces, linenumber); - expression; - checksym(ofsy, linenumber); - undent; - indentplus(tabspaces, linenumber); - statindent := indent; - while not (sym in [endsy, elsesy, othwisesy]) do - begin - if sym in cnstnts then - begin - printline(indent); - labstart := currentline; - constlist; - checksym(colon, linenumber); - labend := currentline; - indentplus(tabspaces, linenumber); - logsymbolstart(casestart); - statement; - if bunching and (labstart = labend) then - bunch(casestart, successful); - undent; - statindent := indent; - end; {if sym in constants} - if sym = semicolon then - nextsym; - if not (sym in (cnstnts + [endsy, semicolon, elsesy, - othwisesy])) then - abort(linenumber, syntax); - end; {while} - if (sym = othwisesy) or (sym = elsesy) then - begin - nextonnewline(0, tabspaces); - statlist; - undent; - end; - printline(indent); - checksym(endsy, linenumber); - undent; - end; {docase} -{$p-----------------* - | Repeat statement | - *------------------*} - - - procedure dorepeat; - - begin {repeat statement} - nextonnewline(0, tabspaces); - statlist; - undent; - statindent := indent; - printline(indent); - checksym(untilsy, linenumber); - if writecol < threefourthline then - indentplus(writecol - indent + 1, linenumber) - else - indentplus(continuespaces, linenumber); - expression; - if sym = semicolon then - putsym; - undent; - end; {dorepeat} -{$p--------------* - | For statement | - *---------------*} - - - procedure dofor; - - begin {for statement} - nextonnewline(0, continuespaces); - checksym(identifier, linenumber); - checksym(becomes, linenumber); - expression; - if (sym <> tosy) and (sym <> downtosy) then - abort(linenumber, syntax); - nextsym; - expression; - checksym(dosy, linenumber); - undent; - indentplus(tabspaces, linenumber); - statement; - undent; - end; {dofor} -{$p----------* - | Statement | - *-----------*} - - - procedure statement; - - begin {handle a (possibly empty) statement} - statindent := indent; - if sym = number then - begin - indentplus( - tabspaces, linenumber); - printline(indent); - nextsym; - checksym(colon, linenumber); - undent; - end; - if sym in (statset - [number]) then - case sym of - beginsy: - dobegin(false); - casesy: - docase; - forsy: - dofor; - gotosy: - dogoto; - identifier: - doassigncall; - ifsy: - doif(false); - repeatsy: - dorepeat; - whilesy: - dowhile; - withsy: - dowith; - end; {case} - statindent := indent; - end; {statement} -{$p----------------------* - | Formal Parameter List | - *-----------------------*} - - - procedure parameters; - - begin {format a formal parameter list: if they start less than - halfway across the page, they are all lined up with the - first parameter, on successive lines. If they start more - than halfway across the page, they begin on the next line, - indented double the usual (arbitrary)} - if writecol > onehalfline then - printline(indent + 2 * tabspaces); - nextsym; - indentplus(writecol - indent, linenumber); - while sym in [identifier, funcsy, procsy, varsy] do - begin - if sym <> identifier then - nextsym; - if sym <> identifier then - abort(linenumber, syntax); - indentplus(continuespaces, linenumber); - identlist; - undent; - if sym = colon then - begin {not proc or func} - nextsym; - if sym = stringsy then - stringtype {overly permissive} - else if sym = arraysy then - arraytype {overly permissive} - else - checksym(identifier, linenumber) - end; - if sym = semicolon then - begin - nextsym; - printline(indent); - end; - end; - checksym(closeparen, linenumber); - undent; - end; {parameters} -{$p-----------* - | Field list | - *------------*} - - - procedure fieldlist; - - var - invarpart: boolean; {true if there was an invarient part} - - begin {scan field list of type specification } - invarpart := false; - while sym = identifier do - begin - invarpart := true; - indentplus(continuespaces, linenumber); - identlist; - checksym(colon, linenumber); - undent; - scantype; - if sym = semicolon then - nextsym; - if sym = identifier then - printline(indent); - end; - if sym = casesy then - begin {case} - if invarpart then - printline(indent); - nextsym; - indentplus(continuespaces, linenumber); - checksym(identifier, linenumber); - if sym = colon then - begin - nextsym; - checksym(identifier, linenumber); - end; - checksym(ofsy, linenumber); - undent; - indentplus(tabspaces, linenumber); - statindent := indent; - printline(indent); - repeat {variant part} - constlist; - checksym(colon, linenumber); - indentplus(tabspaces, linenumber); - statindent := indent; - printline(indent); - checksym(openparen, linenumber); - indentplus(1, linenumber); {compensate for paren} - fieldlist; - undent; - checksym(closeparen, linenumber); - undent; - statindent := indent; - if sym = semicolon then - nextsym; - if (sym <> endsy) and (sym <> closeparen) then - printline(indent); - until not (sym in cnstnts); - undent; - statindent := indent; - end {case} - end; {fieldlist} -{$p------------* - | Record type | - *-------------*} - - - procedure recordtype(packedstart: collog); - - begin {handle a record type, includes a kluge to move "packed" down - to the next line} - indentplus(tabspaces, linenumber); - with packedstart do - if formatting and (logchar <> 0) and (charcount - - logchar < bufsize) then - with unwritten[logchar mod bufsize] do - begin {note that this kluge assumes the logged point has - become a space so it can be changed to a newline} - actionis := beginline; - spacing := indent; - writecol := indent + writecol - logcol; - currentline := currentline + 1; - end - else - printline(indent); - nextsym; - indentplus(tabspaces, linenumber); - statindent := indent; - printline(indent); - fieldlist; - undent; - printline(indent); - checksym(endsy, linenumber); - undent; - end; {recordtype} -{$p-----------* - | Array type | - *------------*} - - - procedure arraytype; - - begin {format an array type} - indentplus(tabspaces, linenumber); - nextsym; - setsymbolbreak; - checksym(openbrack, linenumber); - while sym in cnstnts do - begin - cnstnt; - if sym = subrange then - begin - nextsym; - cnstnt; - end; - if sym = colon then - begin {for conformant arrays} - nextsym; - checksym(identifier, linenumber) - end; - if sym = comma then - begin - nextsym; - setsymbolbreak; - end; - end; {while} - checksym(closebrack, linenumber); - checksym(ofsy, linenumber); - scantype; - undent; - end; {arraytype} -{$P------------* - | String type | - *-------------*} - - - procedure stringtype; - - begin {format a string type} - nextsym; - if sym = openbrack then - begin {optional size '[n]'} - nextsym; - cnstnt; - checksym(closebrack, linenumber) - end - end; -{$p-----------------* - | Enumeration type | - *------------------*} - - - procedure enumtype; - - begin {handle an enumeration type, align to the right of the - opening parenthesis if there is room, otherwise use normal - continuation} - nextsym; - if writecol <= threefourthline then - indentplus(writecol - indent, linenumber) - else - indentplus(continuespaces, linenumber); - identlist; - checksym(closeparen, linenumber); - undent; - end; {enumtype} -{$p----------* - | Scan type | - *-----------*} - - - procedure scantype; - - var - packedstart: collog; - - begin {scan a type, formatting differs for each one} - indentplus(continuespaces, linenumber); - if sym = externsy then - nextsym - else if sym = abslutesy then - begin {absolute [ nnn ] or absolute [ nnn : mmm ]} - nextsym; - checksym(openbrack, linenumber); - cnstnt; - if sym = colon then - begin - nextsym; - cnstnt - end; - checksym(closebrack, linenumber); - space(1); - end; - if sym = packedsy then - begin {mark start of 'packed' - must actually be a space} - logsymbolstart(packedstart); - nextsym - end - else - packedstart.logchar := 0; - undent; - if not (sym in typebegsys) then - abort(linenumber, syntax); - case sym of - openparen: - enumtype; - arraysy: - arraytype; - stringsy: - stringtype; - filesy: - begin - nextsym; {untyped file is ok} - if sym = ofsy then - begin - nextsym; - scantype - end - end; - setsy: - begin - nextsym; - checksym(ofsy, linenumber); - scantype - end; - identifier, number, plus, minus, stringcon: - begin {simple or subrange} - cnstnt; - if sym = subrange then - begin - nextsym; - cnstnt; - end; - end; - pointer: - begin - nextsym; - scantype; - end; - recordsy: - recordtype(packedstart); - end; {case} - statindent := indent; - end; {scantype} -{$p------------------* - | Label Declaration | - *-------------------*} - - - procedure dolabel; - - begin {label declaration} - nextonnewline(1, tabspaces); - printline(indent); - while sym = number do - begin - nextsym; - if sym = comma then - nextsym; - end; {while} - checksym(semicolon, linenumber); - undent; - statindent := indent; - end; {dolabel} -{$p---------------------* - | Constant Declaration | - *----------------------*} - - - procedure doconst; - - var - conststart: collog; {start of particular declaration} - firstconst: boolean; {first constant in decl} - - begin {constant declaration} - nextonnewline(1, tabspaces); - firstconst := true; - while sym = identifier do - begin - logsymbolstart(conststart); - printline(indent); - nextsym; - checksym(equal, linenumber); - cnstnt; - if sym = semicolon then - putsym - else - abort(linenumber, syntax); - if (statsperline > 1) and not firstconst then - bunchstatement(conststart); - nextsym; {split so comments format right} - firstconst := false; - end; {while} - undent; - statindent := indent; - end; {doconst} -{$p-----------------* - | Type Declaration | - *------------------*} - - - procedure dotype; - - begin {typedeclaration} - nextonnewline(1, tabspaces); - while sym = identifier do - begin - printline(indent); - nextsym; - checksym(equal, linenumber); - scantype; - checksym(semicolon, linenumber); - end; {while} - undent; - statindent := indent; - end; {dotype} -{$p----------------* - | Var Declaration | - *-----------------*} - - - procedure dovar; - - begin {var declaration} - nextonnewline(1, tabspaces); - while (sym = identifier) do - begin - printline(indent); - indentplus(continuespaces, linenumber); - if sym <> identifier then - abort(linenumber, syntax); - identlist; - checksym(colon, linenumber); - undent; - scantype; - checksym(semicolon, linenumber); - end; {while} - undent; - statindent := indent; - end; {dovar} -{$P---------------------------* - | Procedure/Function Heading | - *----------------------------*} - - - procedure doprochead; - - var - startsym: symbols; - - begin {process procedure or function heading} - if sym = externsy then - begin {optional 'external'} - nextonnewline(0, continuespaces); - if sym = openbrack then {optional '[n]'} - begin - nextsym; - cnstnt; - checksym(closebrack, linenumber) - end; - startsym := sym; - nextsym - end - else - begin - startsym := sym; - nextonnewline(2, continuespaces) - end; - if sym = intruptsy then - begin {optional 'interrupt [n]'} - nextsym; - checksym(openbrack, linenumber); - cnstnt; - checksym(closebrack, linenumber); - space(1) - end; - checksym(identifier, linenumber); - if sym = openparen then - parameters; - if startsym = funcsy then - begin - checksym(colon, linenumber); - checksym(identifier, linenumber) - end; - checksym(semicolon, linenumber); - undent; - end; - -{$p----------------------* - | Procedure Declaration | - *-----------------------*} - - - procedure doprocedure; - - begin {procedure} - doprochead; - indentplus(tabspaces, linenumber); - if sym = forwardsy then - begin - printline(indent); - nextsym; - end - else if sym in blockbegsys then - doblock - else - abort(linenumber, syntax); - if sym = semicolon then - begin - putsym; - undent; - statindent := indent; - nextsym; - end - else - abort(linenumber, syntax); - end; {doprocedure} -{$p--------* - | Program | - *---------*} - - - procedure doprogram; - - var - doingmodule: boolean; {this is a module} - - begin {program or module} - doingmodule := (sym = modulesy); - nextonnewline(0, continuespaces); - checksym(identifier, linenumber); - if sym = openparen then - begin - nextsym; - while sym = identifier do - begin - nextsym; - if sym = comma then - begin - nextsym; - setsymbolbreak; - end; - end; - checksym(closeparen, linenumber); - end; - checksym(semicolon, linenumber); - undent; - indentplus(tabspaces, linenumber); - doblock; - undent; - if doingmodule then - begin - if sym = semicolon then - nextsym; - if sym = modendsy then - nextonnewline(1, indent) - else - abort(linenumber, syntax); - end {final end for module} ; - checksym(period, linenumber); - end; {doprogram} -{$p------* - | Block | - *-------*} - - - procedure doblock; - - begin {scan a block, including types, etc} - statindent := indent; - while sym in headingbegsys do - begin {declarations} - case sym of - labelsy: - dolabel; - constsy: - doconst; - typesy: - dotype; - varsy: - dovar; - procsy, funcsy: - doprocedure; - externsy: - doprochead; - end; {case} - statindent := indent; - end; {while} - if sym = beginsy then - begin - blankline := true; - dobegin(true); - end; - end; {doblock} - -modend . - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/PMPARSE.SRC b/software/CPM/CPM22_MTPUG_10/PMPARSE.SRC deleted file mode 100644 index 7179989..0000000 --- a/software/CPM/CPM22_MTPUG_10/PMPARSE.SRC +++ /dev/null @@ -1,1082 +0,0 @@ -{*---------------------------------* - | Pasmat Recursive Descent Parser | - *---------------------------------*} -{$K0} {$K2} {$K7} {$K12} {$K13} {$K14} {$K15} -{$S+} {$Q2} -module pmparse; - {$L-} - {$I PMDEFS.INC} - {$L+} - - external procedure abort(line: integer; - kind: abortkind); - external procedure bunch(start: collog; - var success: boolean); - external procedure bunchstatement(start: collog); - external procedure checksym(desired: symbols; - line: integer); - external procedure getsym; - external procedure indentplus(delta: integer; - line: integer); - external procedure logsymbolstart(var log: collog); - external procedure nextonnewline(spacing, delta: integer); - external procedure nextsym; - external procedure printline(indent: integer); - external procedure putsym; - external procedure setsymbolbreak; - external procedure space(n: integer); - external procedure undent; - -{$p----------------* - | Identifier list | - *-----------------*} - - - procedure identlist; - - begin {scan a list of identifiers separated by commas} - while sym = identifier do - begin - nextsym; - if sym = comma then - begin - nextsym; - setsymbolbreak; - end; - end; - end; {identlist} -{$p---------* - | Constant | - *----------*} - - - procedure cnstnt; - - begin {scan a constant} - if (sym = plus) or (sym = minus) then - nextsym; - if not (sym in (cnstnts - [plus, minus])) then - abort(linenumber, syntax); - nextsym; - end; {cnstnt} -{$p---------* - | Variable | - *----------*} - - - procedure variable; - - begin {scan off a variable, doesn't check much} - while sym in [identifier, period, pointer, openbrack] do - begin - if sym = openbrack then - begin - nextsym; - exprlist; - checksym(closebrack, linenumber); - end - else - nextsym; - end; - end; {variable} -{$p--------------* - | Constant list | - *---------------*} - - - procedure constlist; - - begin {scan a list of constants, as for case labels} - while sym in cnstnts do - begin - cnstnt; - if sym = comma then - begin - nextsym; - setsymbolbreak; - end; - end; - end; {constlist} -{$p-------* - | Factor | - *--------*} - - - procedure factor; - - begin {scan a factor in an expression, ignores precedence} - if sym = openparen then - begin - setsymbolbreak; - nextsym; - expression; - checksym(closeparen, linenumber); - end - else if sym = openbrack then - begin {set expression} - setsymbolbreak; - nextsym; - while sym in exprbegsys do - begin - exprlist; - if sym = subrange then - nextsym; - end; - checksym(closebrack, linenumber); - end - else if sym = identifier then - begin - variable; - if sym = openparen then - begin - if writecol <= threefourthline then - indentplus(writecol - indent, linenumber) - else - indentplus(0, linenumber); - nextsym; - exprlist; - checksym(closeparen, linenumber); - undent; - end - end - else - cnstnt; - end; {factor} -{$p-----------* - | Expression | - *------------*} - - - procedure expression; - - var - exprbroken: boolean; {break point already found} - - begin {scan an expression} - exprbroken := false; - while sym in exprbegsys do - begin - if sym in [plus, minus, notsy] then - nextsym; - if (sym = plus) or (sym = minus) or (sym = notsy) then - nextsym; - factor; - if (sym = andsy) or (sym = orsy) then - begin - nextsym; - setsymbolbreak; - exprbroken := true; - end - else if sym in relops then - begin - nextsym; - if not exprbroken and (writecol > fiveeighthline) then - begin - setsymbolbreak; - exprbroken := true; - end; - end - else if sym in arithops then - begin - nextsym; - if not exprbroken and (writecol > threefourthline) then - begin - setsymbolbreak; - exprbroken := true; - end; - end; - end; {while} - end; {expression} -{$p----------------* - | Expression list | - *-----------------*} - - - procedure exprlist; - - begin {scan a list of expressions} - while sym in exprbegsys do - begin - expression; - if (sym = comma) or (sym = colon) then - begin - nextsym; - setsymbolbreak; - end; - end; - end; {exprlist} -{$p--------------------------* - | Statement List (statlist) | - *---------------------------*} - - - procedure statlist; - - var - statterms: setofsyms; - statstart: collog; - firststat: boolean; - - begin {process a list of statements} - statterms := statset + [semicolon]; - firststat := true; - repeat - logsymbolstart(statstart); - statement; - {note: may or may not have semicolon} - if (sym = semicolon) and not symwritten then - putsym; - if (statsperline > 1) and not firststat then - bunchstatement(statstart); - {split like this so following comments don't screw up} - if sym = semicolon then - getsym; - firststat := false; - until not (sym in statterms); - end; {statelist} -{$p---------------------------* - | Compound statement (begin) | - *----------------------------*} - - - procedure dobegin(procblock: boolean); - - var - trim: integer; {amount to indent} - - begin {handle a begin - end block, indenting if requested by - setting procblock true} - if procblock then - trim := tabspaces - else - trim := 0; - nextonnewline(0, trim); - statlist; - undent; - printline(indent); - checksym(endsy, linenumber); - end; {dobegin} -{$p------------------------------* - | Assignment and Procedure Call | - *-------------------------------*} - - - procedure doassigncall; - - begin {either assignment or call} - printline(indent); - indentplus(continuespaces, linenumber); - variable; - if sym = becomes then - begin - nextsym; - if writecol < threefourthline then - indentplus(writecol - indent + 1, linenumber) - else - indentplus(0, linenumber); - expression; - undent; - end - else if sym = openparen then - begin - nextsym; - if writecol <= threefourthline then - indentplus(writecol - indent, linenumber) - else - indentplus(0, linenumber); - exprlist; - undent; - checksym(closeparen, linenumber); - end; - if sym = semicolon then - putsym; - undent; - end; {doassigncall} -{$p---------------* - | Goto statement | - *----------------*} - - - procedure dogoto; - - begin {goto statement} - printline(indent); - nextsym; - checksym(number, linenumber); - if sym = semicolon then - putsym; - end; {dogoto} -{$p----------------* - | While statement | - *-----------------*} - - - procedure dowhile; - - begin {while statement} - printline(indent); - nextsym; - if writecol < threefourthline then - indentplus(writecol - indent + 1, linenumber) - else - indentplus(continuespaces, linenumber); - expression; - checksym(dosy, linenumber); - undent; - indentplus(tabspaces, linenumber); - statindent := indent; - statement; - undent; - end; {dowhile} -{$p---------------* - | With statement | - *----------------*} - - - procedure dowith; - - begin {withstatement} - printline(indent); - nextsym; - if writecol < threefourthline then - indentplus(writecol - indent + 1, linenumber) - else - indentplus(continuespaces, linenumber); - exprlist; - checksym(dosy, linenumber); - undent; - indentplus(tabspaces, linenumber); - statindent := indent; - statement; - undent; - end; {dowith} -{$p-------------* - | If statement | - *--------------*} - - - procedure doif(prevelse: boolean {set if previous sym was else} ); - - var - ifstart: collog; {start of if statement} - startline, endline: integer; {statement lines} - successful: boolean; {bunching went} - - begin {if statement} - if not prevelse then - printline(indent); - nextsym; - if writecol < threefourthline then - indentplus(writecol - indent + 1, linenumber) - else - indentplus(continuespaces, linenumber); - startline := currentline; - expression; - checksym(thensy, linenumber); - undent; - indentplus(tabspaces, linenumber); - endline := currentline; - logsymbolstart(ifstart); - statement; - if bunching and (startline = endline) then - bunch(ifstart, successful); - undent; - statindent := indent; - if sym = elsesy then - begin - printline(indent); - nextsym; - if sym = ifsy then - doif(true) - else - begin - indentplus(tabspaces, linenumber); - logsymbolstart(ifstart); - statement; - if bunching then - bunch(ifstart, successful); - undent; - end; - end; - end; {doif} -{$p---------------* - | Case statement | - *----------------*} - - - procedure docase; - - var - casestart: collog; {start of case} - successful: boolean; {bunching successful} - labstart, labend: integer; {label list lines} - - begin {casestatement} - printline(indent); - nextsym; - if writecol < threefourthline then - indentplus(writecol - indent + 1, linenumber) - else - indentplus(continuespaces, linenumber); - expression; - checksym(ofsy, linenumber); - undent; - indentplus(tabspaces, linenumber); - statindent := indent; - while not (sym in [endsy, elsesy, othwisesy]) do - begin - if sym in cnstnts then - begin - printline(indent); - labstart := currentline; - constlist; - checksym(colon, linenumber); - labend := currentline; - indentplus(tabspaces, linenumber); - logsymbolstart(casestart); - statement; - if bunching and (labstart = labend) then - bunch(casestart, successful); - undent; - statindent := indent; - end; {if sym in constants} - if sym = semicolon then - nextsym; - if not (sym in (cnstnts + [endsy, semicolon, elsesy, - othwisesy])) then - abort(linenumber, syntax); - end; {while} - if (sym = othwisesy) or (sym = elsesy) then - begin - nextonnewline(0, tabspaces); - statlist; - undent; - end; - printline(indent); - checksym(endsy, linenumber); - undent; - end; {docase} -{$p-----------------* - | Repeat statement | - *------------------*} - - - procedure dorepeat; - - begin {repeat statement} - nextonnewline(0, tabspaces); - statlist; - undent; - statindent := indent; - printline(indent); - checksym(untilsy, linenumber); - if writecol < threefourthline then - indentplus(writecol - indent + 1, linenumber) - else - indentplus(continuespaces, linenumber); - expression; - if sym = semicolon then - putsym; - undent; - end; {dorepeat} -{$p--------------* - | For statement | - *---------------*} - - - procedure dofor; - - begin {for statement} - nextonnewline(0, continuespaces); - checksym(identifier, linenumber); - checksym(becomes, linenumber); - expression; - if (sym <> tosy) and (sym <> downtosy) then - abort(linenumber, syntax); - nextsym; - expression; - checksym(dosy, linenumber); - undent; - indentplus(tabspaces, linenumber); - statement; - undent; - end; {dofor} -{$p----------* - | Statement | - *-----------*} - - - procedure statement; - - begin {handle a (possibly empty) statement} - statindent := indent; - if sym = number then - begin - indentplus( - tabspaces, linenumber); - printline(indent); - nextsym; - checksym(colon, linenumber); - undent; - end; - if sym in (statset - [number]) then - case sym of - beginsy: - dobegin(false); - casesy: - docase; - forsy: - dofor; - gotosy: - dogoto; - identifier: - doassigncall; - ifsy: - doif(false); - repeatsy: - dorepeat; - whilesy: - dowhile; - withsy: - dowith; - end; {case} - statindent := indent; - end; {statement} -{$p----------------------* - | Formal Parameter List | - *-----------------------*} - - - procedure parameters; - - begin {format a formal parameter list: if they start less than - halfway across the page, they are all lined up with the - first parameter, on successive lines. If they start more - than halfway across the page, they begin on the next line, - indented double the usual (arbitrary)} - if writecol > onehalfline then - printline(indent + 2 * tabspaces); - nextsym; - indentplus(writecol - indent, linenumber); - while sym in [identifier, funcsy, procsy, varsy] do - begin - if sym <> identifier then - nextsym; - if sym <> identifier then - abort(linenumber, syntax); - indentplus(continuespaces, linenumber); - identlist; - undent; - if sym = colon then - begin {not proc or func} - nextsym; - if sym = stringsy then - stringtype {overly permissive} - else if sym = arraysy then - arraytype {overly permissive} - else - checksym(identifier, linenumber) - end; - if sym = semicolon then - begin - nextsym; - printline(indent); - end; - end; - checksym(closeparen, linenumber); - undent; - end; {parameters} -{$p-----------* - | Field list | - *------------*} - - - procedure fieldlist; - - var - invarpart: boolean; {true if there was an invarient part} - - begin {scan field list of type specification } - invarpart := false; - while sym = identifier do - begin - invarpart := true; - indentplus(continuespaces, linenumber); - identlist; - checksym(colon, linenumber); - undent; - scantype; - if sym = semicolon then - nextsym; - if sym = identifier then - printline(indent); - end; - if sym = casesy then - begin {case} - if invarpart then - printline(indent); - nextsym; - indentplus(continuespaces, linenumber); - checksym(identifier, linenumber); - if sym = colon then - begin - nextsym; - checksym(identifier, linenumber); - end; - checksym(ofsy, linenumber); - undent; - indentplus(tabspaces, linenumber); - statindent := indent; - printline(indent); - repeat {variant part} - constlist; - checksym(colon, linenumber); - indentplus(tabspaces, linenumber); - statindent := indent; - printline(indent); - checksym(openparen, linenumber); - indentplus(1, linenumber); {compensate for paren} - fieldlist; - undent; - checksym(closeparen, linenumber); - undent; - statindent := indent; - if sym = semicolon then - nextsym; - if (sym <> endsy) and (sym <> closeparen) then - printline(indent); - until not (sym in cnstnts); - undent; - statindent := indent; - end {case} - end; {fieldlist} -{$p------------* - | Record type | - *-------------*} - - - procedure recordtype(packedstart: collog); - - begin {handle a record type, includes a kluge to move "packed" down - to the next line} - indentplus(tabspaces, linenumber); - with packedstart do - if formatting and (logchar <> 0) and (charcount - - logchar < bufsize) then - with unwritten[logchar mod bufsize] do - begin {note that this kluge assumes the logged point has - become a space so it can be changed to a newline} - actionis := beginline; - spacing := indent; - writecol := indent + writecol - logcol; - currentline := currentline + 1; - end - else - printline(indent); - nextsym; - indentplus(tabspaces, linenumber); - statindent := indent; - printline(indent); - fieldlist; - undent; - printline(indent); - checksym(endsy, linenumber); - undent; - end; {recordtype} -{$p-----------* - | Array type | - *------------*} - - - procedure arraytype; - - begin {format an array type} - indentplus(tabspaces, linenumber); - nextsym; - setsymbolbreak; - checksym(openbrack, linenumber); - while sym in cnstnts do - begin - cnstnt; - if sym = subrange then - begin - nextsym; - cnstnt; - end; - if sym = colon then - begin {for conformant arrays} - nextsym; - checksym(identifier, linenumber) - end; - if sym = comma then - begin - nextsym; - setsymbolbreak; - end; - end; {while} - checksym(closebrack, linenumber); - checksym(ofsy, linenumber); - scantype; - undent; - end; {arraytype} -{$P------------* - | String type | - *-------------*} - - - procedure stringtype; - - begin {format a string type} - nextsym; - if sym = openbrack then - begin {optional size '[n]'} - nextsym; - cnstnt; - checksym(closebrack, linenumber) - end - end; -{$p-----------------* - | Enumeration type | - *------------------*} - - - procedure enumtype; - - begin {handle an enumeration type, align to the right of the - opening parenthesis if there is room, otherwise use normal - continuation} - nextsym; - if writecol <= threefourthline then - indentplus(writecol - indent, linenumber) - else - indentplus(continuespaces, linenumber); - identlist; - checksym(closeparen, linenumber); - undent; - end; {enumtype} -{$p----------* - | Scan type | - *-----------*} - - - procedure scantype; - - var - packedstart: collog; - - begin {scan a type, formatting differs for each one} - indentplus(continuespaces, linenumber); - if sym = externsy then - nextsym - else if sym = abslutesy then - begin - nextsym; - checksym(openbrack, linenumber); - cnstnt; - checksym(closebrack, linenumber); - space(1); - end; - if sym = packedsy then - begin {mark start of 'packed' - must actually be a space} - logsymbolstart(packedstart); - nextsym - end - else - packedstart.logchar := 0; - undent; - if not (sym in typebegsys) then - abort(linenumber, syntax); - case sym of - openparen: - enumtype; - arraysy: - arraytype; - stringsy: - stringtype; - filesy: - begin - nextsym; {untyped file is ok} - if sym = ofsy then - begin - nextsym; - scantype - end - end; - setsy: - begin - nextsym; - checksym(ofsy, linenumber); - scantype - end; - identifier, number, plus, minus, stringcon: - begin {simple or subrange} - cnstnt; - if sym = subrange then - begin - nextsym; - cnstnt; - end; - end; - pointer: - begin - nextsym; - scantype; - end; - recordsy: - recordtype(packedstart); - end; {case} - statindent := indent; - end; {scantype} -{$p------------------* - | Label Declaration | - *-------------------*} - - - procedure dolabel; - - begin {label declaration} - nextonnewline(1, tabspaces); - printline(indent); - while sym = number do - begin - nextsym; - if sym = comma then - nextsym; - end; {while} - checksym(semicolon, linenumber); - undent; - statindent := indent; - end; {dolabel} -{$p---------------------* - | Constant Declaration | - *----------------------*} - - - procedure doconst; - - var - conststart: collog; {start of particular declaration} - firstconst: boolean; {first constant in decl} - - begin {constant declaration} - nextonnewline(1, tabspaces); - firstconst := true; - while sym = identifier do - begin - logsymbolstart(conststart); - printline(indent); - nextsym; - checksym(equal, linenumber); - cnstnt; - if sym = semicolon then - putsym - else - abort(linenumber, syntax); - if (statsperline > 1) and not firstconst then - bunchstatement(conststart); - nextsym; {split so comments format right} - firstconst := false; - end; {while} - undent; - statindent := indent; - end; {doconst} -{$p-----------------* - | Type Declaration | - *------------------*} - - - procedure dotype; - - begin {typedeclaration} - nextonnewline(1, tabspaces); - while sym = identifier do - begin - printline(indent); - nextsym; - checksym(equal, linenumber); - scantype; - checksym(semicolon, linenumber); - end; {while} - undent; - statindent := indent; - end; {dotype} -{$p----------------* - | Var Declaration | - *-----------------*} - - - procedure dovar; - - begin {var declaration} - nextonnewline(1, tabspaces); - while (sym = identifier) do - begin - printline(indent); - indentplus(continuespaces, linenumber); - if sym <> identifier then - abort(linenumber, syntax); - identlist; - checksym(colon, linenumber); - undent; - scantype; - checksym(semicolon, linenumber); - end; {while} - undent; - statindent := indent; - end; {dovar} -{$P---------------------------* - | Procedure/Function Heading | - *----------------------------*} - - - procedure doprochead; - - var - startsym: symbols; - - begin {process procedure or function heading} - if sym = externsy then - begin {optional 'external'} - nextonnewline(0, continuespaces); - if sym = openbrack then {optional '[n]'} - begin - nextsym; - cnstnt; - checksym(closebrack, linenumber) - end; - startsym := sym; - nextsym - end - else - begin - startsym := sym; - nextonnewline(2, continuespaces) - end; - if sym = intruptsy then - begin {optional 'interrupt [n]'} - nextsym; - checksym(openbrack, linenumber); - cnstnt; - checksym(closebrack, linenumber); - space(1) - end; - checksym(identifier, linenumber); - if sym = openparen then - parameters; - if startsym = funcsy then - begin - checksym(colon, linenumber); - checksym(identifier, linenumber) - end; - checksym(semicolon, linenumber); - undent; - end; - -{$p----------------------* - | Procedure Declaration | - *-----------------------*} - - - procedure doprocedure; - - begin {procedure} - doprochead; - indentplus(tabspaces, linenumber); - if sym = forwardsy then - begin - printline(indent); - nextsym; - end - else if sym in blockbegsys then - doblock - else - abort(linenumber, syntax); - if sym = semicolon then - begin - putsym; - undent; - statindent := indent; - nextsym; - end - else - abort(linenumber, syntax); - end; {doprocedure} -{$p--------* - | Program | - *---------*} - - - procedure doprogram; - - var - doingmodule: boolean; {this is a module} - - begin {program or module} - doingmodule := (sym = modulesy); - nextonnewline(0, continuespaces); - checksym(identifier, linenumber); - if sym = openparen then - begin - nextsym; - while sym = identifier do - begin - nextsym; - if sym = comma then - begin - nextsym; - setsymbolbreak; - end; - end; - checksym(closeparen, linenumber); - end; - checksym(semicolon, linenumber); - undent; - indentplus(tabspaces, linenumber); - doblock; - undent; - if doingmodule then - begin - if sym = semicolon then - nextsym; - if sym = modendsy then - nextonnewline(1, indent) - else - abort(linenumber, syntax); - end {final end for module} ; - checksym(period, linenumber); - end; {doprogram} -{$p------* - | Block | - *-------*} - - - procedure doblock; - - begin {scan a block, including types, etc} - statindent := indent; - while sym in headingbegsys do - begin {declarations} - case sym of - labelsy: - dolabel; - constsy: - doconst; - typesy: - dotype; - varsy: - dovar; - procsy, funcsy: - doprocedure; - externsy: - doprochead; - end; {case} - statindent := indent; - end; {while} - if sym = beginsy then - begin - blankline := true; - dobegin(true); - end; - end; {doblock} - -modend . - \ No newline at end of file diff --git a/software/CPM/CPM22_MTPUG_10/RNB.SRC b/software/CPM/CPM22_MTPUG_10/RNB.SRC deleted file mode 100644 index 77901d9..0000000 --- a/software/CPM/CPM22_MTPUG_10/RNB.SRC +++ /dev/null @@ -1,114 +0,0 @@ -module rnbmodule; - - const - cr = $0D; - lf = $0A; - bs = $08; - - {$I B:FIBDEF.LIB} - - var - @lfb: external ^fib; - resultio: external integer; - - external function @bdos(func: integer; parm: word): integer; - external procedure @dflt; - -{ Purpose: Read N bytes from a file pointed to by @lfb - N is specified by @lfb^.iosize - update: 14 Mar 82, H. Lucas, correct eof/eoln problem - last update: 13 Aug 82, S. Clamage, correct eof problem } - - {$E-} - - - procedure nu_sect; - - var - i: integer; - - begin - with @lfb^ do - begin - fsecinx := 0; - i := @bdos(26, wrd(addr(fsector))); { set dma } - resultio := @bdos(20, wrd(addr(fcb))); { read sector } - if resultio <> 0 then - begin - nosectrs := true; - bufidx := 0 - end - end - end; - - {$E+} - - - procedure @rnb; - - var - dstptr: ^byte; - n, i: integer; - - begin - with @lfb^ do - begin - dstptr := fbufadr; - - if option = fconio then { con:, do an echoing read } - begin - dstptr^ := chr(@bdos(1, wrd(0))); { read a char with - echo } - if dstptr^ = cr then { echo cr with crlf } - i := @bdos(2, wrd(lf)) - else if dstptr^ = bs then { echo bs with sp/bs } - begin - i := @bdos(2, wrd(' ')); - i := @bdos(2, wrd(bs)) - end; - exit - end; { con: } - - if option = ftrmio then { kbd: do a non-echo read } - begin - repeat { read a char with no echo } - dstptr^ := chr(@bdos(6, wrd($FF))); - until dstptr^ <> 0; - exit - end; { kbd: } - - if option = fauxio then { rdr: } - begin - dstptr^ := chr(@bdos(3, wrd(0))); { read rdr: } - exit - end; { rdr: } - - if nosectrs then - begin - feof := true; - exit - end; { nosectrs } - - for n := 1 to iosize do - begin - if fsecinx = 128 then - nu_sect; { need new sector } - if nosectrs then - begin { end of file } - dstptr^ := chr($FF); - @dflt; - exit - end; {nosectrs} - dstptr^ := fsector[fsecinx]; - fsecinx := fsecinx + 1; - dstptr := dstptr + 1 - end; { for } - if @lfb^.fsecinx = 128 then { why is this needed? } - nu_sect; - @lfb^.bufidx := 0; { so gnb works } - @dflt; { to protect user data from i/o clobber } - end; { with } - end; { @rnb } - -modend . - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/ACK.PLI b/software/CPM/CPM23_PLI/ACK.PLI deleted file mode 100644 index 968d773..0000000 --- a/software/CPM/CPM23_PLI/ACK.PLI +++ /dev/null @@ -1,27 +0,0 @@ -ack: - procedure options(main,stack(2000)); - dcl - (m,maxm,n,maxn) fixed; - put skip list('Type max m,n: '); - get list(maxm,maxn); - put skip - list(' ',(decimal(n,4) do n=0 to maxn)); - do m = 0 to maxm; - put skip list(decimal(m,4),':'); - do n = 0 to maxn; - put list(decimal(ackermann(m,n),4)); - end; - end; - stop; - - ackermann: - procedure(m,n) returns(fixed) recursive; - dcl (m,n) fixed; - if m = 0 then - return(n+1); - if n = 0 then - return(ackermann(m-1,1)); - return(ackermann(m-1,ackermann(m,n-1))); - end ackermann; - end ack; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/ACKTST.PLI b/software/CPM/CPM23_PLI/ACKTST.PLI deleted file mode 100644 index 1a0c398..0000000 --- a/software/CPM/CPM23_PLI/ACKTST.PLI +++ /dev/null @@ -1,40 +0,0 @@ -ack: - procedure options(main,stack(2000)); - dcl - (m,n) fixed, - (maxm,maxn) fixed, - ncalls decimal(6), - (curstack, stacksize) fixed, - stksiz entry returns(fixed); - - put skip list('Type max m,n: '); - get list(maxm,maxn); - do m = 0 to maxm; - do n = 0 to maxn; - ncalls = 0; - curstack = 0; - stacksize = 0; - put edit - ('Ack(',m,',',n,')=',ackermann(m,n), - ncalls,' Calls,',stacksize,' Stack Bytes') - (skip,a,2(f(2),a),f(6),f(7),a,f(4),a); - end; - end; - stop; - - ackermann: - procedure(m,n) returns(fixed) recursive; - dcl - (m,n) fixed; - ncalls = ncalls + 1; - curstack = stksiz(); - if curstack > stacksize then - stacksize = curstack; - if m = 0 then - return(n+1); - if n = 0 then - return(ackermann(m-1,1)); - return(ackermann(m-1,ackermann(m,n-1))); - end ackermann; - end ack; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/ALLTST.PLI b/software/CPM/CPM23_PLI/ALLTST.PLI deleted file mode 100644 index 8ddda16..0000000 --- a/software/CPM/CPM23_PLI/ALLTST.PLI +++ /dev/null @@ -1,33 +0,0 @@ -alltst: - proc options(main); - /* assembly language interface to - dynamic storage allocation module */ - dcl - totwds returns(fixed(15)), - maxwds returns(fixed(15)), - allwds entry(fixed(15)) returns(ptr); - - dcl - allreq fixed(15), - memptr ptr, - meminx fixed(15), - memory (0:0) bit(16) based(memptr); - - do while('1'b); - put edit (totwds(),' Total Words Available', - maxwds(),' Maximum Segment Size', - 'Allocation Size? ') - (2(skip,f(6),a),skip,a); - get list(allreq); - memptr = allwds(allreq); - put edit('Allocated',allreq, - ' Words at ',unspec(memptr)) - (skip,a,f(6),a,b4); - - /* clear memory as example */ - do meminx = 0 to allreq-1; - memory(meminx) = '0000'b4; - end; - end; - end alltst; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/CALL.PLI b/software/CPM/CPM23_PLI/CALL.PLI deleted file mode 100644 index 0a467a0..0000000 --- a/software/CPM/CPM23_PLI/CALL.PLI +++ /dev/null @@ -1,26 +0,0 @@ -call: - proc options(main); - dcl - f (3) entry (float) returns (float) variable, - g entry (float) returns (float); - dcl - i fixed, x float; - - f(1) = sin; - f(2) = g; - f(3) = h; - - do i = 1 to 3; - put skip list('Type x '); - get list(x); - put list('f(',i,')=',f(i)(x)); - end; - stop; - - h: - proc(x) returns (float); - dcl x float; - return (2*x + 1); - end h; - end call; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/CHESS.PLI b/software/CPM/CPM23_PLI/CHESS.PLI deleted file mode 100644 index b28e2f7..0000000 --- a/software/CPM/CPM23_PLI/CHESS.PLI +++ /dev/null @@ -1,731 +0,0 @@ -chess: procedure options(main); - -/**************************************************************** -* * -* This program has served as a timing test case throughout * -* the PL/I development. We expect that this program will be * -* extensively changed as various programmers work with it - * -* if you make any great improvements, let us know and we'll * -* send your updated version with our next release (you'll * -* also go in line in the list below, for eternal fame). * -* Feel free to distribute this program, or altered versions * -* thereof, but please keep the list of names intact. Oh, by * -* the way, CHESS currently plays against itself, and reads a * -* value to determine the search depth (don't make the value * -* too large, or you'll wait quite a while for the moves). * -* * -* Programmer Address Date * -* ---------- ------------------- ------ * -* JWB Digital Research 3/79 * -* * -* * -* (P.S., in its current state, this program takes 1:58 to * -* compile on a 4-mhz Z-80 with a hard disk attached, and 1:45 * -* if the $Q compile toggle is enabled.) * -****************************************************************/ - - declare (white initial (1), none initial (0), black initial (-1)) - static fixed (1); - - declare (empty_square initial (0), illegal_square initial (1), - white_pawn initial (2), white_knight initial (3), - white_bishop initial (4), white_rook initial (5), - white_queen initial (6), white_king initial (7), - black_pawn initial (8), black_knight initial (9), - black_bishop initial (10), black_rook initial (11), - black_queen initial (12), black_king initial (13)) - static fixed (4); - - declare piece_value (0 : 13) static fixed initial - (0,0,100,290,310,500,900,8000,-100,-290,-310,-500,-900,-8000); - - declare piece_picture (0 : 13) static char (4) varying initial - (' |','___|',' P |',' N |',' B |',' R |',' Q |',' K |', - '

|','|','|','|','|','|'); - - declare bishop_like (0 : 13) static bit initial - ('0','0','0','0','1','0','1','0','0','0','1','0','1','0'); - - declare rook_like (0 : 13) static bit initial - ('0','0','0','0','0','1','1','0','0','0','0','1','1','0'); - - declare board (0 : 119) static fixed (4) initial - (01,01,01,01,01,01,01,01,01,01, - 01,01,01,01,01,01,01,01,01,01, - 01,11,09,10,12,13,10,09,11,01, - 01,08,08,08,08,08,08,08,08,01, - 01,00,00,00,00,00,00,00,00,01, - 01,00,00,00,00,00,00,00,00,01, - 01,00,00,00,00,00,00,00,00,01, - 01,00,00,00,00,00,00,00,00,01, - 01,02,02,02,02,02,02,02,02,01, - 01,05,03,04,06,07,04,03,05,01, - 01,01,01,01,01,01,01,01,01,01, - 01,01,01,01,01,01,01,01,01,01); - - declare center (0 : 119) static fixed (2) initial - (00,00,00,00,00,00,00,00,00,00, - 00,00,00,00,00,00,00,00,00,00, - 00,00,00,00,00,00,00,00,00,00, - 00,00,01,01,01,01,01,01,00,00, - 00,00,01,02,02,02,02,01,00,00, - 00,00,01,02,03,03,02,01,00,00, - 00,00,01,02,03,03,02,01,00,00, - 00,00,01,02,02,02,02,01,00,00, - 00,00,01,01,01,01,01,01,00,00, - 00,00,00,00,00,00,00,00,00,00, - 00,00,00,00,00,00,00,00,00,00, - 00,00,00,00,00,00,00,00,00,00); - - declare bonus (0 : 119) static fixed (4) initial - ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 1, 3, 2, 1,-9, 3, 4, 1, 0, - 0, 1, 1, 1, 6, 7, 1, 1, 1, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 1, 1, 1, 6, 7, 1, 1, 1, 0, - 0, 1, 3, 2, 1,-9, 3, 4, 1, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); - - declare (((max_stage,max_cap) initial (3), ply, max_ply) fixed (3), - ((move_index, best_move, first_move, last_move) fixed, - (stage_lim, stage_lst) fixed (3), - move_color fixed (1), cur_piece fixed (4), - move_bonus fixed (4)) (0 : 5), - next fixed, /* index to next available of */ - ((est_score, move_score) fixed, - (move_from, move_to, move_dir) fixed (7)) - (0 : 350)) static; - - - - -/**************************************************************** -* * -* * -* * -****************************************************************/ - - display: procedure; - - declare (i, j) fixed; - declare dashes static varying character (41) initial - (' +---+---+---+---+---+---+---+---+'), - spaces static varying character (9) initial (' |'); - - put skip(2); - do i = 20 to 90 by 10; - write from(dashes); - put skip; - write from(spaces); - do j = 1 to 8; - write from(piece_picture (board (i + j))); - end; - put skip; - end; - write from(dashes); - put skip(2); - - end display; - - - -/**************************************************************** -* * -* * -* * -****************************************************************/ - - - display_move: procedure (move); - - declare move fixed; - - declare spaces varying character (6) static initial (' '), - dash varying character (1) static initial ('-'), - takes varying character (1) static initial ('x'), - names (0 : 119) varying character (2) static initial - (' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', - ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', - ' ','a8','b8','c8','d8','e8','f8','g8','h8',' ', - ' ','a7','b7','c7','d7','e7','f7','g7','h7',' ', - ' ','a6','b6','c6','d6','e6','f6','g6','h6',' ', - ' ','a5','b5','c5','d5','e5','f5','g5','h5',' ', - ' ','a4','b4','c4','d4','e4','f4','g4','h4',' ', - ' ','a3','b3','c3','d3','e3','f3','g3','h3',' ', - ' ','a2','b2','c2','d2','e2','f2','g2','h2',' ', - ' ','a1','b1','c1','d1','e1','f1','g1','h1',' ', - ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', - ' ',' ',' ',' ',' ',' ',' ',' ',' ',' '); - - - write from(spaces); - write from(names (move_from (move))); - if cur_piece (ply) = empty_square then - write from(dash); - if cur_piece (ply) ~= empty_square then - write from(takes); - write from(names (move_to (move))); - end display_move; - - -/**************************************************************** -* * -* * -* * -****************************************************************/ - - color: procedure (square) returns (fixed (1)); - - declare square fixed (7); - - if board (square) >= black_pawn then return (black); - if board (square) <= illegal_square then return (none); - return (white); - - end color; - - - - -/**************************************************************** -* * -* * -* * -****************************************************************/ - - sort_moves: procedure; - - declare ((i, j, t) fixed, s fixed (7), color fixed (1), - switched bit) static; - - color = move_color (ply); - do switched = '1' while (switched); - switched = '0'; - do i = first_move (ply) repeat (j) - while (i < last_move (ply)); - j = i + 1; - t = move_score (i) - move_score (j); - if t < 0 & color = white | t > 0 & color = black then - do; - switched = '1'; - t = est_score (i); - est_score (i) = est_score (j); - est_score (j) = t; - t = move_score (i); - move_score (i) = move_score (j); - move_score (j) = t; - s = move_from (i); - move_from (i) = move_from (j); - move_from (j) = s; - s = move_to (i); - move_to (i) = move_to (j); - move_to (j) = s; - s = move_dir (i); - move_dir (i) = move_dir (j); - move_dir (j) = s; - if i > first_move (ply) then j = j - 2; - end; - end; - end; - best_move (ply) = first_move (ply); - end sort_moves; - - - -/**************************************************************** -* * -* * -* * -****************************************************************/ - - generate_moves: procedure; - - declare (move_piece fixed (4), from_square fixed (7), - castle_bonus fixed (4), move fixed) static; - - - -/**************************************************************** -* * -* * -* * -****************************************************************/ - - add_move: procedure (to_square, direction); - declare to_square fixed (7), direction fixed (5); - - declare (current_piece fixed (4), score fixed) static; - - current_piece = board (to_square); - if current_piece = illegal_square then return; - if color (to_square) = move_color (ply) then return; - move_from (next) = from_square; - move_to (next) = to_square; - move_dir (next) = direction; - score = center (to_square) - center (from_square) + - bonus (from_square); - if color (from_square) = black then score = - score; - score = score - piece_value (current_piece); - est_score (next) = score; - move_score (next) = score; - if move_color (ply) = white then - do; - if score > move_score (best_move (ply)) then - best_move (ply) = next; - end; else - do; - if score < move_score (best_move (ply)) then - best_move (ply) = next; - end; - last_move (ply) = next; - next = next + 1; - end add_move; - - - -/**************************************************************** -* * -* * -* * -****************************************************************/ - - multi_move: procedure (dir); - declare dir fixed (5); - - declare ts fixed (7) static; - - do ts = from_square + dir repeat (ts + dir) - while (board (ts) = empty_square); - call add_move (ts, dir); - end; - call add_move (ts, dir); /* adds captures */ - end multi_move; - - - -/**************************************************************** -* * -* * -* * -****************************************************************/ - - - generate_piece_moves: procedure; - - move_piece = board (from_square); - if move_piece = white_pawn then - do; - if board (from_square - 10) = empty_square then - do; call add_move (from_square - 10, -10); - if board (from_square - 20) = empty_square then - if bonus (from_square) ~= 0 then - call add_move (from_square - 20, -10); - end; - if color (from_square - 9) = -move_color (ply) then - call add_move (from_square - 9, -9); - if color (from_square-11) = -move_color (ply) then - call add_move (from_square - 11, -11); - end; else - if move_piece = black_pawn then - do; - if board (from_square + 10) = empty_square then - do; call add_move (from_square + 10, 10); - if board (from_square + 20) = empty_square then - if bonus (from_square) ~= 0 then - call add_move (from_square + 20, 10); - end; - if color (from_square + 9) = -move_color (ply) then - call add_move (from_square + 9, 9); - if color (from_square+11) = -move_color (ply) then - call add_move (from_square + 11, 11); - end; else - if move_piece = white_knight | - move_piece = black_knight then - do; - call add_move (from_square - 21, -21); - call add_move (from_square - 19, -19); - call add_move (from_square - 12, -12); - call add_move (from_square - 8, -8); - call add_move (from_square + 8, 8); - call add_move (from_square + 12, 12); - call add_move (from_square + 19, 19); - call add_move (from_square + 21, 21); - end; else - if move_piece = white_king | - move_piece = black_king then - do; - call add_move (from_square - 11, -11); - call add_move (from_square - 10, -10); - call add_move (from_square - 9, -9); - call add_move (from_square - 1, -1); - call add_move (from_square + 1, 1); - call add_move (from_square + 9, 9); - call add_move (from_square + 10, 10); - call add_move (from_square + 11, 11); - castle_bonus = 0; - if bonus (from_square) ~= 0 then - do; - if move_piece = white_king then - if from_square = 95 then - castle_bonus = 15; - end; else - do; - if move_piece = black_king then - if from_square = 25 then - castle_bonus = -15; - end; - if castle_bonus ~= 0 then - do; - if bonus (from_square + 3) ~= 0 then - if board (from_square + 3) = move_piece-2 then - if board (from_square + 1) = empty_square then - if board (from_square + 2) = empty_square then - do; - call add_move (from_square + 2, 2); - est_score (next - 1) = - est_score (next - 1) + castle_bonus; - move_score (next - 1) = - move_score (next - 1) + castle_bonus; - end; - if bonus (from_square - 4) ~= 0 then - if board (from_square - 4) = move_piece-2 then - if board (from_square - 3) = empty_square then - if board (from_square - 2) = empty_square then - if board (from_square - 1) = empty_square then - do; - call add_move (from_square - 2, -2); - est_score (next - 1) = - est_score (next - 1) + castle_bonus; - move_score (next - 1) = - move_score (next - 1) + castle_bonus; - end; - end; - end; else - do; - if bishop_like (move_piece) then - do; - call multi_move (-11); - call multi_move (-9); - call multi_move (9); - call multi_move (11); - end; - if rook_like (move_piece) then - do; - call multi_move (-10); - call multi_move (10); - call multi_move (1); - call multi_move (-1); - end; - end; - end generate_piece_moves; - - - -/**************************************************************** -* * -* * -* * -****************************************************************/ - - - move_prohibited: procedure (best_move, move) returns (bit); - declare (best_move, move) fixed; - - declare to_sq fixed (7) static; - - do to_sq = move_from (best_move) - repeat (to_sq + move_dir (best_move)) - while (to_sq ~= move_to (best_move)); - if move_to (move) = to_sq then return ('1'); - end; - if move_to (move) = to_sq then return ('1'); - return ('0'); - end move_prohibited; - - - first_move (ply) = next; - best_move (ply) = next; - move_index (ply) = next - 1; - - - - move = best_move (ply - 2); - if ply >= max_ply then - if ply >= 2 then - if move_from (move_index (ply - 2)) ~= move_from (move) then - if move_from (move) ~= move_to (move_index (ply - 1)) then - if move_to (move) ~= move_from (move_index (ply - 1)) then - if ~ move_prohibited (move, move_index (ply - 1)) then - if ~ move_prohibited (move, move_index (ply - 2)) then - do; - from_square = move_from (move); - call add_move (move_to (move), move_dir (move)); - return; - end; - - - - do from_square = 21 to 98; - if color (from_square) = move_color (ply) then - call generate_piece_moves(); - if ply >= max_ply then - if alpha_beta_cutoff (best_move (ply)) then - do; - last_move (ply) = next - 1; - return; - end; - end; - - return; - - end generate_moves; - - - -/**************************************************************** -* * -* * -* * -****************************************************************/ - - alpha_beta_cutoff: procedure (move) returns (bit); - declare move fixed (7); - - declare score fixed static; - - if ply = 0 then return ('0'); - if move_index (ply - 1) = first_move (ply - 1) then - return ('0'); - if move_index (ply) < first_move (ply) then - return ('0'); - score = move_score (move) + - move_score (move_index (ply - 1)) - - move_score (best_move (ply - 1)); - if move_color (ply) = white then return (score > 0); - return (score < 0); - end alpha_beta_cutoff; - - - -/**************************************************************** -* * -* * -* * -****************************************************************/ - - select_next_move: procedure returns (bit); - - declare (to, from) fixed (7) static; - - if alpha_beta_cutoff (move_index (ply)) then return ('0'); - move_index (ply) = move_index (ply) + 1; - if move_index (ply) > last_move (ply) then return ('0'); - to = move_to (move_index (ply)); - from = move_from (move_index (ply)); - cur_piece (ply) = board (to); - if ply >= max_cap & cur_piece (ply) = empty_square then - return ('0'); - board (to) = board (from); - board (from) = empty_square; - move_bonus (ply) = bonus (from); - bonus (from) = 0; - if board (to) = white_king | board (to) = black_king then - do; - if to = from + 2 then - do; - board (to - 1) = board (to) - 2; - board (to + 1) = empty_square; - end; else - if to = from - 2 then - do; - board (to + 1) = board (to) - 2; - board (to - 2) = empty_square; - end; - end; - return ('1'); - end select_next_move; - - - -/**************************************************************** -* * -* * -* * -****************************************************************/ - - retract_move: procedure; - - declare (to, from) fixed (7) static; - - to = move_to (move_index (ply)); - from = move_from (move_index (ply)); - board (from) = board (to); - board (to) = cur_piece (ply); - bonus (from) = move_bonus (ply); - if board (from) = white_king | board (from) = black_king then - do; - if to = from + 2 then - do; - board (to + 1) = board (from) - 2; - board (to - 1) = empty_square; - end; else - if to = from - 2 then - do; - board (to - 2) = board (from) - 2; - board (to + 1) = empty_square; - end; - end; - end retract_move; - - - -/**************************************************************** -* * -* * -* * -****************************************************************/ - - score_ply_moves: procedure recursive; - - do while (select_next_move ()); - call stage(); - move_score (move_index (ply)) = - move_score (move_index (ply)) + - move_score (best_move (ply + 1)); - if move_color (ply) = white then - do; - if move_score (move_index (ply)) > - move_score (best_move (ply)) then - best_move (ply) = move_index (ply); - end; else - do; - if move_score (move_index (ply)) < - move_score (best_move (ply)) then - best_move (ply) = move_index (ply); - end; - call retract_move(); - end; - end score_ply_moves; - - - -/**************************************************************** -* * -* * -* * -****************************************************************/ - - - stage: procedure recursive; - - declare i fixed static; - - ply = ply + 1; - if ply ~= 0 then move_color (ply) = -move_color (ply - 1); - stage_lst (ply) = max_ply; - stage_lim (ply) = ply + 2; - if stage_lim (ply) > max_stage then - stage_lim (ply) = max_stage; - call generate_moves(); - - - if ply ~= 0 then - if cur_piece (ply - 1) = white_king | - cur_piece (ply - 1) = black_king then - do; - move_score (best_move (ply)) = 0; - next = first_move (ply); - ply = ply - 1; - return; - end; - - - if ply < max_ply then - do max_ply = stage_lim (ply) repeat (stage_lim (ply) + 1) - while (max_ply <= stage_lst (ply)); - stage_lim (ply) = max_ply; - do i = first_move (ply) to last_move (ply); - move_score (i) = est_score (i); - end; - move_index (ply) = first_move (ply) - 1; - call score_ply_moves(); - call sort_moves(); - end; - next = first_move (ply); - max_ply = stage_lst (ply); - ply = ply - 1; - end stage; - - - -/**************************************************************** -* * -* * -* * -****************************************************************/ - - make_move: procedure (color); - declare color fixed (1); - - declare (to, from) fixed static; - - next = 0; - ply = -1; - max_ply = max_stage; - move_color (0) = color; - call stage(); - ply = 0; - to = move_to (best_move (0)); - from = move_from (best_move (0)); - cur_piece (0) = board (to); - board (to) = board (from); - board (from) = empty_square; - bonus (from) = 0; - bonus (to) = 0; - if board (to) = white_king | board (to) = black_king then - do; - if to = from + 2 then - do; - board (to - 1) = board (to) - 2; - board (to + 1) = empty_square; - bonus (to + 1) = 0; - end; else - if to = from - 2 then - do; - board (to + 1) = board (to) - 2; - board (to - 2) = empty_square; - bonus (to - 2) = 0; - end; - end; - call display_move (best_move (0)); - end make_move; - - declare (move_number, move_display) - fixed (7) static initial(1); - - put skip list('Chess Program Version 1.0'); - put skip list('Type Search Depth '); - get list(max_cap); - max_stage = max_cap; - put list('Type Number of Moves Between Displays '); - get list(move_display); - do while ('1'); - call make_move (white); - call make_move (black); - put skip; - move_number = move_number + 1; - if move_number > move_display then - do; - move_number = 1; - call display(); - end; - end; - - - end chess; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/COPY.PLI b/software/CPM/CPM23_PLI/COPY.PLI deleted file mode 100644 index 062be9d..0000000 --- a/software/CPM/CPM23_PLI/COPY.PLI +++ /dev/null @@ -1,19 +0,0 @@ -copy: - proc options(main); - dcl - (input,output) file; - - open file (input) stream env(b(8192)) - title('$1.$1'); - - open file (output) stream output env(b(8192)) - title('$2.$2'); - dcl - buff char(254) varying; - - do while('1'b); - read file (input) into (buff); - write file (output) from (buff); - end; - end copy; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/COPYLPT.PLI b/software/CPM/CPM23_PLI/COPYLPT.PLI deleted file mode 100644 index 89397eb..0000000 --- a/software/CPM/CPM23_PLI/COPYLPT.PLI +++ /dev/null @@ -1,77 +0,0 @@ -copy: procedure options(main); - dcl - (sysin, sourcefile, printfile) file; - dcl - (pagesize, pagewidth, - spaces, linenumber) fixed; - dcl - (line char(14), buff char(254)) varying; - - put list('^z File to Print Copy Program'); - - on endfile(sysin) - go to typeover; - - typeover: - put skip(5) list('How Many Lines Per Page? '); - get list(pagesize); - - put skip list('How Many Column Positions? '); - get skip list(pagewidth); - - on error(1) - begin; - put list('Invalid Number, Type Integer'); - go to getnumber; - end; - getnumber: - put skip list('Line Spacing (1=Single)? '); - get skip list(spaces); - revert error(1); - - put skip list('Destination Device/File: '); - get skip list(line); - - open file(printfile) print pagesize(pagesize) - linesize(pagewidth) title(line); - - on undefinedfile(sourcefile) - begin; - put skip list('"',line,'" isn''t a Valid Name'); - go to retry; - end; - retry: - put skip list('Source File to Print? '); - get list(line); - open file(sourcefile) stream title(line) - env(b(8000)); - - on endfile(sourcefile) - begin; - put file(printfile) page; - stop; - end; - - on endfile(printfile) - begin; - put skip list('^g^g^g^g Disk is Full'); - stop; - end; - - on endpage(printfile) - begin; - put file(printfile) page skip(2) - list('PAGE',pageno(printfile)); - put file(printfile) skip(4); - end; - - signal endpage(printfile); - do linenumber = 1 repeat(linenumber + 1); - get file (sourcefile) edit(buff) (a); - put file (printfile) - edit(linenumber,'|',buff) (f(5),x(1),a(2),a); - put file (printfile) skip(spaces); - end; - - end copy; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/CREATE.PLI b/software/CPM/CPM23_PLI/CREATE.PLI deleted file mode 100644 index 9cea6cb..0000000 --- a/software/CPM/CPM23_PLI/CREATE.PLI +++ /dev/null @@ -1,45 +0,0 @@ -create: - procedure options(main); - /* create name and address file */ - -%include 'record.dcl'; - - %replace - true by '1'b, - false by '0'b; - dcl - output file; - dcl - filename character(14) varying; - dcl - eofile bit(1) static initial(false); - - put list ('Name and Address Creation Program, File Name: '); - get list (filename); - - open file(output) stream output title(filename); - - do while (^eofile); - put skip(3) list('Name: '); - get list(name); - eofile = (name = 'EOF'); - if ^eofile then - do; - /* write prompt strings to console */ - put list('Address: '); - get list(addr); - put list('City, State, Zip: '); - get list(city, state, zip); - put list('Phone: '); - get list(phone); - - /* data in memory, write to output file */ - put file(output) - list(name,addr,city,state,zip,phone); - put file(output) skip; - end; - end; - put file(output) skip list('EOF'); - put file(output) skip; - end create; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/DFACT.PLI b/software/CPM/CPM23_PLI/DFACT.PLI deleted file mode 100644 index f0fbcf7..0000000 --- a/software/CPM/CPM23_PLI/DFACT.PLI +++ /dev/null @@ -1,22 +0,0 @@ -f: - proc options(main); - dcl - i fixed; - do i = 0 repeat(i+1); - put skip list('Factorial(',i,')=',fact(i)); - end; - stop; - - fact: - proc (i) - returns(fixed dec(15,0)) recursive; - dcl - i fixed; - dcl - f fixed dec(15,0); - if i = 0 then - return (1); - return (decimal(i,15) * fact(i-1)); - end fact; - end f; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/DIOCALLS.PLI b/software/CPM/CPM23_PLI/DIOCALLS.PLI deleted file mode 100644 index 63a7124..0000000 --- a/software/CPM/CPM23_PLI/DIOCALLS.PLI +++ /dev/null @@ -1,354 +0,0 @@ -diotst: - proc options(main); - /* external CP/M I/O entry points */ - /* (note: each source line begins with tab chars) */ -%include 'diomod.dcl'; - dcl - c char(1), - v char(254) var, - i fixed; - - - /********************************** - * * - * Fixed Location Tests: * - * MEMPTR, MEMSIZ, MEMWDS, * - * DFCB0, DFCB1, DBUFF * - * * - **********************************/ - dcl - memptrv ptr, - memsizv fixed, - (dfcb0v, dfcb1v, dbuffv) ptr, - command char(127) var based (dbuffv), - 1 fcb0 based(dfcb0v), - 2 drive fixed(7), - 2 name char(8), - 2 type char(3), - 2 extnt fixed(7), - 2 space (19) bit(8), - 2 cr fixed(7), - memory (0:0) based(memptrv) bit(8); - memptrv = memptr(); - memsizv = memsiz(); - dfcb0v = dfcb0(); - dfcb1v = dfcb1(); - dbuffv = dbuff(); - put edit ('Command Tail: ',command) (a); - put edit ('First Default File:', - fcb0.name,'.',fcb0.type) (skip,4a); - put edit ('dfcb0 ',unspec(dfcb0v), - 'dfcb1 ',unspec(dfcb1v), - 'dbuff ',unspec(dbuffv), - 'memptr',unspec(memptrv), - 'memsiz',unspec(memsizv), - 'memwds',memwds()) - (5(skip,a(7),b4),skip,a(7),f(6)); - put skip list('Clearing Memory'); - /* sample loop to clear mem */ - do i = 0 repeat(i+1) while (i^=memsizv-1); - memory (i) = '00'b4; - end; - - - /********************************** - * * - * REBOOT Test * - * * - **********************************/ - put skip list ('Reboot? (Y/N)'); - get list (c); - if translate(c,'Y','y') = 'Y' then - call reboot(); - - - /********************************** - * * - * RDCON, WRCON Test * - * * - **********************************/ - put list('Type Input, End with "$" '); - v = '^m^j'; - do while (substr(v,length(v)) ^= '$'); - v = v || rdcon(); - end; - put skip list('You Typed:'); - do i = 1 to length(v); - call wrcon(substr(v,i,1)); - end; - - - /********************************** - * * - * RDRDR and WRPUN Test * - * * - **********************************/ - put skip list('Reader to Punch Test?(Y/N)'); - get list (c); - if translate(c,'Y','y') = 'Y' then - do; - put skip list('Copying RDR to PUN until ctl-z'); - c = ' '; - do while (c ^= '^z'); - c = rdrdr(); - if c ^= '^z' then - call wrpun(c); - end; - end; - - - /********************************** - * * - * WRLST Test * - * * - **********************************/ - put list('List Output Test?(Y/N)'); - get list(c); - if translate(c,'Y','y') = 'Y' then - do i = 1 to length(v); - call wrlst(substr(v,i,1)); - end; - - - /********************************** - * * - * Direct I/O, CONOUT, CONINP * - * * - **********************************/ - put list - ('Direct I/O, Type Line, End with Line Feed'); - c = ' '; - do while (c ^= '^j'); - call conout(c); - c = coninp(); - end; - - - /********************************** - * * - * Direct I/O, Console Status * - * RDSTAT * - * * - **********************************/ - put skip list('Status Test, Type Character'); - do while (^rdstat()); - end; - /* clear the character */ - c = coninp(); - - - /********************************** - * * - * GETIO, SETIO IObyte * - * * - **********************************/ - dcl - iobyte bit(8); - iobyte = getio(); - put edit ('IObyte is ',iobyte, - ', New Value: ') (skip,a,b4,a); - get edit (iobyte) (b4(2)); - call setio(iobyte); - - - /********************************** - * * - * Buffered Write, WRSTR Test * - * * - **********************************/ - put list('Buffered Output Test:'); - /* "v" was previously filled by RDCON */ - call wrstr(addr(v)); - - - /********************************** - * * - * Buffered Read RDBUF Test * - * * - **********************************/ - dcl - 1 inbuff static, - 2 maxsize bit(8) init('80'b4), - 2 inchars char(127) var; - put skip list('Line Input, Type Line, End With Return'); - put skip; - call rdbuf(addr(inbuff)); - put skip list('You Typed: ',inchars); - - - /********************************** - * * - * Console BREAK Test * - * * - **********************************/ - put skip list('Console Break Test, Type Character'); - do while(^break()); - end; - c = rdcon(); - - - /********************************** - * * - * Version Number VERS Test * - * * - **********************************/ - dcl - version bit(16); - version = vers(); - if substr(version,1,8) = '00'b4 then - put skip list('CP/M'); else - put skip list('MP/M'); - put edit(' Version ',substr(version,9,4), - '.',substr(version,13,4)) (a,b4,a,b4); - - - /********************************** - * * - * Disk System RESET Test * - * * - **********************************/ - put skip list('Resetting Disk System'); - call reset(); - - - /********************************** - * * - * Disk SELECT Test * - * * - **********************************/ - put skip list('Select Disk # '); - get list(i); - call select(i); - - /********************************** - * * - * Note: The OPEN, CLOSE, SEAR, * - * SEARN, DELETE, RDSEQ, * - * WRSEQ, MAKE, and RENAME * - * functions are tested in the * - * DIOCOPY program * - * * - **********************************/ - - /********************************** - * * - * LOGVEC and CURDSK * - * * - **********************************/ - put skip list ('Login Vector', - logvec(),'Current Disk', - curdsk()); - - /********************************** - * * - * See DIOCOPY for SETDMA Function * - * * - **********************************/ - - /********************************** - * * - * Allocate Vector ALLVEC Test * - * * - **********************************/ - dcl - alloc (0:30) bit(8) - based (allvec()), - allvecp ptr; - allvecp = allvec(); - put edit('Alloc Vector at ', - unspec(allvecp),':', - (alloc(i) do i=0 to 30)) - (skip,a,b4,a,254(skip,4(b,x(1)))); - - /********************************** - * * - * Note: the following functions * - * apply to version 2.0 or newer. * - * * - **********************************/ - - /********************************** - * * - * WPDISK Test * - * * - **********************************/ - put skip list('Write Protect Disk?(Y/N)'); - get list(c); - if translate(c,'Y','y') = 'Y' then - call wpdisk(); - - /********************************** - * * - * ROVEC Test * - * * - **********************************/ - put skip list('Read/Only Vector is',rovec()); - - /********************************** - * * - * Disk Parameter Block Decoding * - * Using GETDPB * - * * - **********************************/ - dcl - dpbp ptr, - 1 dpb based (dpbp), - 2 spt fixed(15), - 2 bsh fixed(7), - 2 blm bit(8), - 2 exm bit(8), - 2 dsm bit(16), - 2 drm bit(16), - 2 al0 bit(8), - 2 al1 bit(8), - 2 cks bit(16), - 2 off fixed(7); - dpbp = getdpb(); - put edit('Disk Parameter Block:', - 'spt',spt,'bsh',bsh,'blm',blm, - 'exm',exm,'dsm',dsm,'drm',drm, - 'al0',al0,'al1',al1,'cks',cks, - 'off',off) - (skip,a,2(skip,a(4),f(6)), - 4(skip,a(4),b4), - skip,2(a(4),b,x(1)), - skip,a(4),b4, - skip,a(4),f(6)); - - /********************************** - * * - * Test Get/Set user Code * - * GETUSR, SETUSR * - * * - **********************************/ - put skip list - ('User is',getusr(),', New User:'); - get list(i); - call setusr(i); - - /********************************** - * * - * FILSIZ, SETREC, * - * RDRAN, WRRAN, WRRANZ are * - * tested in DIORAND * - * * - **********************************/ - - /********************************** - * * - * Test Drive Reset RESDRV * - * (version 2.2 or newer) * - * * - **********************************/ - dcl - drvect bit(16); - put list('Drive Reset Vector:'); - get list(drvect); - call resdrv(drvect); - - /********************************** - * * - * * - **********************************/ - end diotst; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/DIOCOPY.PLI b/software/CPM/CPM23_PLI/DIOCOPY.PLI deleted file mode 100644 index 39d629e..0000000 --- a/software/CPM/CPM23_PLI/DIOCOPY.PLI +++ /dev/null @@ -1,137 +0,0 @@ -diocopy: - proc options(main); - /* file to file copy program */ - /* (all source lines begin with tabs) */ - - %replace - bufwds by 64, /* words per buffer */ - quest by 63, /* ASCII '?' */ - true by '1'b, - false by '0'b; - -%include 'diomod.dcl'; - - dcl - 1 destfile, -%include 'fcb.dcl'; - - dcl - dfcb0p ptr, - 1 sourcefile based(dfcb0p), -%include 'fcb.dcl'; - - dcl - 1 dfcb1file based(dfcb1()), -%include 'fcb.dcl'; - - dcl - 1 renfile, -%include 'fcb.dcl'; - - dcl - answer char(1), - extcnt fixed(7); - - dcl - /* buffer management */ - eofile bit(8), - i fixed(15), - m fixed(15), - nbuffs fixed(15), - memory (0:0) bit(16) based(memptr()); - - /* compute number of buffs, 64 words each */ - nbuffs = divide(memwds(),bufwds,15); - if nbuffs = 0 then - do; - put skip list('No Buffer Space'); - call reboot(); - end; - - /* initialize fcb's */ - dfcb0p = dfcb0(); - destfile = dfcb1file; - - /* copy fcb to rename file, count extents */ - renfile = destfile; - /* search all extents by inserting '?' */ - renfile.fext = quest; - if sear(addr(renfile)) ^= -1 then - do; - extcnt = 1; - do while(searn() ^= -1); - extcnt = extcnt + 1; - end; - put edit - ('OK to Delete ',extcnt,' Extent(s)?(Y/N)') - (skip,a,f(3),a); - get list(answer); - if ^ (answer = 'Y' ! answer = 'y') then - call reboot(); - end; - - /* destination file will be deleted later */ - destfile.ftype = '$$$'; - /* delete any existing x.$$$ file */ - call delete(addr(destfile)); - - /* open the source file, if possible */ - if open(addr(sourcefile)) = -1 then - do; - put skip list('No Source File'); - call reboot(); - end; - - /* source file opened, create $$$ file */ - destfile.fext = 0; - destfile.crec = 0; - if make(addr(destfile)) = -1 then - do; - put skip list('No Directory Space'); - call reboot(); - end; - - /* $$$ temp file created, now copy from source */ - eofile = false; - do while (^eofile); - m = 0; - /* fill buffers */ - do i = 0 repeat (i+1) while (i= '22'b4; - - /* read and process file name */ - put skip list('Data Base Name: '); - get list(fn); - fn = translate(fn,upper,lower); - - /* process optional drive prefix */ - i = index(fn,':'); - if i = 0 then - drive = 0; - else - if i = 2 then - do; - /* convert character to drive code */ - drive = index(upper,substr(fn,1,1)); - if drive = 0 ! drive > 16 then - do; - put skip list('Bad Drive Name'); - stop; - end; - fn = substr(fn,i+1); - end; - - /* get file name and optional type */ - i = index(fn,'.'); - if i = 0 then - do; - /* no file type specified, use .DAT */ - fname = fn; - ftype = 'DAT'; - end; - else - do; - fname = substr(fn,1,i-1); - ftype = substr(fn,i+1); - end; - - /* clear the extent field */ - fext = 0; - - if open(addr(database)) = -1 then - do; - put skip list('Creating New Database'); - if make(addr(database)) = -1 then - do; - put skip list('No Directory Space'); - stop; - end; - end; - else - do; - call filsiz(addr(database)); - put skip list('File Size:',rrec,' Records'); - end; - - /* main processing loop */ - do while('1'b); - call setrec(addr(database)); - put skip list('Current Record',rrec); - put skip list('Read(0),Write(1),Quit(2)? '); - get list(mode); - if mode < 2 then - do; - put skip list('Record Number? '); - get list(rrec); - rovf = 0; - end; - if mode = 0 then - do; - code = rdran(addr(database)); - if code = 0 then - do; - if bitbuf(1) = '00'b4 then - put skip list('Zero Record'); - else - put skip list(buffer); - end; - else - put skip list('Return Code',code); - end; - else - if mode = 1 then - do; - put skip list('Data: '); - get list(buffer); - if zerofill then - code = wrranz(addr(database)); - else - code = wrran (addr(database)); - if code ^= 0 then - put skip list('Return Code',code); - end; - else - if mode = 2 then - do; - if close(addr(database)) = -1 then - put skip list('Read/Only'); - stop; - end; - end; - end diorand; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/DIV2.ASM b/software/CPM/CPM23_PLI/DIV2.ASM deleted file mode 100644 index c639fda..0000000 --- a/software/CPM/CPM23_PLI/DIV2.ASM +++ /dev/null @@ -1,52 +0,0 @@ - title 'division by power of two' - public div2 - extrn ?signal -; entry: -; p1 -> fixed(7) power of two -; p2 -> floating point number -; exit: -; p1 -> (unchanged) -; p2 -> p2 / (2**p1) -div2: ;HL = .low(.p1) - mov e,m ;low(.p1) - inx h ;HL = .high(.p1) - mov d,m ;DE = .p1 - inx h ;HL = .low(p2) - ldax d ;a = p1 (power of two) - mov e,m ;low(.p2) - inx h ;HL = .high(.p2) - mov d,m ;DE = .p2 - xchg ;HL = .p2 -; -; A = power of 2, HL = .low byte of fp num - inx h ;to middle of mantissa - inx h ;to high byte of mantissa - inx h ;to exponent byte - inr m - dcr m ;p2 already zero? - rz ;return if so -dby2: ;divide by two - ora a ;counted power of 2 to zero? - rz ;return if so - dcr a ;count power of two down - dcr m ;count exponent down - jnz dby2 ;loop again if no underflow -; -;underflow occurred, signal underflow condition - lxi h,siglst;signal parameter list - call ?signal ;signal underflow - ret ;normally, no return -; - dseg -siglst: dw sigcod ;address of signal code - dw sigsub ;address of subcode - dw sigfil ;address of file code - dw sigaux ;address of aux message -; end of parameter vector, start of params -sigcod: db 3 ;03 = underflow -sigsub: db 128 ;arbitrary subcode for id -sigfil: dw 0000 ;no associated file name -sigaux: dw undmsg ;0000 if no aux message -undmsg: db 32,'Underflow in Divide by Two',0 - end - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/DPOLY.PLI b/software/CPM/CPM23_PLI/DPOLY.PLI deleted file mode 100644 index 5278a9b..0000000 --- a/software/CPM/CPM23_PLI/DPOLY.PLI +++ /dev/null @@ -1,30 +0,0 @@ -poly: - procedure options(main); - - /* evaluate polynomial */ - - %replace - true by '1'b; - dcl - (x,y,z) fixed decimal(15,4); - - do while(true); - put skip(2) list('Type x,y,z: '); - get list(x,y,z); - - if x = 0 & y = 0 & z = 0 then - stop; - - put skip list(' 2'); - put skip list(' x + 2y + z =',p(x,y,z)); - end; - - p: - proc (x,y,z) returns (fixed decimal(15,4)); - dcl - (x,y,z) fixed decimal(15,4); - return (x * x + 2 * y + z); - end p; - - end poly; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/DTEST.PLI b/software/CPM/CPM23_PLI/DTEST.PLI deleted file mode 100644 index 55f22e4..0000000 --- a/software/CPM/CPM23_PLI/DTEST.PLI +++ /dev/null @@ -1,14 +0,0 @@ -dtest: - proc options(main); - dcl - div2 entry(fixed(7),float), - i fixed(7), - f float; - - do i = 0 by 1; - f = 100; - call div2(i,f); - put skip list('100 / 2 **',i,'=',f); - end; - end dtest; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/DUMP.PLI b/software/CPM/CPM23_PLI/DUMP.PLI deleted file mode 100644 index 174242c..0000000 --- a/software/CPM/CPM23_PLI/DUMP.PLI +++ /dev/null @@ -1,27 +0,0 @@ -dump: - proc options(main); - /* dump file in hex at terminal */ - dcl - sysprint file, - input file; - dcl - bit(254) bit(8), - c char, - i fixed, - ibuff char(254) varying; - open file(input) stream title('$1.$1'); - open file(sysprint) stream output - linesize(78) pagesize(0) title('$con'); - on endfile(input) - stop; - do while('1'b); - read file(input) into(ibuff); - do i = 1 to length(ibuff); - c = substr(ibuff,i,1); - bit(i) = unspec(c); - end; - put edit((bit(i) do i = 1 to length(ibuff))) - (b4(2)); - end; - end dump; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/DUMP2.PLI b/software/CPM/CPM23_PLI/DUMP2.PLI deleted file mode 100644 index a3e337a..0000000 --- a/software/CPM/CPM23_PLI/DUMP2.PLI +++ /dev/null @@ -1,41 +0,0 @@ -dump: proc options(main); - %replace - items by 16; - dcl - sysprint file, - input file; - dcl - (i, j) fixed, - buff (128) bit(8), - c char(1), - char char(items), - record dec(5); - - on endfile(input) - stop; - - open file(input) record keyed title('$1.$1') - env (f(128),b(4000)); - open file(sysprint) stream output title('$2.$2') - env (b(4000)); - - do record = 0 by 1; - read file(input) into (buff); - do i = 0 to 127 by items; - do j = 1 to items; - if buff(i+j) < '20'b4 then - c = '.'; else - unspec(c) = buff(i+j); - substr(char,j,1) = c; - end; - if i = 0 then - put edit(record,':') (skip(2),f(5),a); - else - put edit(' ') (skip,a); - put edit((' ',buff(i+j) do j = 1 to items)) - (a,b4(2)); - put edit(' ',char) (a); - end; - end; - end dump; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/ENTER.PLI b/software/CPM/CPM23_PLI/ENTER.PLI deleted file mode 100644 index 89a0c30..0000000 --- a/software/CPM/CPM23_PLI/ENTER.PLI +++ /dev/null @@ -1,56 +0,0 @@ -enter: - proc options(main); - - %replace - true by '1'b, - false by '0'b; - - dcl - 1 employee static, - 2 name char(30) varying, - 2 addr, - 3 street char(30) varying, - 3 city char(10) varying, - 3 state char(7) varying, - 3 zip fixed dec(5), - 2 age fixed dec(3), - 2 wage fixed dec(5,2), - 2 hours fixed dec(5,1); - - dcl - 1 default static, - 2 street char (30) varying - initial('(no street)'), - 2 city char(10) varying - initial('(no city)'), - 2 state char(7) varying - initial('(no st)'), - 2 zip fixed dec(5) - initial(00000); - dcl - emp file; - - open file(emp) keyed output environment(f(100),b(8000)) - title ('$1.EMP'); - - do while(true); - put list('Employee: '); - get list(name); - if name = 'EOF' then - do; - call write(); - stop; - end; - addr = default; - put list (' Age, Wage: '); - get list (age,wage); - hours = 0; - call write(); - end; - - write: - procedure; - write file(emp) from(employee); - end write; - end enter; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/EPOLY.PLI b/software/CPM/CPM23_PLI/EPOLY.PLI deleted file mode 100644 index 90457d7..0000000 --- a/software/CPM/CPM23_PLI/EPOLY.PLI +++ /dev/null @@ -1,38 +0,0 @@ -poly: - procedure options(main); - - /* evaluate polynomial */ - - %replace - false by '0'b, - true by '1'b; - dcl - (x,y,z) float binary; - - dcl - eofile bit(1) static initial(false), - sysin file; - - on endfile(sysin) - eofile = true; - - do while(true); - put skip(2) list('Type x,y,z: '); - get list(x,y,z); - - if eofile then - stop; - - put skip list(' 2'); - put skip list(' x + 2y + z =',p(x,y,z)); - end; - - p: - proc (x,y,z) returns (float binary); - dcl - (x,y,z) float binary; - return (x * x + 2 * y + z); - end p; - - end poly; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/EXPR1.PLI b/software/CPM/CPM23_PLI/EXPR1.PLI deleted file mode 100644 index fb1d61e..0000000 --- a/software/CPM/CPM23_PLI/EXPR1.PLI +++ /dev/null @@ -1,61 +0,0 @@ -expression: - proc options(main); - dcl - sysin file, - value float, - token char(10) var; - - on endfile(sysin) - stop; - - on error(1) - /* conversion or signal */ - begin; - put skip list('Invalid Input at ',token); - get skip; - go to restart; - end; - - restart: - do while('1'b); - put skip(3) list('Type expression: '); - value = exp(); - put skip list('Value is:',value); - end; - - gnt: - proc; - get list(token); - end gnt; - - exp: - proc returns(float binary) recursive; - dcl x float binary; - call gnt(); - if token = '(' then - do; - x = exp(); - call gnt(); - if token = '+' then - x = x + exp(); - else - if token = '-' then - x = x - exp(); - else - if token = '*' then - x = x * exp(); - else - if token = '/' then - x = x / exp(); - else - signal error(1); - call gnt(); - if token ^= ')' then - signal error(1); - end; - else - x = token; - return(x); - end exp; - end expression; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/EXPR2.PLI b/software/CPM/CPM23_PLI/EXPR2.PLI deleted file mode 100644 index 0781e4a..0000000 --- a/software/CPM/CPM23_PLI/EXPR2.PLI +++ /dev/null @@ -1,91 +0,0 @@ -expression: - proc options(main); - - %replace - true by '1'b; - - dcl - sysin file, - value float, - (token char(10), line char(80)) varying - static initial(''); - - on endfile(sysin) - stop; - - on error(1) - /* conversion or signal */ - begin; - put skip list('Invalid Input at ',token); - token = ''; line = ''; - go to restart; - end; - - restart: - - do while('1'b); - put skip(3) list('Type expression: '); - value = exp(); - put edit('Value is: ',value) (skip,a,f(10,4)); - end; - - gnt: - proc; - dcl - i fixed; - - line = substr(line,length(token)+1); - do while(true); - if line = '' then - get edit(line) (a); - i = verify(line,' '); - if i = 0 then - line = ''; - else - do; - line = substr(line,i); - i = verify(line,'0123456789.'); - if i = 0 then - token = line; - else - if i = 1 then - token = substr(line,1,1); - else - token = substr(line,1,i-1); - return; - end; - end; - end gnt; - - exp: - proc returns(float binary) recursive; - dcl x float binary; - call gnt(); - if token = '(' then - do; - x = exp(); - call gnt(); - if token = '+' then - x = x + exp(); - else - if token = '-' then - x = x - exp(); - else - if token = '*' then - x = x * exp(); - else - if token = '/' then - x = x / exp(); - else - signal error(1); - call gnt(); - if token ^= ')' then - signal error(1); - end; - else - x = token; - return(x); - end exp; - - end expression; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/FACT.PLI b/software/CPM/CPM23_PLI/FACT.PLI deleted file mode 100644 index 8aac126..0000000 --- a/software/CPM/CPM23_PLI/FACT.PLI +++ /dev/null @@ -1,17 +0,0 @@ -f: - proc options(main); - dcl - i fixed; - do i = 0 repeat(i+1); - put skip list('factorial(',i,')=',fact(i)); - end; - stop; - - fact: - procedure(i) returns(fixed) recursive; - dcl i fixed; - if i = 0 then return (1); - return (i * fact(i-1)); - end fact; - end f; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/FCB.DCL b/software/CPM/CPM23_PLI/FCB.DCL deleted file mode 100644 index 2992944..0000000 --- a/software/CPM/CPM23_PLI/FCB.DCL +++ /dev/null @@ -1,16 +0,0 @@ - 2 name1, - 3 drive fixed(7), /* drive number */ - 3 fname char(8), /* file name */ - 3 ftype char(3), /* file type */ - 3 fext fixed(7), /* file extent */ - 3 space (3) bit(8),/* filler */ - 2 name2, /* used in rename */ - 3 drive2 fixed(7), - 3 fname2 char(8), - 3 ftype2 char(3), - 3 fext2 fixed(7), - 3 space2 (3) bit(8), - 2 crec fixed(7), /* current record */ - 2 rrec fixed(15), /* random record */ - 2 rovf fixed(7); /* random rec overflow */ - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/FDIV2.ASM b/software/CPM/CPM23_PLI/FDIV2.ASM deleted file mode 100644 index 0c6a16e..0000000 --- a/software/CPM/CPM23_PLI/FDIV2.ASM +++ /dev/null @@ -1,63 +0,0 @@ - title 'div by power of two (function)' - public fdiv2 - extrn ?signal -; entry: -; p1 -> fixed(7) power of two -; p2 -> floating point number -; exit: -; p1 -> (unchanged) -; p2 -> (unchanged) -; stack: p2 / (2 ** p1) -fdiv2: ;HL = .low(.p1) - mov e,m ;low(.p1) - inx h ;HL = .high(.p1) - mov d,m ;DE = .p1 - inx h ;HL = .low(p2) - ldax d ;a = p1 (power of two) - mov e,m ;low(.p2) - inx h ;HL = .high(.p2) - mov d,m ;DE = .p2 - xchg ;HL = .p2 -; -; A = power of 2, HL = .low byte of fp num - mov e,m ;E = low mantissa - inx h ;to middle of mantissa - mov d,m ;D = middle mantissa - inx h ;to high byte of mantissa - mov c,m ;C = high mantissa - inx h ;to exponent byte - mov b,m ;B = exponent - inr b ;B = 00? - dcr b ;becomes 00 if so - jz fdret ;to return from float div -dby2: ;divide by two - ora a ;counted power of 2 to zero? - jz fdret ;return if so - dcr a ;count power of two down - dcr b ;count exponent down - jnz dby2 ;loop again if no underflow -; -;underflow occurred, signal underflow condition - lxi h,siglst;signal parameter list - call ?signal ;signal underflow - lxi b,0 ;clear to zero - lxi d,0 ;for default return -; -fdret: pop h ;recall return address - push b ;save high order fp num - push d ;save low order fp num - pchl ;return to calling routine -; - dseg -siglst: dw sigcod ;address of signal code - dw sigsub ;address of subcode - dw sigfil ;address of file code - dw sigaux ;address of aux message -; end of parameter vector, start of params -sigcod: db 3 ;03 = underflow -sigsub: db 128 ;arbitrary subcode for id -sigfil: dw 0000 ;no associated file name -sigaux: dw undmsg ;0000 if no aux message -undmsg: db 32,'Underflow in Divide by Two',0 - end - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/FDTEST.PLI b/software/CPM/CPM23_PLI/FDTEST.PLI deleted file mode 100644 index 908c503..0000000 --- a/software/CPM/CPM23_PLI/FDTEST.PLI +++ /dev/null @@ -1,14 +0,0 @@ -dtest: - proc options(main); - dcl - fdiv2 entry(fixed(7),float) - returns(float), - i fixed(7), - f float; - - do i = 0 by 1; - put skip list('100 / 2 **',i,'=', - fdiv2(i,100)); - end; - end dtest; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/FFACT.PLI b/software/CPM/CPM23_PLI/FFACT.PLI deleted file mode 100644 index 617b6db..0000000 --- a/software/CPM/CPM23_PLI/FFACT.PLI +++ /dev/null @@ -1,18 +0,0 @@ -f: - proc options(main); - dcl - i fixed; - do i = 0 repeat(i+1); - put skip list('factorial(',i,')=',fact(i)); - end; - stop; - - fact: - procedure(i) returns(float) recursive; - dcl i fixed; - if i = 0 then - return(1); - return (i * fact(i-1)); - end fact; - end f; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/FIB.PLI b/software/CPM/CPM23_PLI/FIB.PLI deleted file mode 100644 index 8e0502f..0000000 --- a/software/CPM/CPM23_PLI/FIB.PLI +++ /dev/null @@ -1,18 +0,0 @@ -fibonacci: - proc options(main); - dcl i fixed; - do i = 0 to 100; - put list(fib(i)); - end; - - fib: - proc(n) returns(fixed) recursive; - dcl n fixed; - if n = 0 then - return(1); - if n = 1 then - return(1); - return(fib(n-1) + fib(n-2)); - end fib; - end fibonacci; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/FSCAN.PLI b/software/CPM/CPM23_PLI/FSCAN.PLI deleted file mode 100644 index b1a5956..0000000 --- a/software/CPM/CPM23_PLI/FSCAN.PLI +++ /dev/null @@ -1,44 +0,0 @@ -fscan: - proc options(main); - %replace - true by '1'b; - dcl - token char(80) var - static initial(''); - - gnt: - proc; - dcl - i fixed, - line char(80) var - static initial(''); - - line = substr(line,length(token)+1); - do while(true); - if line = '' then - get edit(line) (a); - i = verify(line,' '); - if i = 0 then - line = ''; - else - do; - line = substr(line,i); - i = verify(line,'0123456789.'); - if i = 0 then - token = line; - else - if i = 1 then - token = substr(line,1,1); - else - token = substr(line,1,i-1); - return; - end; - end; - end gnt; - - do while(true); - call gnt; - put edit(''''!!token!!'''') (x(1),a); - end; - end fscan; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/GOTO.PLI b/software/CPM/CPM23_PLI/GOTO.PLI deleted file mode 100644 index f2440ec..0000000 --- a/software/CPM/CPM23_PLI/GOTO.PLI +++ /dev/null @@ -1,37 +0,0 @@ -main: - proc options(main); - dcl - i fixed, - (x, y, z(3)) label; - x = lab1; - y = x; - - go to lab1; - go to x; - go to y; - - call p(lab2); - - do i = 1 to 3; - z(i) = c(1); - end; - - i = 2; - go to z(i); - go to c(i); - - c(1):; - c(2):; - c(3):; - - lab1:; - lab2:; - - p: - proc(g); - dcl - g label; - go to g; - end p; - end main; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/GRADE.PLI b/software/CPM/CPM23_PLI/GRADE.PLI deleted file mode 100644 index cd62a04..0000000 --- a/software/CPM/CPM23_PLI/GRADE.PLI +++ /dev/null @@ -1,38 +0,0 @@ -average: - proc options (main); - /* grade averaging program */ - - dcl - sysin file, - (grade,total,n) fixed; - - on error (1) - /* conversion */ - begin; - put skip list('Bad Value, Try Again.'); - get skip; - go to retry; - end; - - on endfile (sysin) - begin; - if n ^= 0 then - put skip list - ('Average is',total/n); - stop; - end; - - put skip list - ('Type a List of Grades, End with Ctl-Z'); - total = 0; - n = 0; - - retry: - put skip; - do while('1'b); - get list (grade); - total = total + grade; - n = n + 1; - end; - end average; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/IFACT.PLI b/software/CPM/CPM23_PLI/IFACT.PLI deleted file mode 100644 index b865211..0000000 --- a/software/CPM/CPM23_PLI/IFACT.PLI +++ /dev/null @@ -1,14 +0,0 @@ -f: - proc options(main); - dcl - (i,n,fact) fixed; - do i = 0 by 1; - fact = 1; - do n = i to 1 by -1; - fact = n * fact; - end; - put edit('factorial(',i,')=',fact) - (skip, a,f(2),a,f(7)); - end; - end f; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/INVERT1.PLI b/software/CPM/CPM23_PLI/INVERT1.PLI deleted file mode 100644 index 17b3baf..0000000 --- a/software/CPM/CPM23_PLI/INVERT1.PLI +++ /dev/null @@ -1,61 +0,0 @@ -inv: - procedure options(main); - %replace - true by '1'b, - false by '0'b; -%include 'matsize.lib'; - dcl - mat(maxrow,maxcol) float (24); - dcl - (i,j,n,m) fixed(6); - dcl - var char(26) static initial - ('abcdefghijklmnopqrstuvwxyz'); - dcl - invert entry - ((maxrow,maxcol) float(24), fixed(6), fixed(6)); - - put list('Solution of Simultaneous Equations'); - do while(true); - put skip(2) list('Type rows, columns: '); - get list(n); - if n = 0 then - stop; - - get list(m); - if n > maxrow ! m > maxcol then - put skip list('Matrix is Too Large'); - else - do; - put skip list('Type Matrix of Coefficients'); - put skip; - do i = 1 to n; - put list('Row',i,':'); - get list((mat(i,j) do j = 1 to n)); - end; - - put skip list('Type Solution Vectors'); - put skip; - do j = n + 1 to m; - put list('Variable',substr(var,j-n,1),':'); - get list((mat(i,j) do i = 1 to n)); - end; - - call invert(mat,n,m); - put skip(2) list('Solutions:'); - do i = 1 to n; - put skip list(substr(var,i,1),'='); - put edit((mat(i,j) do j = 1 to m-n)) - (f(8,2)); - end; - - put skip(2) list('Inverse Matrix is'); - do i = 1 to n; - put skip edit - ((mat(i,j) do j = m-n+1 to m)) - (x(3),6f(8,2),skip); - end; - end; - end; -end inv; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/INVERT2.PLI b/software/CPM/CPM23_PLI/INVERT2.PLI deleted file mode 100644 index cc8d067..0000000 --- a/software/CPM/CPM23_PLI/INVERT2.PLI +++ /dev/null @@ -1,25 +0,0 @@ -invert: - proc (a,r,c); -%include 'matsize.lib'; - dcl - (d, a(maxrow,maxcol)) float (24), - (i,j,k,l,r,c) fixed (6); - do i = 1 to r; - d = a(i,1); - do j = 1 to c - 1; - a(i,j) = a(i,j+1)/d; - end; - a(i,c) = 1/d; - do k = 1 to r; - if k ^= i then - do; - d = a(k,1); - do l = 1 to c - 1; - a(k,l) = a(k,l+1) - a(i,l) * d; - end; - a(k,c) = - a(i,c) * d; - end; - end; - end; -end invert; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/KEYFILE.PLI b/software/CPM/CPM23_PLI/KEYFILE.PLI deleted file mode 100644 index 582ac9e..0000000 --- a/software/CPM/CPM23_PLI/KEYFILE.PLI +++ /dev/null @@ -1,30 +0,0 @@ -keypr: - proc options(main); - - /* create key from employee file */ - - dcl - 1 employee static, - 2 name char(30) varying; - - dcl - (input, keys) file; - - dcl - k fixed; - - open title('$1.emp') keyed - env(f(100),b(10000)) file(input); - - open file (keys) stream output - linesize (60) title('$1.key'); - - do while('1'); - read file(input) into(employee) keyto(k); - put skip list(k,name); - put file(keys) list(name,k); - if name = 'EOF' then - stop; - end; - end keypr; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/LIB.COM b/software/CPM/CPM23_PLI/LIB.COM deleted file mode 100644 index d9e6a5c..0000000 Binary files a/software/CPM/CPM23_PLI/LIB.COM and /dev/null differ diff --git a/software/CPM/CPM23_PLI/LINK.COM b/software/CPM/CPM23_PLI/LINK.COM deleted file mode 100644 index 0d3d599..0000000 Binary files a/software/CPM/CPM23_PLI/LINK.COM and /dev/null differ diff --git a/software/CPM/CPM23_PLI/MACASM.PLI b/software/CPM/CPM23_PLI/MACASM.PLI deleted file mode 100644 index 777f99d..0000000 --- a/software/CPM/CPM23_PLI/MACASM.PLI +++ /dev/null @@ -1,154 +0,0 @@ -xl: - proc options(main); - /************************************************ - * (Another Sample Program....) * - * * - * this program aids in the translation of files * - * in the microsoft assembly language format, to * - * a form acceptable by RMAC. In particular, * - * RMAC requires quotes around the title string * - * and does not allow parentheses around the * - * operand of the NAME pseudo-op. Although these* - * differences only produce warnings, this pro- * - * gram can be used to automatically change these* - * elements. Note that upper case letters are * - * also changed to lower case outside of string * - * quotes. The program is initiated by typing: * - * MACASM commandfile listing * - * where "commandfile" is a file containing a * - * list of file names to process, with the file * - * type MAC, and "listing" is the name of a * - * file to receive a listing of the changes. * - * the source files must be on drive A, and the * - * resulting files, with the new file type ASM * - * are placed on drive B (this can be easily * - * generalized by making simple changes to the * - * program). Note that the listing file can be * - * $LST which sends output to the printer. * - * * - ************************************************/ - %replace - true by '1'b, - false by '0'b; - dcl - (input, output, command, listing) file, - i fixed, - column fixed, - c char, - line char(254) var, - lineno fixed, - title char (254) var; - open file (listing) print title('$2.$2'); - open file (command) title('$1.$1'); - on endfile(command) - stop; - on undefinedfile(input) - begin; - put skip list('***** file not found *****'); - go to retry; - end; - - retry: - do while('1'b); - get file(command) list(title); - open file (input) title('a:'||title||'.mac') - env(b(5000)); - open file (output) stream output - title('b:'||title||'.asm') env(b(5000)); - put file(listing) skip list('Processing:',title); - on endfile(input) - go to nextfile; - do lineno = 1 by 1; - get file(input) edit(line) (a); - if translate() then - do; - put skip file(listing) - list(lineno,':'); - column = 1; - do i = 1 to length(line); - c = substr(line,i,1); - if c = '^i' then - do while(mod(column,8)^=0); - put file(listing) edit(' ')(a); - column = column + 1; - end; - else - do; - put file(listing) edit(c) (a); - column = column + 1; - end; - end; - end; - put file(output) edit(line) (a); - put file(output) skip; - end; - nextfile: - put skip(3) file(listing); - revert endfile(input); - close file(input); - close file(output); - end; - - translate: - proc returns(bit); - /* translate current line */ - dcl - (i,j) fixed, - xl bit, - linelen fixed; - xl = lowercase(); - i = index(line,'name^i'); - if i ^= 0 then - do; - /* look for ('xxx') */ - i = i + 5; - if substr(line,i,1) = '(' then - do; - line = substr(line,1,length(line)-1); - line = substr(line,1,i-1) || - substr(line,i+1); - end; - xl = true; - end; - i = index(line,'title^i'); - if i ^= 0 then - do; - /* look for missing parens */ - i = i + 6; - if substr(line,i,1) ^= '''' then - line = substr(line,1,i-1) || - '''' || - substr(line,i) || ''''; - xl = true; - end; - return (xl); - end translate; - - lowercase: - proc returns(bit); - /* translate to lower case */ - dcl - q bit, - i fixed, - rc fixed, - c char, - lc bit; - lc = false; - q = false; - do i = 1 to length(line); - c = substr(line,i,1); - if c = '''' then - q = ^q; - rc = rank(c) - rank('A'); - if ^q then - if rc >= 0 then - if rc <= 25 then - do; - lc = true; - substr(line,i,1) = ascii(rc+rank('a')); - end; - end; - return (lc); - end lowercase; - end xl; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/MATSIZ.LIB b/software/CPM/CPM23_PLI/MATSIZ.LIB deleted file mode 100644 index ab5d02a..0000000 --- a/software/CPM/CPM23_PLI/MATSIZ.LIB +++ /dev/null @@ -1,4 +0,0 @@ - %replace - maxrow by 26, - maxcol by 40; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/MATSIZE.LIB b/software/CPM/CPM23_PLI/MATSIZE.LIB deleted file mode 100644 index ab5d02a..0000000 --- a/software/CPM/CPM23_PLI/MATSIZE.LIB +++ /dev/null @@ -1,4 +0,0 @@ - %replace - maxrow by 26, - maxcol by 40; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/NET.PLI b/software/CPM/CPM23_PLI/NET.PLI deleted file mode 100644 index 054a35e..0000000 --- a/software/CPM/CPM23_PLI/NET.PLI +++ /dev/null @@ -1,217 +0,0 @@ -graph: - proc options(main); - %replace - true by '1'b, - false by '0'b, - citysize by 20, - infinite by 32767; - dcl - sysin file; - dcl - 1 city_node based, - 2 city_name char(citysize) var, - 2 total_dist fixed, - 2 investigate bit, - 2 city_list ptr, - 2 route_head ptr; - dcl - 1 route_node based, - 2 next_city ptr, - 2 route_dist fixed, - 2 route_list ptr; - dcl - city_head ptr; - - do while(true); - call setup(); - if city_head = null then - stop; - call print_all(); - call print_paths(); - call free_all(); - end; - - setup: - proc; - dcl - dist fixed, - (city1, city2) char(citysize) var; - on endfile(sysin) go to eof; - city_head = null; - put skip list('Type "City1, Dist, City2"'); - put skip; - do while(true); - get list(city1, dist, city2); - call connect(city1, dist, city2); - call connect(city2, dist, city1); - end; - eof: - end setup; - - connect: - proc(source_city, dist, dest_city); - dcl - source_city char(citysize) var, - dist fixed, - dest_city char(citysize) var; - dcl - (r, s, d) ptr; - s = find(source_city); - d = find(dest_city); - allocate route_node set (r); - r->route_dist = dist; - r->next_city = d; - r->route_list = s->route_head; - s->route_head = r; - end connect; - - find: - proc(city) returns(ptr); - dcl - city char(citysize) var; - dcl - (p, q) ptr; - do p = city_head - repeat(p->city_list) while(p^=null); - if city = p->city_name then - return(p); - end; - allocate city_node set(p); - p->city_name = city; - p->city_list = city_head; - city_head = p; - p->total_dist = infinite; - p->route_head = null; - return(p); - end find; - - print_all: - proc; - dcl - (p, q) ptr; - do p = city_head - repeat(p->city_list) while(p^=null); - put skip list(p->city_name,':'); - do q = p->route_head - repeat(q->route_list) while(q^=null); - put skip list(q->route_dist,'miles to', - q->next_city->city_name); - end; - end; - end print_all; - - print_paths: - proc; - dcl - city char(citysize) var; - on endfile(sysin) go to eof; - do while(true); - put skip list('Type Destination '); - get list(city); - call shortest_dist(city); - on endfile(sysin) go to eol; - do while(true); - put skip list('Type Start '); - get list(city); - call print_route(city); - end; - eol: revert endfile(sysin); - end; - eof: - end print_paths; - - shortest_dist: - proc(city); - dcl - city char(citysize) var; - dcl - bestp ptr, - (d, bestd) fixed, - (p, q, r) ptr; - do p = city_head - repeat(p->city_list) while(p^=null); - p->total_dist = infinite; - p->investigate = false; - end; - p = find(city); - p->total_dist = 0; - p->investigate = true; - do while(true); - bestp = null; - bestd = infinite; - do p = city_head - repeat(p->city_list) while(p^=null); - if p->investigate then - do; - if p->total_dist < bestd then - do; - bestd = p->total_dist; - bestp = p; - end; - end; - end; - if bestp = null then - return; - bestp->investigate = false; - do q = bestp->route_head - repeat(q->route_list) while(q^=null); - r = q->next_city; - d = bestd + q->route_dist; - if d < r->total_dist then - do; - r->total_dist = d; - r->investigate = true; - end; - end; - end; - end shortest_dist; - - print_route: - proc(city); - dcl - city char(citysize) var; - dcl - (p, q) ptr, - (t, d) fixed; - p = find(city); - do while(true); - t = p->total_dist; - if t = infinite then - do; - put skip list('(No Connection)'); - return; - end; - if t = 0 then - return; - put skip list(t,'miles remain,'); - q = p->route_head; - do while(q^=null); - p = q->next_city; - d = q->route_dist; - if t = d + p->total_dist then - do; - put list(d,'miles to',p->city_name); - q = null; - end; else - q = q->route_list; - end; - end; - end print_route; - - free_all: - proc; - dcl - (p, q) ptr; - do p = city_head - repeat(p->city_list) while(p^=null); - do q = p->route_head - repeat(q->route_list) while(q^=null); - free q->route_node; - end; - free p->city_node; - end; - end free_all; - - end graph; - free p->city_node; - e \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/NETASM.PLI b/software/CPM/CPM23_PLI/NETASM.PLI deleted file mode 100644 index 4b3e5b9..0000000 --- a/software/CPM/CPM23_PLI/NETASM.PLI +++ /dev/null @@ -1,222 +0,0 @@ -graph: - proc options(main); - %replace - true by '1'b, - false by '0'b, - citysize by 20, - infinite by 32767; - dcl - (twords, mwords) entry returns(fixed); - dcl - sysin file; - dcl - 1 city_node based, - 2 city_name char(citysize) var, - 2 total_dist fixed, - 2 investigate bit, - 2 city_list ptr, - 2 route_head ptr; - dcl - 1 route_node based, - 2 next_city ptr, - 2 route_dist fixed, - 2 route_list ptr; - dcl - city_head ptr; - - do while(true); - put skip edit - ('^gTotal Storage = ',twords(),' Words', - 'Max Available = ',mwords(),' Words') - (2(column(10),a,f(6),a,skip),skip(4)); - call setup(); - if city_head = null then - stop; - call print_all(); - call print_paths(); - call free_all(); - end; - - setup: - proc; - dcl - dist fixed, - (city1, city2) char(citysize) var; - on endfile(sysin) go to eof; - city_head = null; - put skip list('Type "City1, Dist, City2"'); - put skip; - do while(true); - get list(city1, dist, city2); - call connect(city1, dist, city2); - call connect(city2, dist, city1); - end; - eof: - end setup; - - connect: - proc(source_city, dist, dest_city); - dcl - source_city char(citysize) var, - dist fixed, - dest_city char(citysize) var; - dcl - (r, s, d) ptr; - s = find(source_city); - d = find(dest_city); - allocate route_node set (r); - r->route_dist = dist; - r->next_city = d; - r->route_list = s->route_head; - s->route_head = r; - end connect; - - find: - proc(city) returns(ptr); - dcl - city char(citysize) var; - dcl - (p, q) ptr; - do p = city_head - repeat(p->city_list) while(p^=null); - if city = p->city_name then - return(p); - end; - allocate city_node set(p); - p->city_name = city; - p->city_list = city_head; - city_head = p; - p->total_dist = infinite; - p->route_head = null; - return(p); - end find; - - print_all: - proc; - dcl - (p, q) ptr; - do p = city_head - repeat(p->city_list) while(p^=null); - put skip list(p->city_name,':'); - do q = p->route_head - repeat(q->route_list) while(q^=null); - put skip list(q->route_dist,'miles to', - q->next_city->city_name); - end; - end; - end print_all; - - print_paths: - proc; - dcl - city char(citysize) var; - on endfile(sysin) go to eof; - do while(true); - put skip list('Type Destination '); - get list(city); - call shortest_dist(city); - on endfile(sysin) go to eol; - do while(true); - put skip list('Type Start '); - get list(city); - call print_route(city); - end; - eol: revert endfile(sysin); - end; - eof: - end print_paths; - - shortest_dist: - proc(city); - dcl - city char(citysize) var; - dcl - bestp ptr, - (d, bestd) fixed, - (p, q, r) ptr; - do p = city_head - repeat(p->city_list) while(p^=null); - p->total_dist = infinite; - p->investigate = false; - end; - p = find(city); - p->total_dist = 0; - p->investigate = true; - do while(true); - bestp = null; - bestd = infinite; - do p = city_head - repeat(p->city_list) while(p^=null); - if p->investigate then - do; - if p->total_dist < bestd then - do; - bestd = p->total_dist; - bestp = p; - end; - end; - end; - if bestp = null then - return; - bestp->investigate = false; - do q = bestp->route_head - repeat(q->route_list) while(q^=null); - r = q->next_city; - d = bestd + q->route_dist; - if d < r->total_dist then - do; - r->total_dist = d; - r->investigate = true; - end; - end; - end; - end shortest_dist; - - print_route: - proc(city); - dcl - city char(citysize) var; - dcl - (p, q) ptr, - (t, d) fixed; - p = find(city); - do while(true); - t = p->total_dist; - if t = infinite then - do; - put skip list('(No Connection)'); - return; - end; - if t = 0 then - return; - put skip list(t,'miles remain,'); - q = p->route_head; - do while(q^=null); - p = q->next_city; - d = q->route_dist; - if t = d + p->total_dist then - do; - put list(d,'miles to',p->city_name); - q = null; - end; else - q = q->route_list; - end; - end; - end print_route; - - free_all: - proc; - dcl - (p, px, q, qx) ptr; - do p = city_head repeat(px) while(p^=null); - do q = p->route_head repeat(qx) while(q^=null); - qx = q->route_list; - free q->route_node; - end; - px = p->city_list; - free p->city_node; - end; - end free_all; - - end graph; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/OPTIMIST.COM b/software/CPM/CPM23_PLI/OPTIMIST.COM deleted file mode 100644 index 7c33bca..0000000 Binary files a/software/CPM/CPM23_PLI/OPTIMIST.COM and /dev/null differ diff --git a/software/CPM/CPM23_PLI/OPTIMIST.PLI b/software/CPM/CPM23_PLI/OPTIMIST.PLI deleted file mode 100644 index 52c50df..0000000 --- a/software/CPM/CPM23_PLI/OPTIMIST.PLI +++ /dev/null @@ -1,44 +0,0 @@ -optimist: - proc options(main); - %replace - true by '1'b, - false by '0'b, - nwords by 5; - dcl - negative (1:nwords) char(8) var static initial - (' never',' none',' nothing',' not',' no'), - positive (1:nwords) char(10) var static initial - (' always',' all',' something','',' some'), - upper char(28) static initial - ('ABCDEFGHIJKLMNOPQRSTUVWXYZ. '), - lower char(28) static initial - ('abcdefghijklmnopqrstuvwxyz. '); - dcl - sent char(254) var, - word char(32) var; - dcl - (i,j) fixed; - - do while(true); - put skip list('What''s up? '); - sent = ' '; - do while - (substr(sent,length(sent)) ^= '.'); - get list (word); - sent = sent !! ' ' !! word; - end; - sent = translate(sent,lower,upper); - if verify(sent,lower) ^= 0 then - sent = ' that''s an interesting idea.'; - do i = 1 to nwords; - j = index(sent,negative(i)); - if j ^= 0 then - sent = substr(sent,1,j-1) !! - positive(i) !! - substr(sent,j+length(negative(i))); - end; - put list('Actually,'!!sent); - put skip; - end; - end optimist; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/PLANT1.EMP b/software/CPM/CPM23_PLI/PLANT1.EMP deleted file mode 100644 index 0e63947..0000000 Binary files a/software/CPM/CPM23_PLI/PLANT1.EMP and /dev/null differ diff --git a/software/CPM/CPM23_PLI/PLANT2.EMP b/software/CPM/CPM23_PLI/PLANT2.EMP deleted file mode 100644 index 567c70e..0000000 Binary files a/software/CPM/CPM23_PLI/PLANT2.EMP and /dev/null differ diff --git a/software/CPM/CPM23_PLI/PLI.COM b/software/CPM/CPM23_PLI/PLI.COM deleted file mode 100644 index 8c5db57..0000000 Binary files a/software/CPM/CPM23_PLI/PLI.COM and /dev/null differ diff --git a/software/CPM/CPM23_PLI/PLI0.OVL b/software/CPM/CPM23_PLI/PLI0.OVL deleted file mode 100644 index 8c5d942..0000000 Binary files a/software/CPM/CPM23_PLI/PLI0.OVL and /dev/null differ diff --git a/software/CPM/CPM23_PLI/PLI1.OVL b/software/CPM/CPM23_PLI/PLI1.OVL deleted file mode 100644 index 5d27896..0000000 Binary files a/software/CPM/CPM23_PLI/PLI1.OVL and /dev/null differ diff --git a/software/CPM/CPM23_PLI/PLI2.OVL b/software/CPM/CPM23_PLI/PLI2.OVL deleted file mode 100644 index 0825772..0000000 Binary files a/software/CPM/CPM23_PLI/PLI2.OVL and /dev/null differ diff --git a/software/CPM/CPM23_PLI/PLIDIO.ASM b/software/CPM/CPM23_PLI/PLIDIO.ASM deleted file mode 100644 index 04d9eca..0000000 --- a/software/CPM/CPM23_PLI/PLIDIO.ASM +++ /dev/null @@ -1,607 +0,0 @@ - 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 - 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 - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/PLILIB.IRL b/software/CPM/CPM23_PLI/PLILIB.IRL deleted file mode 100644 index 554b083..0000000 Binary files a/software/CPM/CPM23_PLI/PLILIB.IRL and /dev/null differ diff --git a/software/CPM/CPM23_PLI/POLY.PLI b/software/CPM/CPM23_PLI/POLY.PLI deleted file mode 100644 index b457b6e..0000000 --- a/software/CPM/CPM23_PLI/POLY.PLI +++ /dev/null @@ -1,31 +0,0 @@ -poly: - procedure options(main); - - /* evaluate polynomial */ - - %replace - false by '0'b, - true by '1'b; - dcl - (x,y,z) float binary; - - do while(true); - put skip(2) list('Type x,y,z: '); - get list(x,y,z); - - if x = 0 & y = 0 & z = 0 then - stop; - - put skip list(' 2'); - put skip list(' x + 2y + z =',p(x,y,z)); - end; - - p: - proc (x,y,z) returns (float binary); - dcl - (x,y,z) float binary; - return (x * x + 2 * y + z); - end p; - - end poly; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/RANDOM.PLI b/software/CPM/CPM23_PLI/RANDOM.PLI deleted file mode 100644 index b87742d..0000000 --- a/software/CPM/CPM23_PLI/RANDOM.PLI +++ /dev/null @@ -1,68 +0,0 @@ -random: - procedure options(main); - /* test random number generator */ - %replace - dseed by 899, /* default seed */ - clear by '^z', /* clear screen character */ - width by 70, /* histogram width */ - nslots by 20; /* length of histogram */ - dcl - xseed fixed static initial(899); - dcl - k fixed, - (n, max) decimal, - slot(nslots) decimal; - - put list('Number of RAND Calls: '); - get list(max); - put list('Seed Value (or comma) '); - xseed = dseed; - get list(xseed); - do k = lbound(slot,1) to hbound(slot,1); - slot(k) = 0; - end; - - do n = 1 to max; - k = rand(xseed) * nslots + 1; - if k < lbound(slot,1) | k > hbound(slot,1) then - put skip list(k,'Out of Range'); - slot(k) = slot(k) + 1; - if mod(n,100) = 0 then - call histogram(); - end; - call histogram(); - stop; - - histogram: - procedure; - dcl - largest decimal, - (i, j) fixed; - largest = 0; - do i = lbound(slot,1) to hbound(slot,1); - if slot(i) > largest then - largest = slot(i); - end; - if largest = 0 then - return; - put skip list(clear,'Largest Value',largest); - if largest < width then - largest = width; - do i = lbound(slot,1) to hbound(slot,1); - put edit(slot(i), - ('*' do j = 1 to slot(i)*width/largest)) - (skip,f(7),x(1),width(a)); - end; - end histogram; - - rand: - proc (seed) returns(float); - dcl - seed fixed; - seed = seed * 899; - unspec(seed)=unspec(seed) & '7FFF'b4; - return (float(seed)/32768.); - - end rand; - end random; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/READ.ME b/software/CPM/CPM23_PLI/READ.ME deleted file mode 100644 index f437d6f..0000000 --- a/software/CPM/CPM23_PLI/READ.ME +++ /dev/null @@ -1,4 +0,0 @@ -This zip file contains the PLI compiler. It came from an old set of diskettes -that I personaly used many years ago. I believe it to be complete. - - diff --git a/software/CPM/CPM23_PLI/RECORD.DCL b/software/CPM/CPM23_PLI/RECORD.DCL deleted file mode 100644 index 3a22c82..0000000 --- a/software/CPM/CPM23_PLI/RECORD.DCL +++ /dev/null @@ -1,9 +0,0 @@ - dcl - 1 record, - 2 name character(30) varying, - 2 addr character(30) varying, - 2 city character(20) varying, - 2 state character(10) varying, - 2 zip fixed decimal(6), - 2 phone character(12) varying; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/REPORT.PLI b/software/CPM/CPM23_PLI/REPORT.PLI deleted file mode 100644 index 0ef87fd..0000000 --- a/software/CPM/CPM23_PLI/REPORT.PLI +++ /dev/null @@ -1,56 +0,0 @@ -report: - procedure options(main); - - dcl - 1 employee static, - 2 name character(30) varying, - 2 addr, - 3 street character(30) varying, - 3 city character(10) varying, - 3 state character(7) varying, - 3 zip fixed dec(5), - 2 age fixed dec(3), - 2 wage fixed dec(5,2), - 2 hours fixed dec(5,1); - - dcl - dashes character(15) static initial - ('$--------------'), - buff character(20) varying; - - dcl - i fixed, - (grosspay, withhold) fixed dec(7,2); - - dcl - (repfile, empfile) file; - - open file(empfile) keyed env(f(100),b(4000)) - title ('$1.EMP'); - - open file(repfile) stream print title('$2.$2') - environment(b(2000)); - - put list('Set Top of Forms, Type Return'); - get skip; - - do while('1'b); - read file(empfile) into(employee); - if name = 'EOF' then - stop; - put file(repfile) skip(2); - buff = '[' !! name !! ']^m^j'; - write file(repfile) from (buff); - grosspay = wage * hours; - withhold = grosspay * .15; - buff = grosspay - withhold; - do i = 1 to 15 - while (substr(buff,i,1) = ' '); - end; - i = i - 1; - substr(buff,1,i) = substr(dashes,1,i); - write file (repfile) from(buff); - end; - - end report; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/RETRIEVE.PLI b/software/CPM/CPM23_PLI/RETRIEVE.PLI deleted file mode 100644 index ab8ba7b..0000000 --- a/software/CPM/CPM23_PLI/RETRIEVE.PLI +++ /dev/null @@ -1,55 +0,0 @@ -retrieve: - procedure options(main); - /* name and address retrieval program */ - -%include 'record.dcl'; - - %replace - true by '1'b, - false by '0'b; - - dcl - (sysprint, input) file; - - dcl - filename character(14) varying, - (lower, upper) character(30) varying, - eofile bit(1); - - open file(sysprint) print title('$con'); - put list('Name and Address Retrieval, File Name: '); - get list(filename); - - do while(true); - lower = 'AAAAAAAAAAAAAAAAAAAAAAAAAAAAAA'; - upper = 'zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz'; - put skip(2) list('Type Lower, Upper Bounds: '); - get list(lower,upper); - if lower = 'EOF' then - stop; - - open file(input) stream input environment(b(1024)) - title(filename); - eofile = false; - do while (^eofile); - get file(input) list(name); - eofile = (name = 'EOF'); - if ^eofile then - do; - get file(input) - list(addr,city,state,zip,phone); - if name >= lower & name <= upper then - do; - put page skip(3) - list(name); - put skip list(addr); - put skip list(city,state); - put skip list(zip); - put skip list(phone); - end; - end; - end; - close file(input); - end; - end retrieve; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/REV.PLI b/software/CPM/CPM23_PLI/REV.PLI deleted file mode 100644 index 533691f..0000000 --- a/software/CPM/CPM23_PLI/REV.PLI +++ /dev/null @@ -1,50 +0,0 @@ -reverse: - proc options(main); - dcl - sentence ptr, - 1 wordnode based (sentence), - 2 word char(30) varying, - 2 next ptr; - - do while('1'b); - call read(); - if sentence = null then - stop; - call write(); - end; - - read: - proc; - dcl - newword char(30) varying, - newnode ptr; - sentence = null; - put skip list('What''s up? '); - do while('1'b); - get list(newword); - if newword = '.' then - return; - allocate wordnode set (newnode); - newnode->next = sentence; - sentence = newnode; - word = newword; - end; - end read; - - write: - proc; - dcl - p ptr; - put skip list('Actually, '); - do while (sentence ^= null); - put list(word); - p = sentence; - sentence = next; - free p->wordnode; - end; - put list('.'); - put skip; - end write; - - end reverse; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/REVERT.PLI b/software/CPM/CPM23_PLI/REVERT.PLI deleted file mode 100644 index 5fe2186..0000000 --- a/software/CPM/CPM23_PLI/REVERT.PLI +++ /dev/null @@ -1,25 +0,0 @@ -revert: - proc options(main); - dcl - i fixed, - sysin file; - - do i = 1 to 10000; - call p(i,exit); - exit: - end; - - p: - proc(index,lab); - dcl - (t, index) fixed, - lab label; - on endfile(sysin) - go to lab; - put skip list(index,':'); - get list(t); - if t = index then - go to lab; - end p; - end revert; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/RMAC.COM b/software/CPM/CPM23_PLI/RMAC.COM deleted file mode 100644 index 8fc9f0e..0000000 Binary files a/software/CPM/CPM23_PLI/RMAC.COM and /dev/null differ diff --git a/software/CPM/CPM23_PLI/SELECT.PLI b/software/CPM/CPM23_PLI/SELECT.PLI deleted file mode 100644 index 4c4968c..0000000 --- a/software/CPM/CPM23_PLI/SELECT.PLI +++ /dev/null @@ -1,78 +0,0 @@ -select: - proc options(main); - /***************************************************** - * * - * This program is used to selectively print pages * - * from a TEX file, using the command shown below * - * * - * select source destination * - * * - * where "source" is a source file, usually a "prn" * - * file produced by TEX, and "destination" is a file * - * or device (e.g., $lst) to receive the selected * - * output pages. The program prompts the console: * - * * - * Page Length: p (or "," followed by return) * - * * - * where p is the page length (default is 66). * - * * - * Range of Pages: n,m * - * * - * where n is the first page to print, and m is the * - * last page. The range prompt will continue until * - * the end of the document is encountered, or an end * - * of file is entered at the console. * - * * - *****************************************************/ - %replace - true by '1'b, - false by '0'b, - copy by true, - deflen by 66, - nocopy by false; - dcl - (sysin, input, output) file, - (lower, upper, page, pagelen) fixed, - linebuff char(254) var; - - open file(input) title('$1.prn') env(b(8000)); - on endfile(sysin) - stop; - on endfile(input) - stop; - open file(output) output title('$2.$2') - env(b(8000)); - - pagelen = deflen; - put list('Page Length: '); - get list(pagelen); - - upper = 0; - lower = 0; - page = 1; - do while(true); - do while (page y then - if x > z then - max = x; - else - max = z; - else - if y > z then - max = y; - else - max = z; - return(max); - end max3; - end test; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/TITLE.PLI b/software/CPM/CPM23_PLI/TITLE.PLI deleted file mode 100644 index d88cf0c..0000000 --- a/software/CPM/CPM23_PLI/TITLE.PLI +++ /dev/null @@ -1,179 +0,0 @@ -title: - proc options(main); -/*************************************************************** -* This program prepares a title page from a series of print * -* files constructed using the TEX Text formatter. This program* -* scans the files, looking for headings of the form: * -* aa.bb.cc.ee. xxxxxxxxxxxxxxxxxxxxxxx. * -* where aa through ee represent one or more heading digits * -* and xxxxx represents a heading title, optionally followed by * -* a period. Headings of the form: * -* aa. XXXXXXXXXX * -* are taken as chapter titles, and are preceded by a blank * -* line. The operator enters the page size and starting page * -* number (or a comma, if default values are to be used), along * -* with the name of a file which, in turn, lists the names of * -* files to be scanned. This file, called the command file, * -* is read with a GET LIST statement, and normally contains the * -* names of TEX files with the extension PRN. The output from * -* this program appears as: * -* 10. MAJOR TITLE . . . . . . . . . . . . . . . . . . . 100 * -* 10.1. Minor Title . . . . . . . . . . . . . . . . 102 * -* 10.1.1. Paragraph Title . . . . . . . . . 103 * -* * -* The Table of Contents shown in the "PL/I-80 Reference Manual"* -* was prepared using this program, so it provides a good exam- * -* of the input and output forms. * -***************************************************************/ - %replace - fw by 3, /* starting field width */ - fi by 2, /* field increment */ - fm by 30, /* max field width */ - lpp by 66, /* lines per page */ - true by '1'b, - false by '0'b; - dcl - blanks char(30) static initial - (' '), - dots char(80) var static initial -('. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . '); - dcl - (commd, input, output) file, - page decimal(3), - fv fixed, - fn fixed, - lppv fixed, - linc fixed, - line char(254) var, - pref char(254) var, - title char(254) var; - - put list ('Output File Name ? '); - get list(title); - open file (output) title(title) stream output - env (b(1000)); - put list ('Command File Name? '); - get list (title); - on undefinedfile(commd) - begin; - put list (title,'command file not present'); - stop; - end; - open file (commd) title(title) stream input; - lppv = lpp; - put list ('Lines Per Page ? '); - get list (lppv); - page = 1; - put list ('Start Page Number? '); - get list (page); - page = page - 1; - linc = lppv; - put file(output) edit('.ce','TABLE OF CONTENTS','.sp 2','.li') - (a,skip); - on endfile(commd) - begin; - put file(output) edit('.br') (skip,a); - put file(output) skip; - stop; - end; - on undefinedfile(input) - begin; - put skip list(title,'Not Found, Continue? (Y/N)'); - get list(title); - if title = 'y' | title = 'Y' then - go to retry; - stop; - end; - retry: - do while(true); - get file(commd) list(title); - open file (input) title(title) stream input - env(b(1000)); - put skip list('Processing: ',title); - on endfile(input) - go to nextfile; - do while(true); - get file(input) edit(line) (a); - call deblank(); - linc = linc + 1; - if linc > lpp then - do; - linc = 1; - page = page + 1; - end; - title = ''; - fv = 0; - fn = fw; - do while(numeric()); - title = title || pref; - fn = fn + fi; - fv = fv + fn; - end; - if title ^= '' then - if fv <= fm then - if substr(line,1,1) = ' ' then - do; - fv = fv - fn; - if fv = 0 then - put file(output) skip; - else - title = substr(blanks,1,fv) - || title; - fv = fv + fn; - if length(title) < fv then - title = title || - substr(blanks,1,fv-length(title)); - title = title || heading(); - line = title || substr(dots,length(title)+1); - put file(output) edit(line,page) (skip,a,f(3)); - end; - end; - nextfile: - linc = lpp; - revert endfile(input); - close file(input); - end; - - numeric: - proc returns(bit(1)); - dcl - i fixed; - i = index(line,'.'); - if i <= 1 then - return (false); - if verify(substr(line,1,i-1),'0123456789') = 0 then - do; - pref = substr(line,1,i); - line = substr(line,i+1); - return (true); - end; - return (false); - end numeric; - - heading: - proc returns (char(254) var); - dcl - i fixed; - call deblank(); - i = index(line,'.'); - if i ^= 0 then - line = substr(line,1,i-1); - i = index(line,' '); - do while (i ^= 0); - line = substr(line,1,i) || substr(line,i+2); - i = index(line,' '); - end; - return (line || ' '); - end heading; - - deblank: - proc; - dcl - i fixed; - i = verify(line,' '); - if i = 0 then - return; - line = substr(line,i); - end deblank; - end title; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/UPDATE.PLI b/software/CPM/CPM23_PLI/UPDATE.PLI deleted file mode 100644 index bd7c6d9..0000000 --- a/software/CPM/CPM23_PLI/UPDATE.PLI +++ /dev/null @@ -1,57 +0,0 @@ -update: - proc options(main); - dcl - 1 employee static, - 2 name char(30) var, - 2 addr, - 3 street char(30) var, - 3 city char(10) var, - 3 state char(7) var, - 3 zip fixed dec(5), - 2 age fixed dec(3), - 2 wage fixed dec(5,2), - 2 hours fixed dec(5,1); - dcl - (emp, keys) file; - dcl - 1 keylist (100), - 2 keyname char(30) var, - 2 keyval fixed binary; - dcl - (i, endlist) fixed, - eolist bit(1) static initial('0'b), - matchname char(30) var; - - open file(emp) update direct env(f(100)) - title ('$1.EMP'); - - open file(keys) stream env(b(4000)) title('$1.key'); - - do i = 1 to 100 while(^eolist); - get file(keys) list(keyname(i),keyval(i)); - eolist = keyname(i) = 'EOF'; - end; - - do while('1'b); - put skip list('Employee: '); - get list(matchname); - if matchname = 'EOF' then - stop; - do i = 1 to 100; - if matchname = keyname(i) then - do; - read file(emp) into(employee) - key(keyval(i)); - put skip list('Address: ', - street, city, state, zip); - put skip list(' '); - get list(street, city, state, zip); - put list('Hours:',hours,': '); - get list(hours); - write file(emp) from (employee) - keyfrom(keyval(i)); - end; - end; - end; - end update; - \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/WAGE.PLI b/software/CPM/CPM23_PLI/WAGE.PLI deleted file mode 100644 index f5f5f5b..0000000 --- a/software/CPM/CPM23_PLI/WAGE.PLI +++ /dev/null @@ -1,34 +0,0 @@ -payroll: - procedure options(main); - - declare - name (100) character(30) varying, - hours(100) fixed decimal(5,1), - wage (100) fixed decimal(5,2), - done bit(1), - next fixed; - - declare - (grosspay, withhold, netpay) fixed decimal(7,2); - - /* read initial values */ - done = '0'b; - do next = 1 to 100 while(^done); - put list('Type ''employee'', hours, wage: '); - get list(name(next),hours(next),wage(next)); - done = (name(next) = 'END'); - end; - - /* all names have been read, write the report */ - put list('Adjust Paper to Top of Page, Type return'); - get skip(2); - - do next = 1 to 100 while(name(next) ^= 'END'); - grosspay = hours(next) * wage(next); - withhold = grosspay * .15; - netpay = grosspay - withhold; - put skip(2) list('$',netpay,'for',name(next)); - end; - - end payroll; - \ No newline at end of file diff --git a/software/CPM/CPM24_PLI80_v13/ACK.PLI b/software/CPM/CPM24_PLI80_v13/ACK.PLI deleted file mode 100644 index 968d773..0000000 --- a/software/CPM/CPM24_PLI80_v13/ACK.PLI +++ /dev/null @@ -1,27 +0,0 @@ -ack: - procedure options(main,stack(2000)); - dcl - (m,maxm,n,maxn) fixed; - put skip list('Type max m,n: '); - get list(maxm,maxn); - put skip - list(' ',(decimal(n,4) do n=0 to maxn)); - do m = 0 to maxm; - put skip list(decimal(m,4),':'); - do n = 0 to maxn; - put list(decimal(ackermann(m,n),4)); - end; - end; - stop; - - ackermann: - procedure(m,n) returns(fixed) recursive; - dcl (m,n) fixed; - if m = 0 then - return(n+1); - if n = 0 then - return(ackermann(m-1,1)); - return(ackermann(m-1,ackermann(m,n-1))); - end ackermann; - end ack; - \ No newline at end of file diff --git a/software/CPM/CPM24_PLI80_v13/DFACT.PLI b/software/CPM/CPM24_PLI80_v13/DFACT.PLI deleted file mode 100644 index f0fbcf7..0000000 --- a/software/CPM/CPM24_PLI80_v13/DFACT.PLI +++ /dev/null @@ -1,22 +0,0 @@ -f: - proc options(main); - dcl - i fixed; - do i = 0 repeat(i+1); - put skip list('Factorial(',i,')=',fact(i)); - end; - stop; - - fact: - proc (i) - returns(fixed dec(15,0)) recursive; - dcl - i fixed; - dcl - f fixed dec(15,0); - if i = 0 then - return (1); - return (decimal(i,15) * fact(i-1)); - end fact; - end f; - \ No newline at end of file diff --git a/software/CPM/CPM24_PLI80_v13/LIB.COM b/software/CPM/CPM24_PLI80_v13/LIB.COM deleted file mode 100644 index 3438d67..0000000 Binary files a/software/CPM/CPM24_PLI80_v13/LIB.COM and /dev/null differ diff --git a/software/CPM/CPM24_PLI80_v13/LINK.COM b/software/CPM/CPM24_PLI80_v13/LINK.COM deleted file mode 100644 index d322996..0000000 Binary files a/software/CPM/CPM24_PLI80_v13/LINK.COM and /dev/null differ diff --git a/software/CPM/CPM24_PLI80_v13/OPTIMIST.PLI b/software/CPM/CPM24_PLI80_v13/OPTIMIST.PLI deleted file mode 100644 index 52c50df..0000000 --- a/software/CPM/CPM24_PLI80_v13/OPTIMIST.PLI +++ /dev/null @@ -1,44 +0,0 @@ -optimist: - proc options(main); - %replace - true by '1'b, - false by '0'b, - nwords by 5; - dcl - negative (1:nwords) char(8) var static initial - (' never',' none',' nothing',' not',' no'), - positive (1:nwords) char(10) var static initial - (' always',' all',' something','',' some'), - upper char(28) static initial - ('ABCDEFGHIJKLMNOPQRSTUVWXYZ. '), - lower char(28) static initial - ('abcdefghijklmnopqrstuvwxyz. '); - dcl - sent char(254) var, - word char(32) var; - dcl - (i,j) fixed; - - do while(true); - put skip list('What''s up? '); - sent = ' '; - do while - (substr(sent,length(sent)) ^= '.'); - get list (word); - sent = sent !! ' ' !! word; - end; - sent = translate(sent,lower,upper); - if verify(sent,lower) ^= 0 then - sent = ' that''s an interesting idea.'; - do i = 1 to nwords; - j = index(sent,negative(i)); - if j ^= 0 then - sent = substr(sent,1,j-1) !! - positive(i) !! - substr(sent,j+length(negative(i))); - end; - put list('Actually,'!!sent); - put skip; - end; - end optimist; - \ No newline at end of file diff --git a/software/CPM/CPM24_PLI80_v13/PLI.COM b/software/CPM/CPM24_PLI80_v13/PLI.COM deleted file mode 100644 index a8dd056..0000000 Binary files a/software/CPM/CPM24_PLI80_v13/PLI.COM and /dev/null differ diff --git a/software/CPM/CPM24_PLI80_v13/PLI0.OVL b/software/CPM/CPM24_PLI80_v13/PLI0.OVL deleted file mode 100644 index 394e8a4..0000000 Binary files a/software/CPM/CPM24_PLI80_v13/PLI0.OVL and /dev/null differ diff --git a/software/CPM/CPM24_PLI80_v13/PLI1.OVL b/software/CPM/CPM24_PLI80_v13/PLI1.OVL deleted file mode 100644 index 6ec488e..0000000 Binary files a/software/CPM/CPM24_PLI80_v13/PLI1.OVL and /dev/null differ diff --git a/software/CPM/CPM24_PLI80_v13/PLI2.OVL b/software/CPM/CPM24_PLI80_v13/PLI2.OVL deleted file mode 100644 index 5c45b77..0000000 Binary files a/software/CPM/CPM24_PLI80_v13/PLI2.OVL and /dev/null differ diff --git a/software/CPM/CPM24_PLI80_v13/PLILIB.IRL b/software/CPM/CPM24_PLI80_v13/PLILIB.IRL deleted file mode 100644 index bf60c1f..0000000 Binary files a/software/CPM/CPM24_PLI80_v13/PLILIB.IRL and /dev/null differ diff --git a/software/CPM/CPM24_PLI80_v13/RMAC.COM b/software/CPM/CPM24_PLI80_v13/RMAC.COM deleted file mode 100644 index 6196e86..0000000 Binary files a/software/CPM/CPM24_PLI80_v13/RMAC.COM and /dev/null differ diff --git a/software/CPM/CPM24_PLI80_v13/XREF.COM b/software/CPM/CPM24_PLI80_v13/XREF.COM deleted file mode 100644 index 32c57ae..0000000 Binary files a/software/CPM/CPM24_PLI80_v13/XREF.COM and /dev/null differ diff --git a/software/CPM/CPM25_PLI80_v14/A.PLI b/software/CPM/CPM25_PLI80_v14/A.PLI deleted file mode 100644 index a50b221..0000000 --- a/software/CPM/CPM25_PLI80_v14/A.PLI +++ /dev/null @@ -1,6 +0,0 @@ -a: - procedure(x) returns (float); /* external procedure */ - declare x float; - return (x/2); -end a; - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/ACK.PLI b/software/CPM/CPM25_PLI80_v14/ACK.PLI deleted file mode 100644 index 1fdb644..0000000 --- a/software/CPM/CPM25_PLI80_v14/ACK.PLI +++ /dev/null @@ -1,34 +0,0 @@ -/******************************************************/ -/* This program evaluates the Ackermann function */ -/* A(m,n), and increases the size of the stack */ -/* because of the large number of recursive calls. */ -/******************************************************/ -ack: - procedure options(main,stack(2000)); - declare - (m,maxm,n,maxn) fixed; - put skip list('Type max m,n: '); - get list(maxm,maxn); - put skip - list(' ',(decimal(n,4) do n=0 to maxn)); - do m = 0 to maxm; - put skip list(decimal(m,4),':'); - do n = 0 to maxn; - put list(decimal(ackermann(m,n),4)); - end; - end; - stop; - - ackermann: - procedure(m,n) returns(fixed) recursive; - declare (m,n) fixed; - if m = 0 then - return(n+1); - if n = 0 then - return(ackermann(m-1,1)); - return(ackermann(m-1,ackermann(m,n-1))); - end ackermann; - -end ack; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/ACKTST.PLI b/software/CPM/CPM25_PLI80_v14/ACKTST.PLI deleted file mode 100644 index 356a836..0000000 --- a/software/CPM/CPM25_PLI80_v14/ACKTST.PLI +++ /dev/null @@ -1,45 +0,0 @@ -/************************************************/ -/* This program tests the STKSIZ function while */ -/* evaluating a RECURSIVE procedure. */ -/************************************************/ -ack: - procedure options(main,stack(2000)); - declare - (m,n) fixed, - (maxm,maxn) fixed, - ncalls decimal(6), - (curstack, stacksize) fixed, - stksiz entry returns(fixed); - - put skip list('Type max m,n: '); - get list(maxm,maxn); - do m = 0 to maxm; - do n = 0 to maxn; - ncalls = 0; - curstack = 0; - stacksize = 0; - put edit('Ack(',m,',',n,')=',ackermann(m,n), - ncalls,' Calls,',stacksize,' Stack Bytes') - (skip,a,2(f(2),a),f(6),f(7),a,f(4),a); - end; - end; - stop; - - ackermann: - procedure(m,n) returns(fixed) recursive; - - declare - (m,n) fixed; - ncalls = ncalls + 1; - curstack = stksiz(); - if curstack > stacksize then - stacksize = curstack; - if m = 0 then - return(n+1); - if n = 0 then - return(ackermann(m-1,1)); - return(ackermann(m-1,ackermann(m,n-1))); - end ackermann; - - end ack; - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/ALLTST.PLI b/software/CPM/CPM25_PLI80_v14/ALLTST.PLI deleted file mode 100644 index 2aa01f4..0000000 --- a/software/CPM/CPM25_PLI80_v14/ALLTST.PLI +++ /dev/null @@ -1,35 +0,0 @@ -/*****************************************************/ -/* This program tests the TOTWDS, MAXWDS, and ALLWDS */ -/* functions from the Run-time Subroutine Library. */ -/*****************************************************/ -alltst: - procedure options(main); - declare - totwds returns(fixed(15)), - maxwds returns(fixed(15)), - allwds entry(fixed(15)) returns(pointer); - - declare - allreq fixed(15), - memptr ptr, - meminx fixed(15), - memory (0:0) bit(16) based(memptr); - - do while('1'b); - put edit (totwds(),' Total Words Available', - maxwds(),' Maximum Segment Size', - 'Allocation Size? ') (2(skip,f(6),a),skip,a); - get list(allreq); - memptr = allwds(allreq); - put edit('Allocated',allreq,' Words at ',unspec(memptr)) - (skip,a,f(6),a,b4); - - /* clear memory as example */ - do meminx = 0 to allreq-1; - memory(meminx) = '0000'b4; - end; - end; - -end alltst; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/ANNUITY.PLI b/software/CPM/CPM25_PLI80_v14/ANNUITY.PLI deleted file mode 100644 index fc4893c..0000000 --- a/software/CPM/CPM25_PLI80_v14/ANNUITY.PLI +++ /dev/null @@ -1,83 +0,0 @@ -/******************************************************/ -/* This program computes either the present value(PV),*/ -/* the payment(PMT), or the number of periods in an */ -/* annuity. */ -/******************************************************/ -annuity: - procedure options(main); - %replace - clear by '^z', - true by '1'b; - declare - PMT fixed decimal(7,2), - PV fixed decimal(9,2), - IP fixed decimal(6,6), - x float binary, - yi float binary, - i float binary, - n fixed; - - declare - ftc entry(float binary(24)) - returns(character(17) varying); - - put list (clear,'^i^iO R D I N A R Y A N N U I T Y'); - put skip(2) list - ('^iEnter Known Values, or 0, on Each Iteration'); - - on error - begin; - put skip list('^iInvalid Data, Re-enter'); - goto retry; - end; - - retry: - do while (true); - put skip(3) list('^iPresent Value '); - get list(PV); - put list('^iPayment '); - get list(PMT); - put list('^iInterest Rate '); - get list(yi); - i = yi / 1200; - put list('^iPay Periods '); - get list(n); - - if PV = 0 | PMT = 0 then - x = 1 - 1/(1+i)**n; - - /******************************/ - /* compute the present value */ - /******************************/ - if PV = 0 then - do; - PV = PMT * dec(ftc(x/i),15,6); - put edit('^iPresent Value is ',PV) - (a,p'$$$,$$$,$$$V.99'); - end; - - /******************************/ - /* compute the payment */ - /******************************/ - if PMT = 0 then - do; - PMT = PV * dec(ftc(i/x),15,8); - put edit('^iPayment is ',PMT) - (a,p'$$,$$$,$$$V.99'); - end; - - /*****************************/ - /* compute number of periods */ - /*****************************/ - if n = 0 then - do; - IP = ftc(i); - x = char(PV * IP / PMT); - n = ceil ( - log(1-x)/log(1+i) ); - put edit('^i',n,' Pay Periods') - (a,p'ZZZ9',a); - end; - end; - -end annuity; - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/CALL.PLI b/software/CPM/CPM25_PLI80_v14/CALL.PLI deleted file mode 100644 index f69fb8f..0000000 --- a/software/CPM/CPM25_PLI80_v14/CALL.PLI +++ /dev/null @@ -1,35 +0,0 @@ -call: - procedure options(main); - declare - f(3) entry(float) returns(float) variable, - a entry(float) returns(float); */ entry constant */ - declare - i fixed, x float; - - f(1) = a; - f(2) = b; - f(3) = c; - - do i = 1 to 3; - put skip list('Type x '); - get list(x); - put list('f(',i,')=',f(i)(x)); - end; - stop; - - b: - procedure(x) returns(float); /* internal procedure */ - declare x float; - return (2*x + 1); - end b; - - c: - procedure(x) returns(float); /* internal procedure */ - declare x float; - return(sin(x)); - end c; - - -end call; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/COPY.PLI b/software/CPM/CPM25_PLI80_v14/COPY.PLI deleted file mode 100644 index c5a2771..0000000 --- a/software/CPM/CPM25_PLI80_v14/COPY.PLI +++ /dev/null @@ -1,24 +0,0 @@ -/*****************************************************/ -/* This program copies one file to another using */ -/* buffered I/O. */ -/*****************************************************/ -copy: - procedure options(main); - declare - (input_file,output_file) file; - - open file (input_file) stream - environment(b(8192)) title('$1.$1'); - - open file (output_file) stream output - environment(b(8192)) title('$2.$2'); - declare - buff character(254) varying; - - do while('1'b); - read file (input_file) into (buff); - write file (output_file) from (buff); - end; -end copy; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/COPYLPT.PLI b/software/CPM/CPM25_PLI80_v14/COPYLPT.PLI deleted file mode 100644 index b56a664..0000000 --- a/software/CPM/CPM25_PLI80_v14/COPYLPT.PLI +++ /dev/null @@ -1,81 +0,0 @@ -/******************************************************/ -/* This program copies a STREAM file on disk to a */ -/* PRINT file, and formats the output with a page */ -/* header, and line numbers. */ -/******************************************************/ -copy: procedure options(main); - - declare - (sysin, sourcefile, printfile) file, - (pagesize, pagewidth, spaces, linenumber) fixed, - (line character(14), buff character(254)) varying; - - put list('^z File to Print Copy Program'); - - on endfile(sysin) - go to typeover; - - typeover: - put skip(5) list('How Many Lines Per Page? '); - get list(pagesize); - - put skip list('How Many Column Positions? '); - get skip list(pagewidth); - - on error(1) - begin; - put list('Invalid Number, Type Integer'); - go to getnumber; - end; - getnumber: - put skip list('Line Spacing (1=Single)? '); - get skip list(spaces); - revert error(1); - - put skip list('Destination Device/File: '); - get skip list(line); - - open file(printfile) print pagesize(pagesize) - linesize(pagewidth) title(line); - - on undefinedfile(sourcefile) - begin; - put skip list('"',line,'" isn''t a Valid Name'); - go to retry; - end; - retry: - put skip list('Source File to Print? '); - get list(line); - open file(sourcefile) stream environment(b(8000)) - title(line); - on endfile(sourcefile) - begin; - put file(printfile) page; - stop; - end; - - on endfile(printfile) - begin; - put skip list('^g^g^g^g Disk is Full'); - stop; - end; - - on endpage(printfile) - begin; - put file(printfile) page skip(2) - list('PAGE',pageno(printfile)); - put file(printfile) skip(4); - end; - - signal endpage(printfile); - do linenumber = 1 repeat(linenumber + 1); - get file (sourcefile) edit(buff) (a); - put file (printfile) - edit(linenumber,'|',buff) (f(5),x(1),a(2),a); - put file (printfile) skip(spaces); - end; - -end copy; - - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/CPMDIO.ASM b/software/CPM/CPM25_PLI80_v14/CPMDIO.ASM deleted file mode 100644 index a71df3e..0000000 --- a/software/CPM/CPM25_PLI80_v14/CPMDIO.ASM +++ /dev/null @@ -1,608 +0,0 @@ - name 'CPMDIO' - 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 (#7) - public setio ;set i/o byte (#8) - public wrstr ;print string (#9) - 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 char -; -;*********************************************************** -;* * -;*********************************************************** -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 (#6a) - 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 (#6b) - ;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 (#6c) - 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 (#7) - mvi c,getiof - jmp ?bdos ;value returned to A -; -;*********************************************************** -;* * -;*********************************************************** -setio: ;set i/o byte (#8) - ;1->i/o byte - call getp1 ;new i/o byte to E - mvi c,setiof - jmp ?bdos ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -wrstr: ;write string (#9) - ;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 - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/CREATE.PLI b/software/CPM/CPM25_PLI80_v14/CREATE.PLI deleted file mode 100644 index 3f31918..0000000 --- a/software/CPM/CPM25_PLI80_v14/CREATE.PLI +++ /dev/null @@ -1,49 +0,0 @@ -/*****************************************************/ -/* This program creates a name and address file. The */ -/* data structure for each record is in the %INCLUDE */ -/* file RECORD.DCL. */ -/*****************************************************/ -create: - procedure options(main); - -%include 'record.dcl'; -%replace - true by '1'b, - false by '0'b; - - declare - output file, - filename character(14) varying, - eofile bit(1) static initial(false); - - put list ('Name and Address Creation Program, File Name: '); - get list (filename); - - open file(output) stream output title(filename); - - do while (^eofile); - put skip(3) list('Name: '); - get list(name); - eofile = (name = 'EOF'); - if ^eofile then - do; - /* write prompt strings to console */ - put list('Address: '); - get list(addr); - put list('City, State, Zip: '); - get list(city, state, zip); - put list('Phone: '); - get list(phone); - - /* data in memory, write to output file */ - put file(output) - list(name,addr,city,state,zip,phone); - put file(output) skip; - end; - end; - put file(output) skip list('EOF'); - put file(output) skip; - -end create; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/DECPOLY.PLI b/software/CPM/CPM25_PLI80_v14/DECPOLY.PLI deleted file mode 100644 index a6e09eb..0000000 --- a/software/CPM/CPM25_PLI80_v14/DECPOLY.PLI +++ /dev/null @@ -1,33 +0,0 @@ -/*****************************************************/ -/* This program evaluates a polynomial expression */ -/* using FIXED DECIMAL data. */ -/*****************************************************/ -decpoly: - procedure options(main); - - %replace - true by '1'b; - declare - (x,y,z) fixed decimal(15,4); - - do while(true); - put skip(2) list('Type x,y,z: '); - get list(x,y,z); - - if x=0 & y=0 & z=0 then - stop; - - put skip list(' 2'); - put skip list(' x + 2y + z =',P(x,y,z)); - end; - - P: - procedure (x,y,z) returns (fixed decimal(15,4)); - declare - (x,y,z) fixed decimal(15,4); - return (x * x + 2 * y + z); - end P; - -end decpoly; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/DEMO.PLI b/software/CPM/CPM25_PLI80_v14/DEMO.PLI deleted file mode 100644 index fe629f3..0000000 --- a/software/CPM/CPM25_PLI80_v14/DEMO.PLI +++ /dev/null @@ -1,15 +0,0 @@ -demo: - procedure options(main); - - declare - name character(20) varying; - - - put skip(2) list('PLEASE ENTER YOUR FIRST NAME: '); - get list(name); - put skip(2) list('HELLO '||name||', WELCOME TO PL/I'); - -end demo; - - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/DEPREC.PLI b/software/CPM/CPM25_PLI80_v14/DEPREC.PLI deleted file mode 100644 index 5ecc523..0000000 --- a/software/CPM/CPM25_PLI80_v14/DEPREC.PLI +++ /dev/null @@ -1,298 +0,0 @@ -/*******************************************************/ -/* This program calculates three kinds of depreciation */ -/* schedules: straight_line, sum_of_the_years, and */ -/* double_declining. */ -/*******************************************************/ -depreciate: - procedure options(main); - %replace - clear_screen by '^z', - indent by 15, - ITC_rate by .1, - bonus_rate by .1, - bonus_max by 2000; - - declare - selling_price decimal(8,2), - adjusted_price decimal(8,2), - residual_value decimal(8,2), - year_value decimal(8,2), - depreciation_value decimal(8,2), - total_depreciation decimal(8,2), - book_value decimal(8,2), - tax_rate decimal(3,2), - sales_tax decimal(8,2), - tax_bracket decimal(2), - FYD decimal(8,2), - ITC decimal(8,2), - bonus_dep decimal(8,2), - months_remaining decimal(2), - new character(4), - factor decimal(2,1), - years decimal(2), - year_sum decimal(3), - current_year decimal(2), - select_sched character(1); - - declare - copy_to_list character(4), - output file variable, - (sysprint, list) file; - - declare - schedules character(3) static initial ('syd'), - schedule (0:3) entry variable; - - schedule (0) = error; - schedule (1) = straight_line; - schedule (2) = sum_of_years; - schedule (3) = double_declining; - - open file (sysprint) stream print pagesize(0) - title ('$con'); - - do while('1'b); - put list(clear_screen,'^i^i^iDepreciation Schedule'); - put skip(3) list('^i^iSelling Price? '); - get list(selling_price); - put list('^i^iResidual Value? '); - get list(residual_value); - put list('^i^iSales Tax (%)? '); - get list(tax_rate); - put list('^i^iTax Bracket(%)? '); - get list(tax_bracket); - put list('^i^iProRate Months? '); - get list(months_remaining); - put list('^i^iHow Many Years? '); - get list(years); - put list('^i^iNew? (yes/no) '); - get list(new); - put edit('^i^iSchedule:', - '^i^iStraight (s)', - '^i^iSum-of-Yrs (y)', - '^i^iDouble Dec (d)? ') (a,skip); - get list(select_sched); - put list('^i^iList? (yes/no) '); - get list(copy_to_list); - if copy_to_list = 'yes' then - open file(list) stream print title('$lst'); - factor = 1.5; - if new = 'yes' then - factor = 2.0; - sales_tax = decimal(selling_price*tax_rate,12,2)/100+.005; - if new = 'yes' | selling_price <= 100000.00 then - ITC = selling_price * ITC_rate; - else - ITC = 100000 * ITC_rate; - bonus_dep = selling_price * bonus_rate; - if bonus_dep > bonus_max then - bonus_dep = bonus_max; - put list(clear_screen); - call display(sysprint); - if copy_to_list = 'yes' then - call display(list); - put skip list('^i^i^i Type RETURN to Continue'); - get skip(2); - end; - -/******************************************************/ -/* This procedure displays the various depreciation */ -/* schedules. It calls the appropriate schedule with */ -/* an index into an array of entry constants. */ -/******************************************************/ -display: - procedure(f); - declare - f file; - output = f; - call schedule (index (schedules,select_sched)); -end display; - -/********************************************/ -/* This is a global error recovery routine. */ -/********************************************/ -error: - procedure; - put file (output) edit('Invalid Schedule - Enter s, y, or d') - (page,column(indent),x(8),a); - call line(); -end error; - -/*******************************************************/ -/* This procedure computes straight_line depreciation. */ -/*******************************************************/ -straight_line: - procedure; - adjusted_price = selling_price - bonus_dep; - put file (output) edit('S T R A I G H T L I N E') - (page,column(indent),x(14),a); - call header(); - depreciation_value = adjusted_price - residual_value; - book_value = adjusted_price; - total_depreciation = 0; - do current_year = 1 to years; - year_value = decimal(depreciation_value/years,8,2) + .005; - if current_year = 1 then - do; - year_value = year_value * months_remaining / 12; - FYD = year_value; - end; - depreciation_value = depreciation_value - year_value; - total_depreciation = total_depreciation + year_value; - book_value = adjusted_price - total_depreciation; - call print_line(); - end; - call summary(); -end straight_line; - -/*************************************************/ -/* This procedure computes depreciation based on */ -/* the sum_of_the_years. */ -/*************************************************/ -sum_of_years: - procedure; - adjusted_price = selling_price - bonus_dep; - put file (output) edit('S U M O F T H E Y E A R S') - (page,column(indent),x(11),a); - call header(); - depreciation_value = adjusted_price - residual_value; - book_value = adjusted_price; - total_depreciation = 0; - year_sum = 0; - do current_year = 1 to years; - year_sum = year_sum + current_year; - end; - - do current_year = 1 to years; - year_value = decimal(depreciation_value * - (years - current_year + 1),12,2)/ year_sum + .005; - if current_year = 1 then - do; - year_value = year_value * months_remaining / 12; - FYD = year_value; - end; - depreciation_value = depreciation_value - year_value; - total_depreciation = total_depreciation + year_value; - book_value = adjusted_price - total_depreciation; - call print_line(); - end; - call summary(); -end sum_of_years; - -/********************************************/ -/* This procedure computes double_declining */ -/* depreciation. */ -/********************************************/ -double_declining: - procedure; - adjusted_price = selling_price - bonus_dep; - put file (output) edit('D O U B L E D E C L I N I N G') - (page,column(indent),x(10),a); - call header(); - depreciation_value = adjusted_price - residual_value; - book_value = adjusted_price; - total_depreciation = 0; - do current_year = 1 to years - while (depreciation_value > 0); - year_value = decimal(book_value/years,8,2) * factor+.005; - if current_year = 1 then - do; - year_value = year_value * months_remaining / 12; - FYD = year_value; - end; - if year_value > depreciation_value then - year_value = depreciation_value; - depreciation_value = depreciation_value - year_value; - total_depreciation = total_depreciation + year_value; - book_value = adjusted_price - total_depreciation; - call print_line(); - end; - call summary(); -end double_declining; - -/**************************************************/ -/* This procedure prints an output header record. */ -/**************************************************/ -header: - procedure; - declare - new_or_used character(5); - - if new = 'yes' then - new_or_used = ' New'; - else - new_or_used = ' Used'; - put file (output) edit( - '--------------------------------------------------', - '|',selling_price+sales_tax,new_or_used, - residual_value,' Residual Value|', - '|',months_remaining,' Months Left ', - tax_rate,'% Tax',tax_bracket,'% Tax Bracket|') - (2(skip,column(indent),a), - 2(p'B$$,$$$,$$9.V99',a), - skip,column(indent),a,x(5),f(2),a,2(x(2),p'B99',a)); - - put file (output) edit( - '--------------------------------------------------', - '| Y | Depreciation | Depreciation | Book Value |', - '| r | For Year | Remaining | |', - '--------------------------------------------------') - (skip,column(indent),a); -end header; - -/*******************************************/ -/* This procedure prints the current line. */ -/*******************************************/ -print_line: - procedure; - put file (output) edit( - '|',current_year, - ' |',year_value, - ' |',depreciation_value, - ' |',book_value,' |') - (skip,column(indent),a,f(2),4(a,p'$z,zzz,zz9v.99')); -end print_line; - -/***************************************************/ -/* This procedure prints the summary of values for */ -/* each type of depreciation schedule. */ -/***************************************************/ -summary: - procedure; - declare - adj_ITC decimal(8,2), - total decimal(8,2), - direct decimal(8,2); - - call line(); - adj_ITC = ITC * 100 / tax_bracket; - total = FYD + sales_tax + adj_ITC + bonus_dep; - direct = total * tax_bracket / 100; - put file (output) edit( - '| First Year Reduction in Taxable Income |', - '--------------------------------------------------', - '| Depreciation ' ,FYD, '|', - '| Sales Tax ' ,sales_tax, '|', - '| ITC (Adjusted) ' ,adj_ITC, '|', - '| Bonus Depreciation ' ,bonus_dep, '|', - '| ------------- |', - '| Total for First Year ' ,total, '|', - '| Direct Reduction in Tax ' ,direct, '|') - (2(skip,column(indent),a),2(4(skip,column(indent),a, - p'$z,zzz,zz9v.99',x(3),a),skip,column(indent),a)); - call line(); -end summary; - -/*******************************************/ -/* This procedure prints a line of dashes. */ -/*******************************************/ -line: - procedure; - put file (output) edit( - '--------------------------------------------------') - (skip,column(indent),a); -end line; - - -end depreciate; - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/DFACT.PLI b/software/CPM/CPM25_PLI80_v14/DFACT.PLI deleted file mode 100644 index 46163df..0000000 --- a/software/CPM/CPM25_PLI80_v14/DFACT.PLI +++ /dev/null @@ -1,26 +0,0 @@ -/******************************************************/ -/* This program evaluates the Factorial function (n!) */ -/* using recursion and FIXED DECIMAL data. */ -/******************************************************/ -dfact: - procedure options(main); - declare - i fixed; - do i = 0 repeat(i+1); - put skip list('Factorial(',i,')=',factorial(i)); - end; - stop; - - factorial: - procedure(i) returns(fixed decimal(15,0)) - recursive; - declare - i fixed; - - if i = 0 then return (1); - return (decimal(i,15) * factorial(i-1)); - end factorial; - -end dfact; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/DIO80.DCL b/software/CPM/CPM25_PLI80_v14/DIO80.DCL deleted file mode 100644 index 17ccf2a..0000000 --- a/software/CPM/CPM25_PLI80_v14/DIO80.DCL +++ /dev/null @@ -1,5 +0,0 @@ -declare - allvec entry returns(pointer), - getdpb entry returns(pointer); - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/DIOCALLS.PLI b/software/CPM/CPM25_PLI80_v14/DIOCALLS.PLI deleted file mode 100644 index 462eeee..0000000 --- a/software/CPM/CPM25_PLI80_v14/DIOCALLS.PLI +++ /dev/null @@ -1,440 +0,0 @@ -/************************************************************** -* This PL/I program tests CP/M operating system entry points. * -* Note: The file DIOMOD.DCL contains only those declarations * -* for the entry points common to both the 8080 and 8086 * -* implementations. If you are running under CP/M 2.2 (or * -* newer) you also need to include the file DIO80.DCL. If you * -* are running under CP/M-86, you also need to include the * -* file DIO86.DCL. * -***************************************************************/ -diotest: - procedure options(main); - - %include 'diomod.dcl'; /* and either 'dio80.dcl' - or 'dio86.dcl' */ - - declare - c character(1), - v character(254) varying, - i fixed; - - -/********************************** -* * -* Fixed Location Tests: * -* * -* MEMPTR, MEMSIZ, MEMWDS, * -* DFCB0, DFCB1, DBUFF * -* * -**********************************/ -declare - memptrv pointer, - memsizv fixed, - (dfcb0v, dfcb1v, dbuffv) pointer, - command character(127) varying based (dbuffv), - 1 fcb0 based(dfcb0v), - 2 drive fixed(7), - 2 name character(8), - 2 type character(3), - 2 extnt fixed(7), - 2 space (19) bit(8), - 2 cr fixed(7), - memory (0:0) based(memptrv) bit(8); - memptrv = memptr(); - memsizv = memsiz(); - dfcb0v = dfcb0(); - dfcb1v = dfcb1(); - dbuffv = dbuff(); - - put edit ('Command Tail: ',command) (a); - put edit ('First Default File:', - fcb0.name,'.',fcb0.type) (skip,4a); - put edit ('dfcb0 ',unspec(dfcb0v), - 'dfcb1 ',unspec(dfcb1v), - 'dbuff ',unspec(dbuffv), - 'memptr',unspec(memptrv), - 'memsiz',unspec(memsizv), - 'memwds',memwds()) - (5(skip,a(7),b4),skip,a(7),f(6)); - put skip list('Clearing Memory'); - -/* sample loop to clear memory */ - -do i = 0 repeat(i+1) while (i^=memsizv-1); - memory (i) = '00'b4; -end; - - -/********************************** -* * -* REBOOT Test * -* * -**********************************/ -put skip list ('Reboot? (Y/N)'); -get list (c); -if translate(c,'Y','y') = 'Y' then - call reboot(); - - -/********************************** -* * -* RDCON, WRCON Test * -* * -**********************************/ -put list('Type Input, End with "$" '); -v = '^m^j'; -do while (substr(v,length(v)) ^= '$'); - v = v || rdcon(); -end; -put skip list('You Typed:'); -do i = 1 to length(v); - call wrcon(substr(v,i,1)); -end; - - -/********************************** -* * -* RDRDR and WRPUN Test * -* * -**********************************/ -put skip list('Reader to Punch Test?(Y/N)'); -get list (c); -if translate(c,'Y','y') = 'Y' then - do; - put skip list('Copying RDR to PUN until ctrl-z'); - c = ' '; - do while (c ^= '^z'); - c = rdrdr(); - if c ^= '^z' then - call wrpun(c); - end; - end; - - -/********************************** -* * -* WRLST Test * -* * -**********************************/ -put list('List Output Test?(Y/N)'); -get list(c); -if translate(c,'Y','y') = 'Y' then - do i = 1 to length(v); - call wrlst(substr(v,i,1)); - end; - - -/********************************** -* * -* Direct I/O, CONOUT, CONINP * -* * -**********************************/ -put list ('Direct I/O, Type Line, End with Line Feed'); -c = ' '; -do while (c ^= '^j'); - call conout(c); - c = coninp(); -end; - - -/********************************** -* * -* Direct I/O, Console Status * -* RDSTAT * -* * -**********************************/ -put skip list('Status Test, Type Character'); -do while (^rdstat()); -end; -/* clear the character */ -c = coninp(); - - -/********************************** -* * -* GETIO, SETIO IObyte * -* * -**********************************/ -declare - iobyte bit(8); - - iobyte = getio(); - put edit ('IObyte is ',iobyte,', New Value: ') - (skip,a,b4,a); - get edit (iobyte) (b4(2)); - call setio(iobyte); - - -/********************************** -* * -* Buffered Write, WRSTR Test * -* * -**********************************/ -put list('Buffered Output Test:'); - -/* "v" was previously filled by RDCON */ - -call wrstr(addr(v)); - - -/********************************** -* * -* Buffered Read RDBUF Test * -* * -**********************************/ -declare - 1 inbuff static, - 2 maxsize bit(8) initial('80'b4), - 2 inchars character(127) varying; - -put skip list('Line Input, Type Line, End With Return'); -put skip; -call rdbuf(addr(inbuff)); -put skip list('You Typed: ',inchars); - - -/********************************** -* * -* Console BREAK Test * -* * -**********************************/ -put skip list('Console Break Test, Type Character'); -do while(^break()); -end; -c = rdcon(); - - -/********************************** -* * -* Version Number VERS Test * -* * -**********************************/ -declare - version bit(16); - -version = vers(); - -if substr(version,1,8) = '00'b4 then - put skip list('CP/M'); -else - put skip list('MP/M'); - -put edit(' Version ',substr(version,9,4),'.',substr(version,13,4)) - (a,b4,a,b4); - - -/********************************** -* * -* Disk System RESET Test * -* * -**********************************/ -put skip list('Resetting Disk System'); -call reset(); - - -/********************************** -* * -* Disk SELECT Test * -* * -**********************************/ -put skip list('Select Disk # '); -get list(i); -call select(i); - -/********************************** -* * -* Note: The OPEN, CLOSE, SEAR, * -* SEARN, DELETE, RDSEQ, * -* WRSEQ, MAKE, and RENAME * -* functions are tested in * -* the DIOCOPY program. * -* * -**********************************/ - -/********************************** -* * -* LOGVEC and CURDSK * -* * -**********************************/ -put skip list ('Login Vector',logvec(), - 'Current Disk',curdsk()); - -/********************************** -* * -* See DIOCOPY for SETDMA Function * -* * -**********************************/ - -/********************************** -* * -* Allocate Vector ALLVEC Test * -* * -* Note: This test contains two * -* different versions; one for * -* 8080 code, and another for * -* 8086 code. Before compiling * -* you must comment out the * -* version you don't want to use. * -* * -**********************************/ - -/* 8080 version - -declare - alloc (0:30) bit(8) based (allvec()), - allvecp pointer; - -allvecp = allvec(); -put edit('Alloc Vector at ',unspec(allvecp),':', - (alloc(i) do i=0 to 30)) - (skip,a,b4,a,254(skip,4(b,x(1)))); */ - - -/* 8086 version - -declare - alloc (0:30) bit(8), - allvecp(2) pointer; - -call allvec(allvecp); -call movgtl(31,allvecp,addr(alloc)); -put edit('Alloc Vector at offset ', unspec(allvecp(1)), - ', segment ',unspec(allvecp(2)),':', - (alloc(i) do i=0 to 30)) - (skip,a,b4,a,b4,a,254(skip,4(b,x(1)))); */ - - -/********************************** -* * -* Note: the following functions * -* apply to version 2.0 or newer. * -* * -**********************************/ - -/********************************** -* * -* WPDISK Test * -* * -**********************************/ -put skip list('Write Protect Disk?(Y/N)'); -get list(c); -if translate(c,'Y','y') = 'Y' then - call wpdisk(); - -/********************************** -* * -* ROVEC Test * -* * -**********************************/ -put skip list('Read/Only Vector is',rovec()); - -/********************************** -* * -* Disk Parameter Block Decoding * -* Using GETDPB * -* * -* Note: This test contains two * -* different versions; one for * -* 8080 code, and another for * -* 8086 code. Before compiling * -* you must comment out the * -* version you don't want to use. * -* * -**********************************/ - -/* 8080 version - -declare - dpbp pointer, - 1 dpb based (dpbp), - 2 spt fixed(15), - 2 bsh fixed(7), - 2 blm bit(8), - 2 exm bit(8), - 2 dsm bit(16), - 2 drm bit(16), - 2 al0 bit(8), - 2 al1 bit(8), - 2 cks bit(16), - 2 off fixed(15); - -dpbp = getdpb(); -put edit('Disk Parameter Block:', - 'spt',spt,'bsh',bsh,'blm',blm, - 'exm',exm,'dsm',dsm,'drm',drm, - 'al0',al0,'al1',al1,'cks',cks, - 'off',off) - (skip,a,2(skip,a(4),f(6)),4(skip,a(4),b4), - skip,2(a(4),b,x(1)),skip,a(4),b4, - skip,a(4),f(6)); */ - - -/* 8086 version - -declare - dpbp(2) pointer, - 1 dpb, - 2 spt fixed(15), - 2 bsh fixed(7), - 2 blm bit(8), - 2 exm bit(8), - 2 dsm bit(16), - 2 drm bit(16), - 2 al0 bit(8), - 2 al1 bit(8), - 2 cks bit(16), - 2 off fixed(15); - -call getdpb(dpbp); -call movgtl(15,dpbp,addr(dpb)); -put edit('Disk Parameter Block:', - 'spt',spt,'bsh',bsh,'blm',blm, - 'exm',exm,'dsm',dsm,'drm',drm, - 'al0',al0,'al1',al1,'cks',cks, - 'off',off) - (skip,a,2(skip,a(4),f(6)), - 4(skip,a(4),b4), - skip,2(a(4),b,x(1)), - skip,a(4),b4, - skip,a(4),f(6)); */ - - -/********************************** -* * -* Test Get/Set user Code * -* GETUSR, SETUSR * -* * -**********************************/ -put skip list ('User is',getusr(),', New User:'); -get list(i); -call setusr(i); - -/********************************** -* * -* FILSIZ, SETREC, * -* RDRAN, WRRAN, WRRANZ are * -* tested in DIORAND * -* * -**********************************/ - -/********************************** -* * -* Test Drive Reset RESDRV * -* (version 2.2 or newer) * -* * -**********************************/ -declare - drvect bit(16); - -put list('Drive Reset Vector:'); -get list(drvect); -call resdrv(drvect); - -/********************************** -* * -* * -**********************************/ - -end diotest; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/DIOCOPY.PLI b/software/CPM/CPM25_PLI80_v14/DIOCOPY.PLI deleted file mode 100644 index 68ac9f4..0000000 --- a/software/CPM/CPM25_PLI80_v14/DIOCOPY.PLI +++ /dev/null @@ -1,155 +0,0 @@ -/********************************************************* -* This PL/I program demonstrates direct operating system * -* calls by performing a file-to-file copy. * -*********************************************************/ -diocopy: - procedure options(main); - - %replace - bufwds by 64, /* words per buffer */ - quest by 63, /* ASCII '?' */ - true by '1'b, - false by '0'b; - - %include 'diomod.dcl'; - - declare - 1 destfile, - %include 'fcb.dcl'; - - declare - dfcb0p ptr, - 1 sourcefile based(dfcb0p), - %include 'fcb.dcl'; - - declare - 1 dfcb1file based(dfcb1()), - %include 'fcb.dcl'; - - declare - 1 renfile, - %include 'fcb.dcl'; - - declare - answer char(1), - extcnt fixed(7); - -/* buffer management */ - - declare - eofile bit(1), - i fixed(15), - m fixed(15), - nbuffs fixed(15), - memory (0:0) bit(16) based(memptr()); - -/* compute number of buffs, 64 words each */ - - nbuffs = divide(memwds(),bufwds,15); - if nbuffs = 0 then - do; - put skip list('No Buffer Space'); - call reboot(); - end; - -/* initialize fcb's */ - - dfcb0p = dfcb0(); - destfile = dfcb1file; - -/* copy fcb to rename file, count extents */ - - renfile = destfile; - -/* search all extents by inserting '?' */ - - renfile.fext = quest; - if sear(addr(renfile)) ^= -1 then - do; - extcnt = 1; - do while(searn() ^= -1); - extcnt = extcnt + 1; - end; - put edit ('OK to Delete ',extcnt,' Extent(s)?(Y/N)') - (skip,a,f(3),a); - get list(answer); - if ^ (answer = 'Y' ! answer = 'y') then - call reboot(); - end; - -/* destination file will be deleted later */ - - destfile.ftype = '$$$'; - -/* delete any existing x.$$$ file */ - - call delete(addr(destfile)); - -/* open the source file, if possible */ - - if open(addr(sourcefile)) = -1 then - do; - put skip list('No Source File'); - call reboot(); - end; - -/* source file opened, create $$$ file */ - - destfile.fext = 0; - destfile.crec = 0; - if make(addr(destfile)) = -1 then - do; - put skip list('No Directory Space'); - call reboot(); - end; - -/* $$$ temp file created, now copy from source */ - - eofile = false; - do while (^eofile); - m = 0; - /* fill buffers */ - do i = 0 repeat (i+1) while (i= '22'b4; - -/* read and process file name */ - - put skip list('Data Base Name: '); - get list(fn); - fn = translate(fn,upper,lower); - -/* process optional drive prefix */ - - i = index(fn,':'); - if i = 0 then - drive = 0; - else - if i = 2 then - do; /* convert character to drive code */ - drive = index(upper,substr(fn,1,1)); - if drive = 0 ! drive > 16 then - do; - put skip list('Bad Drive Name'); - stop; - end; - fn = substr(fn,i+1); - end; - -/* get file name and optional type */ - - i = index(fn,'.'); - if i = 0 then - do; /* no file type specified, use .DAT */ - fname = fn; - ftype = 'DAT'; - end; - else - do; - fname = substr(fn,1,i-1); - ftype = substr(fn,i+1); - end; - -/* clear the extent field */ - fext = 0; - - if open(addr(database)) = -1 then - do; - put skip list('Creating New Database'); - if make(addr(database)) = -1 then - do; - put skip list('No Directory Space'); - stop; - end; - end; - else - do; - call filsiz(addr(database)); - put skip list('File Size:',rrec,' Records'); - end; - -/* main processing loop */ - - do while('1'b); - call setrec(addr(database)); - put skip list('Current Record',rrec); - put skip list('Read(0),Write(1),Quit(2)? '); - get list(mode); - if mode < 2 then - do; - put skip list('Record Number? '); - get list(rrec); - rovf = 0; - end; - if mode = 0 then - do; - code = rdran(addr(database)); - if code = 0 then - do; - if bitbuf(1) = '00'b4 then - put skip list('Zero Record'); - else - put skip list(buffer); - end; - else - put skip list('Return Code',code); - end; - else - if mode = 1 then - do; - put skip list('Data: '); - get list(buffer); - if zerofill then - code = wrranz(addr(database)); - else - code = wrran (addr(database)); - if code ^= 0 then - put skip list('Return Code',code); - end; - else - if mode = 2 then - do; - if close(addr(database)) = -1 then - put skip list('Read/Only'); - stop; - end; - end; - - end diorand; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/DIV2.ASM b/software/CPM/CPM25_PLI80_v14/DIV2.ASM deleted file mode 100644 index c639fda..0000000 --- a/software/CPM/CPM25_PLI80_v14/DIV2.ASM +++ /dev/null @@ -1,52 +0,0 @@ - title 'division by power of two' - public div2 - extrn ?signal -; entry: -; p1 -> fixed(7) power of two -; p2 -> floating point number -; exit: -; p1 -> (unchanged) -; p2 -> p2 / (2**p1) -div2: ;HL = .low(.p1) - mov e,m ;low(.p1) - inx h ;HL = .high(.p1) - mov d,m ;DE = .p1 - inx h ;HL = .low(p2) - ldax d ;a = p1 (power of two) - mov e,m ;low(.p2) - inx h ;HL = .high(.p2) - mov d,m ;DE = .p2 - xchg ;HL = .p2 -; -; A = power of 2, HL = .low byte of fp num - inx h ;to middle of mantissa - inx h ;to high byte of mantissa - inx h ;to exponent byte - inr m - dcr m ;p2 already zero? - rz ;return if so -dby2: ;divide by two - ora a ;counted power of 2 to zero? - rz ;return if so - dcr a ;count power of two down - dcr m ;count exponent down - jnz dby2 ;loop again if no underflow -; -;underflow occurred, signal underflow condition - lxi h,siglst;signal parameter list - call ?signal ;signal underflow - ret ;normally, no return -; - dseg -siglst: dw sigcod ;address of signal code - dw sigsub ;address of subcode - dw sigfil ;address of file code - dw sigaux ;address of aux message -; end of parameter vector, start of params -sigcod: db 3 ;03 = underflow -sigsub: db 128 ;arbitrary subcode for id -sigfil: dw 0000 ;no associated file name -sigaux: dw undmsg ;0000 if no aux message -undmsg: db 32,'Underflow in Divide by Two',0 - end - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/DTEST.PLI b/software/CPM/CPM25_PLI80_v14/DTEST.PLI deleted file mode 100644 index c4be1f1..0000000 --- a/software/CPM/CPM25_PLI80_v14/DTEST.PLI +++ /dev/null @@ -1,20 +0,0 @@ -/******************************************************/ -/* This program tests an assembly language routine to */ -/* do floating point division. */ -/******************************************************/ -dtest: - procedure options(main); - declare - div2 entry(fixed(7),float), - i fixed(7), - f float; - - do i = 0 by 1; - f = 100; - call div2(i,f); - put skip list('100 / 2 **',i,'=',f); - end; - -end dtest; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/ENTER.PLI b/software/CPM/CPM25_PLI80_v14/ENTER.PLI deleted file mode 100644 index a47aaeb..0000000 --- a/software/CPM/CPM25_PLI80_v14/ENTER.PLI +++ /dev/null @@ -1,62 +0,0 @@ -/******************************************************/ -/* This program constructs a data base of employee */ -/* records using a structure declaration. */ -/******************************************************/ - -enter: - procedure options(main); - %replace - true by '1'b, - false by '0'b; - - declare - 1 employee static, - 2 name character(30) varying, - 2 address, - 3 street character(30) varying, - 3 city character(10) varying, - 3 state character(12) varying, - 3 zip fixed decimal(5), - 2 age fixed decimal(3), - 2 wage fixed decimal(5,2), - 2 hours fixed decimal(5,1); - - declare - 1 default static, - 2 street character(30) varying - initial('(no street)'), - 2 city character(10) varying - initial('(no city)'), - 2 state character(12) varying - initial('(no state)'), - 2 zip fixed decimal(5) - initial(00000); - declare - emp file; - - open file(emp) keyed output environment(f(128),b(8000)) - title ('$1.EMP'); - - do while(true); - put list('Employee: '); - get list(name); - if name = 'EOF' then - do; - call write_it(); - stop; - end; - address = default; - put list (' Age, Wage: '); - get list (age,wage); - hours = 0; - call write_it(); - end; - - write_it: - procedure; - write file(emp) from(employee); - end write_it; - -end enter; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/EXPR1.PLI b/software/CPM/CPM25_PLI80_v14/EXPR1.PLI deleted file mode 100644 index 10f02c8..0000000 --- a/software/CPM/CPM25_PLI80_v14/EXPR1.PLI +++ /dev/null @@ -1,70 +0,0 @@ -/******************************************************/ -/* This program evaluates an arithmetic expression */ -/* using recursion. It contains two procedures. GNT */ -/* obtains the input expression consisting of separate*/ -/* tokens, and EXP which performs the recursive */ -/* evaluation of the tokens in the input line. */ -/******************************************************/ -expression: - procedure options(main); - declare - sysin file, - value float, - token character(10) varying; - - on endfile(sysin) - stop; - - on error(1) /* conversion or signal */ - begin; - put skip list('Invalid Input at ',token); - get skip; - goto restart; - end; - - restart: - - do while('1'b); - put skip(3) list('Type expression: '); - value = exp(); - put skip list('Value is:',value); - end; - - gnt: - procedure; - get list(token); - end gnt; - - exp: - procedure returns(float binary) recursive; - declare x float binary; - call gnt(); - if token = '(' then - do; - x = exp(); - call gnt(); - if token = '+' then - x = x + exp(); - else - if token = '-' then - x = x - exp(); - else - if token = '*' then - x = x * exp(); - else - if token = '/' then - x = x / exp(); - else - signal error(1); - call gnt(); - if token ^= ')' then - signal error(1); - end; - else - x = token; - return(x); - end exp; - -end expression; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/EXPR2.PLI b/software/CPM/CPM25_PLI80_v14/EXPR2.PLI deleted file mode 100644 index 82c689b..0000000 --- a/software/CPM/CPM25_PLI80_v14/EXPR2.PLI +++ /dev/null @@ -1,99 +0,0 @@ -/******************************************************/ -/* This program evaluates an arithmetic expression */ -/* using recursion. It contains an expanded version */ -/* of the GNT procedure that obtains an expression */ -/* containing separate tokens. EXP then recursively */ -/* evaluates the tokens in the input line. */ -/******************************************************/ - -expression: - procedure options(main); - - %replace - true by '1'b; - - declare - sysin file, - value float, - (token character(10), line character(80)) varying - static initial(''); - - on endfile(sysin) - stop; - - on error(1) /* conversion or signal */ - begin; - put skip list('Invalid Input at ',token); - token = ''; line = ''; - goto restart; - end; - - restart: - - do while('1'b); - put skip(3) list('Type expression: '); - value = exp(); - put edit('Value is: ',value) (skip,a,f(10,4)); - end; - - gnt: - procedure; - declare - i fixed; - - line = substr(line,length(token)+1); - do while(true); - if line = '' then - get edit(line) (a); - i = verify(line,' '); - if i = 0 then - line = ''; - else - do; - line = substr(line,i); - i = verify(line,'0123456789.'); - if i = 0 then - token = line; - else - if i = 1 then - token = substr(line,1,1); - else - token = substr(line,1,i-1); - return; - end; - end; - end gnt; - - exp: - procedure returns(float binary) recursive; - declare x float binary; - call gnt(); - if token = '(' then - do; - x = exp(); - call gnt(); - if token = '+' then - x = x + exp(); - else - if token = '-' then - x = x - exp(); - else - if token = '*' then - x = x * exp(); - else - if token = '/' then - x = x / exp(); - else - signal error(1); - call gnt(); - if token ^= ')' then - signal error(1); - end; - else - x = token; - return(x); - end exp; - -end expression; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/FCB.DCL b/software/CPM/CPM25_PLI80_v14/FCB.DCL deleted file mode 100644 index 7f93ba2..0000000 --- a/software/CPM/CPM25_PLI80_v14/FCB.DCL +++ /dev/null @@ -1,16 +0,0 @@ - 2 name1, - 3 drive fixed(7), /* drive number */ - 3 fname character(8), /* file name */ - 3 ftype character(3), /* file type */ - 3 fext fixed(7), /* file extent */ - 3 space (3) bit(8), /* filler */ - 2 name2, /* used in rename */ - 3 drive2 fixed(7), - 3 fname2 character(8), - 3 ftype2 character(3), - 3 fext2 fixed(7), - 3 space2 (3) bit(8), - 2 crec fixed(7), /* current record */ - 2 rrec fixed(15), /* random record */ - 2 rovf fixed(7); /* random rec overflow */ - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/FDIV2.ASM b/software/CPM/CPM25_PLI80_v14/FDIV2.ASM deleted file mode 100644 index 0c6a16e..0000000 --- a/software/CPM/CPM25_PLI80_v14/FDIV2.ASM +++ /dev/null @@ -1,63 +0,0 @@ - title 'div by power of two (function)' - public fdiv2 - extrn ?signal -; entry: -; p1 -> fixed(7) power of two -; p2 -> floating point number -; exit: -; p1 -> (unchanged) -; p2 -> (unchanged) -; stack: p2 / (2 ** p1) -fdiv2: ;HL = .low(.p1) - mov e,m ;low(.p1) - inx h ;HL = .high(.p1) - mov d,m ;DE = .p1 - inx h ;HL = .low(p2) - ldax d ;a = p1 (power of two) - mov e,m ;low(.p2) - inx h ;HL = .high(.p2) - mov d,m ;DE = .p2 - xchg ;HL = .p2 -; -; A = power of 2, HL = .low byte of fp num - mov e,m ;E = low mantissa - inx h ;to middle of mantissa - mov d,m ;D = middle mantissa - inx h ;to high byte of mantissa - mov c,m ;C = high mantissa - inx h ;to exponent byte - mov b,m ;B = exponent - inr b ;B = 00? - dcr b ;becomes 00 if so - jz fdret ;to return from float div -dby2: ;divide by two - ora a ;counted power of 2 to zero? - jz fdret ;return if so - dcr a ;count power of two down - dcr b ;count exponent down - jnz dby2 ;loop again if no underflow -; -;underflow occurred, signal underflow condition - lxi h,siglst;signal parameter list - call ?signal ;signal underflow - lxi b,0 ;clear to zero - lxi d,0 ;for default return -; -fdret: pop h ;recall return address - push b ;save high order fp num - push d ;save low order fp num - pchl ;return to calling routine -; - dseg -siglst: dw sigcod ;address of signal code - dw sigsub ;address of subcode - dw sigfil ;address of file code - dw sigaux ;address of aux message -; end of parameter vector, start of params -sigcod: db 3 ;03 = underflow -sigsub: db 128 ;arbitrary subcode for id -sigfil: dw 0000 ;no associated file name -sigaux: dw undmsg ;0000 if no aux message -undmsg: db 32,'Underflow in Divide by Two',0 - end - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/FDTEST.PLI b/software/CPM/CPM25_PLI80_v14/FDTEST.PLI deleted file mode 100644 index 4fb2d76..0000000 --- a/software/CPM/CPM25_PLI80_v14/FDTEST.PLI +++ /dev/null @@ -1,18 +0,0 @@ -/****************************************************/ -/* This program tests the assembly-language routine */ -/* called FDIV2 which returns a FLOAT BINARY value. */ -/****************************************************/ -fdtest: - procedure options(main); - declare - fdiv2 entry(fixed(7),float) returns(float), - i fixed(7), - f float; - - do i = 0 by 1; - put skip list('100 / 2 **',i,'=',fdiv2(i,100)); - end; - -end fdtest; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/FFACT.PLI b/software/CPM/CPM25_PLI80_v14/FFACT.PLI deleted file mode 100644 index 525e0e2..0000000 --- a/software/CPM/CPM25_PLI80_v14/FFACT.PLI +++ /dev/null @@ -1,24 +0,0 @@ -/******************************************************/ -/* This program evaluates the Factorial function (n!) */ -/* using recursion and FLOAT BINARY data. */ -/******************************************************/ -ffact: - procedure options(main); - declare - i fixed; - do i = 0 repeat(i+1); - put skip list('Factorial(',i,')=',factorial(i)); - end; - stop; - - factorial: - procedure(i) returns(float) recursive; - declare - i fixed; - if i = 0 then return (1); - return (i * factorial(i-1)); - end factorial; - -end ffact; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/FLTPOLY.PLI b/software/CPM/CPM25_PLI80_v14/FLTPOLY.PLI deleted file mode 100644 index 4bae21f..0000000 --- a/software/CPM/CPM25_PLI80_v14/FLTPOLY.PLI +++ /dev/null @@ -1,33 +0,0 @@ -/*****************************************************/ -/* This program evaluates a polynomial expression */ -/* using FLOAT BINARY data. */ -/*****************************************************/ -fltpoly: - procedure options(main); - - %replace - true by '1'b; - declare - (x,y,z) float binary(24); - - do while(true); - put skip(2) list('Type x,y,z: '); - get list(x,y,z); - - if x=0 & y=0 & z=0 then - stop; - - put skip list(' 2'); - put skip list(' x + 2y + z =',P(x,y,z)); - end; - - P: - procedure (x,y,z) returns (float binary(24)); - declare - (x,y,z) float binary; - return (x * x + 2 * y + z); - end P; - -end fltpoly; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/FLTPOLY2.PLI b/software/CPM/CPM25_PLI80_v14/FLTPOLY2.PLI deleted file mode 100644 index 60c8904..0000000 --- a/software/CPM/CPM25_PLI80_v14/FLTPOLY2.PLI +++ /dev/null @@ -1,39 +0,0 @@ -/******************************************************/ -/* This program evaluates a polynomial expression */ -/* using FLOAT BINARY data. It also traps the end-of */ -/* file condition for the file SYSIN. */ -/******************************************************/ -fltpoly2: - procedure options(main); - %replace - false by '0'b, - true by '1'b; - declare - (x,y,z) float binary(24), - eofile bit(1) static initial(false), - sysin file; - - on endfile(sysin) - eofile = true; - - do while(true); - put skip(2) list('Type x,y,z: '); - get list(x,y,z); - - if eofile then - stop; - - put skip list(' 2'); - put skip list(' x + 2y + z =',P(x,y,z)); - end; - - P: - procedure (x,y,z) returns (float binary(24)); - declare - (x,y,z) float binary(24); - return (x * x + 2 * y + z); - end P; - -end fltpoly2; - -  \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/FSCAN.PLI b/software/CPM/CPM25_PLI80_v14/FSCAN.PLI deleted file mode 100644 index 5cac035..0000000 --- a/software/CPM/CPM25_PLI80_v14/FSCAN.PLI +++ /dev/null @@ -1,51 +0,0 @@ -/******************************************************/ -/* This program tests the procedure called GNT, which */ -/* is a free-field scanner (parser) that reads a line */ -/* of input and breaks it into individual parts. */ -/******************************************************/ -fscan: - procedure options(main); - %replace - true by '1'b; - declare - token character(80) varying - static initial(''); - - gnt: - procedure; - declare - i fixed, - line character(80) varying - static initial(''); - - line = substr(line,length(token)+1); - do while(true); - if line = '' then - get edit(line) (a); - i = verify(line,' '); - if i = 0 then - line = ''; - else - do; - line = substr(line,i); - i = verify(line,'0123456789.'); - if i = 0 then - token = line; - else - if i = 1 then - token = substr(line,1,1); - else - token = substr(line,1,i-1); - return; - end; - end; - end gnt; - - do while(true); - call gnt; - put edit(''''!!token!!'''') (x(1),a); - end; - -end fscan; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/IFACT.PLI b/software/CPM/CPM25_PLI80_v14/IFACT.PLI deleted file mode 100644 index e72770d..0000000 --- a/software/CPM/CPM25_PLI80_v14/IFACT.PLI +++ /dev/null @@ -1,20 +0,0 @@ -/******************************************************/ -/* This program evaluates the Factorial function (n!) */ -/* using iteration. */ -/******************************************************/ -ifact: - procedure options(main); - declare - (i, n, F) fixed; - - do i = 0 by 1; - F = 1; - do n = i to 1 by -1; - F = n * F; - end; - put edit('factorial(',i,')=',F) - (skip, a,f(2), a, f(7)); - end; -end ifact; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/INVERT.PLI b/software/CPM/CPM25_PLI80_v14/INVERT.PLI deleted file mode 100644 index a8d7ce2..0000000 --- a/software/CPM/CPM25_PLI80_v14/INVERT.PLI +++ /dev/null @@ -1,30 +0,0 @@ -/******************************************************/ -/* This is an external procedure called by MAININVT. */ -/******************************************************/ -invert: - procedure (a,r,c); - %include 'matsize.lib'; - declare - (d, a(maxrow,maxcol)) float binary(24), - (i,j,k,l,r,c) fixed binary(6); - do i = 1 to r; - d = a(i,1); - do j = 1 to c - 1; - a(i,j) = a(i,j+1)/d; - end; - a(i,c) = 1/d; - do k = 1 to r; - if k ^= i then - do; - d = a(k,1); - do l = 1 to c - 1; - a(k,l) = a(k,l+1) - a(i,l) * d; - end; - a(k,c) = - a(i,c) * d; - end; - end; - end; - -end invert; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/KEYFILE.PLI b/software/CPM/CPM25_PLI80_v14/KEYFILE.PLI deleted file mode 100644 index ace1b4a..0000000 --- a/software/CPM/CPM25_PLI80_v14/KEYFILE.PLI +++ /dev/null @@ -1,33 +0,0 @@ -/******************************************************/ -/* This program reads an employee record file and */ -/* creates another file of keys to access the records.*/ -/******************************************************/ - -keyfile: - procedure options(main); - declare - 1 employee static, - 2 name character(30) varying; - - declare - (input, keys) file, - k fixed; - - open file(input) keyed environment(f(128),b(10000)) - title('$1.emp'); - - open file(keys) stream output - linesize (60) title('$1.key'); - - do while('1'); - read file(input) into(employee) keyto(k); - put skip list(k,name); - put file(keys) list(name,k); - if name = 'EOF' then - stop; - end; - -end keyfile; - - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/LABELS.PLI b/software/CPM/CPM25_PLI80_v14/LABELS.PLI deleted file mode 100644 index d58ea96..0000000 --- a/software/CPM/CPM25_PLI80_v14/LABELS.PLI +++ /dev/null @@ -1,45 +0,0 @@ -/******************************************************/ -/* This is a non-functional program. Its purpose is */ -/* to illustrate the concept of label constants and */ -/* variables. */ -/******************************************************/ -Labels: - procedure options(main); - declare - i fixed, - (x, y, z(3)) label; - x = lab1; - y = x; - - goto lab1; - goto x; - goto y; - - call P(lab2); - - do i = 1 to 3; - z(i) = c(i); - end; - - i = 2; - goto z(i); - goto c(i); - - c(1):; - c(2):; - c(3):; - - lab1:; - lab2:; - - P: - procedure (g); - declare - g label; - goto g; - end P; - -end Labels; - - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/LIB.COM b/software/CPM/CPM25_PLI80_v14/LIB.COM deleted file mode 100644 index 49a4e4d..0000000 Binary files a/software/CPM/CPM25_PLI80_v14/LIB.COM and /dev/null differ diff --git a/software/CPM/CPM25_PLI80_v14/LINK.COM b/software/CPM/CPM25_PLI80_v14/LINK.COM deleted file mode 100644 index c3ae0fd..0000000 Binary files a/software/CPM/CPM25_PLI80_v14/LINK.COM and /dev/null differ diff --git a/software/CPM/CPM25_PLI80_v14/LOAN1.PLI b/software/CPM/CPM25_PLI80_v14/LOAN1.PLI deleted file mode 100644 index b3b87fc..0000000 --- a/software/CPM/CPM25_PLI80_v14/LOAN1.PLI +++ /dev/null @@ -1,42 +0,0 @@ -/******************************************************/ -/* This program produces a schedule of loan payments */ -/* using the following algorithm: if P = loan payment,*/ -/* i = interest, and PMT is the monthly payment then */ -/* P = (P + (i*P) - PMT. */ -/******************************************************/ -loan1: - procedure options(main); - declare - m fixed binary, - y fixed binary, - P fixed decimal(11,2), - PMT fixed decimal(6,2), - i fixed decimal(4,2); - - do while('1'b); - put skip list('Principal '); - get list(P); - put list('Interest '); - get list(i); - put list('Payment '); - get list(PMT); - m = 0; - y = 0; - do while (P > 0); - if mod(m,12) = 0 then - do; - y = y + 1; - put skip list('Year',y); - end; - m = m + 1; - put skip list(m,P); - P = P + round( i * P / 1200, 2); - if P < PMT - then PMT = P; - put list(PMT); - P = P - PMT; - end; - end; - -end loan1; - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/LOAN2.PLI b/software/CPM/CPM25_PLI80_v14/LOAN2.PLI deleted file mode 100644 index ac2812b..0000000 --- a/software/CPM/CPM25_PLI80_v14/LOAN2.PLI +++ /dev/null @@ -1,221 +0,0 @@ -/*****************************************************/ -/* This program computes a schedule of loan payments */ -/* using an elaborate analysis and display format. */ -/* It contains five internal procedures: DISPLAY, */ -/* SUMMARY, CURRENT_YEAR, HEADER, and LINE. */ -/*****************************************************/ -loan2: - procedure options(main); - %replace - true by '1'b, - false by '0'b, - clear by '^z'; - - declare - end bit(1), - m fixed binary, - sm fixed binary, - y fixed binary, - sy fixed binary, - fm fixed binary, - dl fixed binary, - P fixed decimal(10,2), - PV fixed decimal(10,2), - PP fixed decimal(10,2), - PL fixed decimal(10,2), - PMT fixed decimal(10,2), - PMV fixed decimal(10,2), - INT fixed decimal(10,2), - YIN fixed decimal(10,2), - IP fixed decimal(10,2), - yi fixed decimal(4,2), - i fixed decimal(4,2), - INF fixed decimal(4,3), - ci fixed decimal(15,14), - fi fixed decimal(7,5), - ir fixed decimal(4,2); - - declare - name character(14) varying static initial('$con'), - output file; - - put list(clear,'^i^iS U M M A R Y O F P A Y M E N T S'); - - on undefinedfile(output) - begin; - put skip list('^i^icannot write to',name); - goto open_output; - end; - - open_output: - put skip(2) list('^i^iOutput File Name '); - get list(name); - if name = '$con' then - open file(output) title('$con') print pagesize(0); - else - open file(output) title(name) print; - - on error - begin; - put skip list('^i^iBad Input Data, Retry'); - goto retry; - end; - - retry: - do while(true); - put skip(2) list('^i^iPrincipal '); - get list(PV); - P = PV; - put list('^i^iInterest '); - get list(yi); - i = yi; - put list('^i^iPayment '); - get list(PMV); - PMT = PMV; - put list('^i^i%Inflation '); - get list(ir); - fi = 1 + ir/1200; - ci = 1.00; - put list('^i^iStarting Month '); - get list(sm); - put list('^i^iStarting Year '); - get list(sy); - put list('^i^iFiscal Month '); - get list(fm); - put edit('^i^iDisplay Level ', - '^i^iYr Results : 0 ', - '^i^iYr Interest: 1 ', - '^i^iAll Values : 2 ') - (skip,a); - get list(dl); - if dl < 0 | dl > 2 then - signal error; - m = sm; - y = sy; - IP = 0; - PP = 0; - YIN = 0; - if name ^= '' then - put file(output) page; - call header(); - do while (P > 0); - end = false; - INT = round ( i * P / 1200, 2 ); - IP = IP + INT; - PL = P; - P = P + INT; - if P < PMT then - PMT = P; - P = P - PMT; - PP = PP + (PL - P); - INF = ci; - ci = ci / fi; - if P = 0 | dl > 1 | m = fm then - do; - put file(output) skip - edit('|',100*m+y) (a,p'99/99'); - call display(PL * INF, INT * INF, - PMT * INF, PP * INF, IP * INF); - end; - if m = fm & dl > 0 then - call summary(); - m = m + 1; - if m > 12 then - do; - m = 1; - y = y + 1; - if y > 99 then - y = 0; - end; - end; - if dl = 0 then - call line(); - else - if ^end then - call summary(); - end retry; -/****************************************************/ -/* This procedure performs the output of the actual */ -/* parameters passed to it by the main part of the */ -/* program. */ -/****************************************************/ -display: - procedure(a,b,c,d,e); - declare - (a,b,c,d,e) fixed decimal(10,2); - - put file (output) edit - ('|',a,'|',b,'|',c,'|',d,'|',e,'|') - (a,2(2(p'$zz,zzz,zz9v.99',a), - p'$zzz,zz9.v99',a)); -end display; - -/*************************************************/ -/* This procedure computes the summary of yearly */ -/* interest. */ -/*************************************************/ -summary: - procedure; - end = true; - call current_year(IP-YIN); - YIN = IP; -end summary; - -/****************************************************/ -/* This procedure computes the interest paid during */ -/* current year. */ -/****************************************************/ -current_year: - procedure(I); - declare - yp fixed binary, - I fixed decimal(10,2); - yp = y; - if fm < 12 then - yp = yp - 1; - call line(); - put skip file(output) edit - ('|','Interest Paid During ''',yp,'-''',y,' is ',I,'|') - (a,x(15),2(a,p'99'),a,p'$$$,$$$,$$9V.99',x(16),a); - call line(); -end current_year; - -/******************************************************/ -/* This procedure defines and prints out an elaborate */ -/* header format. */ -/******************************************************/ -header: - procedure; - put file(output) list(clear); - call line(); - put file(output) skip edit - ('|','L O A N P A Y M E N T S U M M A R Y','|') - (a,x(19)); - call line(); - put file(output) skip edit - ('|','Interest Rate',yi,'%','Inflation Rate',ir,'%','|') - (a,x(15),2(a,p'b99v.99',a,x(6)),x(9),a); - call line(); - put file(output) skip edit - ('|Date |',' Principal |','Plus Interest|',' Payment |', - 'Principal Paid|','Interest Paid |') (a); - call line(); -end header; - -/*******************************************************/ -/* This procedure prints out a series of dashed lines. */ -/*******************************************************/ -line: - procedure; - declare - i fixed bin; - put file(output) skip edit - ('-------','------------', - ('---------------' do i = 1 to 4)) (a); -end line; - - -end loan2; - - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/MAININVT.PLI b/software/CPM/CPM25_PLI80_v14/MAININVT.PLI deleted file mode 100644 index 91ec230..0000000 --- a/software/CPM/CPM25_PLI80_v14/MAININVT.PLI +++ /dev/null @@ -1,65 +0,0 @@ -/******************************************************/ -/* This program is the main module in a program that */ -/* performs matrix inversion. It calls the entry */ -/* constant INVERT which does the actual inversion. */ -/******************************************************/ -maininvt: - procedure options(main); - %replace - true by '1'b, - false by '0'b; - %include 'matsize.lib'; - - declare - mat(maxrow,maxcol) float binary(24), - (i,j,n,m) fixed(6), - var character (26) static initial - ('abcdefghijklmnopqrstuvwxyz'), - invert entry - ((maxrow,maxcol) float(24), fixed(6), fixed(6)); - - put list('Solution of Simultaneous Equations'); - do while(true); - put skip(2) list('Type rows, columns: '); - get list(n); - if n = 0 then - stop; - - get list(m); - if n > maxrow ! m > maxcol then - put skip list('Matrix is Too Large'); - else - do; - put skip list('Type Matrix of Coefficients'); - put skip; - do i = 1 to n; - put list('Row',i,':'); - get list((mat(i,j) do j = 1 to n)); - end; - - put skip list('Type Solution Vectors'); - put skip; - do j = n + 1 to m; - put list('Variable',substr(var,j-n,1),':'); - get list((mat(i,j) do i = 1 to n)); - end; - - call invert(mat,n,m); - put skip(2) list('Solutions:'); - do i = 1 to n; - put skip list(substr(var,i,1),'='); - put edit((mat(i,j) do j = 1 to m-n)) - (f(8,2)); - end; - - put skip(2) list('Inverse Matrix is'); - do i = 1 to n; - put skip edit((mat(i,j) do j = m-n+1 to m)) - (x(3),6f(8,2),skip); - end; - end; - end; - -end maininvt; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/MATSIZE.LIB b/software/CPM/CPM25_PLI80_v14/MATSIZE.LIB deleted file mode 100644 index 4e7b4f3..0000000 --- a/software/CPM/CPM25_PLI80_v14/MATSIZE.LIB +++ /dev/null @@ -1,4 +0,0 @@ -%replace - true by '1'b, - false by '0'b; - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/MPMCALLA.PLI b/software/CPM/CPM25_PLI80_v14/MPMCALLA.PLI deleted file mode 100644 index fcc3d34..0000000 --- a/software/CPM/CPM25_PLI80_v14/MPMCALLA.PLI +++ /dev/null @@ -1,515 +0,0 @@ -/* -******************************************************* -* Direct MP/M Operating System Call Test Program * -******************************************************* - -The programs MPMCALLA.PLI and MPMCALLB.PLI demonstrate direct MP/M -Operating System calls from PLI. The following instructions describe -the steps to assemble, compile, link and execute these programs. - - 1) Compile the PLI programs with the commands: - - A>pli mpmcalla $pl - A>pli mpmcallb $pl - - 2) Assemble the mpmdio.asm module with the command: - - A>rmac mpmdio - - 3) Link the mpmcalla, mpmcallb, and mpmdio modules: - - A>link mpmcalla,mpmcallb,mpmdio - - 4) Gensys your MP/M system as follows: - - Top .... = ff - Number of con.. = 1 - Add system call ... ? n - Bank switched mem... ? n - :0 - :a0 - :ff - - 5) Run the program: - - A>mpmcalla - - -*/ - - -mpmtest: /* external MP/M I/O entry points */ - -procedure options(main); - -declare - part2 entry; - -%replace - true by '1'b, - false by '0'b; - -%include 'mpmdio.dcl'; - -declare - vers entry returns(bit(16)); - -declare - sysin file, - version bit(16), - oldpriority fixed(7), - v character(254) var, - i fixed; - -declare - pdadr pointer, - 1 pd based (pdadr), - 2 link pointer, - 2 status fixed(7), - 2 priority fixed(7), - 2 stkptr pointer, - 2 name character(8), - 2 console fixed(7), - 2 memseg fixed(7), - 2 b fixed(15), - 2 thread pointer, - 2 dmadr pointer, - 2 slct bit(8); -/* 2 dcnt fixed(15), - 2 searchl fixed(7), - 2 searcha pointer, - 2 drvact bit(16), - 2 registers (20) fixed(7), - 2 scratch fixed(15); - */ - -declare - 1 localpd static, - 2 link pointer, - 2 status fixed(7), - 2 priority fixed(7), - 2 stkptr pointer, - 2 name character(8) initial ('LocalPD '), - 2 console fixed(7), - 2 memseg fixed(7), - 2 b fixed(15), - 2 thread pointer, - 2 dmadr pointer, - 2 slct fixed(7), - 2 dcnt fixed(15), - 2 searchl fixed(7), - 2 searcha pointer, - 2 drvact bit(16), - 2 registers (20) fixed(7), - 2 scratch fixed(15); - -declare - localstk (0:255) entry (fixed) variable; - -declare - sysdatpgadr pointer, - 1 sysdatpg based (sysdatpgadr), - 2 memtop bit(8), - 2 nmbcns fixed(7), - 2 brkptrst fixed (7), - 2 syscallstks bit(8), - 2 bankswitched bit(8); -/* 2 z80cpu bit(8), - 2 bankedbdos bit(8), - 2 basebankedbdos pointer; - */ - -declare - upper character(27) static initial - ('ABCDEFGHIJKLMNOPQRSTUVWXYZ '), - lower character(27) static initial - ('abcdefghijklmnopqrstuvwxyz '); - - -/********************************** -* * -* Local procedures used during * -* testing. * -* * -**********************************/ - -flagtest: -procedure; -declare - boolean bit(1); - -call attcon(); -boolean = flgwt (30); -put skip list ('-> flagtest wait on #30 complete.'); -call detcon(); -boolean = flgset (31); -call term ('ffff'b4); -end flagtest; - -queuetest: -procedure; -declare - 1 qcbB static, - 2 link fixed(15), - 2 name character(8) initial ('QueueB '), - 2 msglen fixed(15) initial (10), - 2 nmbmsgs fixed(15) initial (2), - 2 dqph pointer, - 2 nqph pointer, - 2 msgin pointer, - 2 msgout pointer, - 2 msgcnt fixed(15), - 2 buffer (2), - 3 lnk pointer, - 3 character(10); - -declare - 1 uqcbA static, - 2 pointer pointer, - 2 msgadr pointer, - 2 name character(8) initial ('QueueA '); - -declare - 1 uqcbB, - 2 pointer pointer, - 2 msgadr pointer; - -declare - msgA character(10), - msgB character(10); - -uqcbA.msgadr = addr (msgA); -uqcbB.pointer = addr (qcbB); -uqcbB.msgadr = addr (msgB); -call makque (addr (qcbB)); -do while (~opnque (addr (uqcbA))); - call delay (1); /* until qcbA created */ -end; -do while (true); - call rdque (addr (uqcbA)); - msgB = translate (msgA,upper,lower); - call wrque (addr (uqcbB)); -end; -end queuetest; - - -/************************************************** -*************************************************** -******** ******** -******** M a i n P r o g r a m ******** -******** ******** -*************************************************** -**************************************************/ - - -/********************************** -* * -* Verify Operation Under MP/M * -* Without Banked Memory. * -* * -**********************************/ - -version = vers(); -if substr (version,1,8) = '00'b4 then -do; - put skip list ('Tests cannot run under CP/M.'); - call term('0000'b4); -end; -sysdatpgadr = sysdat (); -if sysdatpg.bankswitched = 'FF'b4 then -do; - put skip list ('Tests cannot run under MP/M'); - put list ('with bank switched memory.'); - call term('0000'b4); -end; -if sysdatpg.syscallstks = 'FF'b4 then -do; - put skip list ('Tests cannot run under MP/M'); - put list ('with system call user stacks.'); - call term('0000'b4); -end; -pdadr = rpdadr(); /* get current running pd adr */ -oldpriority = pd.priority; - -/********************************** -* * -* Memory Management Tests: * -* AMEMRQ, RMEMRQ, MEMFR * -* * -**********************************/ -declare - 1 memdscr, - 2 base fixed (7), /* base page */ - 2 size fixed (7), /* # of pages */ - 2 attrib fixed (7), /* attributes */ - 2 bank fixed (7); /* bank byte */ - -on endfile (sysin) - goto rmemrqtst; -put skip list ('Memory Management Tests:'); -do while (true); - put skip(2) list (' Absolute Request'); - put skip list (' Base (xx in hex) = '); - i = pd.memseg; /* save old memseg index */ - get edit (unspec (memdscr.base)) (b4(2)); - if amemrq (addr (memdscr)) then - do; - put skip list (' Absolute Request satisfied.'); - put edit (' Base = ',unspec (memdscr.base),'H') - (skip,a,b4,a); - put edit (' Size = ',unspec (memdscr.size),'H') - (skip,a,b4,a); - put edit (' Attr = ',unspec (memdscr.attrib),'H') - (skip,a,b4,a); - put edit (' Bank = ',unspec (memdscr.bank),'H') - (skip,a,b4,a); - call memfr (addr (memdscr)); - pd.memseg = i; /* restore former memseg index */ - end; - else - do; - put skip list (' Absolute Request failed.'); - end; -end; - -rmemrqtst: - -get edit (v) (a); /* clear input buffer */ - -on endfile (sysin) - goto polltst; -do while (true); - put skip(2) list (' Relocatable Request'); - put skip list (' Size (xxh) = '); - i = pd.memseg; /* save old memseg index */ - get edit (unspec (memdscr.size)) (b4(2)); - if rmemrq (addr (memdscr)) then - do; - put skip list (' Relocatable Request satisfied.'); - put edit (' Base = ',unspec (memdscr.base),'H') - (skip,a,b4,a); - put edit (' Size = ',unspec (memdscr.size),'H') - (skip,a,b4,a); - put edit (' Attr = ',unspec (memdscr.attrib),'H') - (skip,a,b4,a); - put edit (' Bank = ',unspec (memdscr.bank),'H') - (skip,a,b4,a); - call memfr (addr (memdscr)); - pd.memseg = i; /* restore former memseg index */ - end; - else - do; - put skip list (' Relocatable Request failed.'); - end; -end; - -/********************************** -* * -* Poll Tests: * -* The poll call cannot be tested * -* unless the poll device table * -* in the XIOS is known. * -* * -**********************************/ - -polltst: - -get edit (v) (a); /* clear input buffer */ - -/* The following code is "commented out" - -call poll (devicenumber); -put edit ('Device ',devicenumber,'is ready.') - (skip,a,f,a); - -End of comment-deleted code */ - -put skip(2) list ('Poll call not tested.'); - -/********************************** -* * -* Flag Tests: * -* FLGWT, FLGSET * -* * -* Note: this test assumes that * -* flags 30 & 31 are unused. * -* * -**********************************/ -declare - flagover bit(1), - flagunder bit(1); - -unspec (localpd.link) = '0000'b4; -localpd.priority = 100; -localpd.stkptr = addr (localstk(255)); -localpd.console = pd.console; -localpd.memseg = pd.memseg; -localstk(255) = flagtest; -call crproc (addr (localpd)); -put skip(2) list ('Flag Tests:'); -call setpri (101); -call detcon(); -flagover = ~flgset (30); -call attcon(); -call setpri (oldpriority); -flagunder = ~flgwt (31); -if flagover then - put skip list ('-> flag over-run.'); -if flagunder then - put skip list ('-> flag under-run.'); -put skip list ('-> flag tests successful.'); - -/********************************** -* * -* Queue Management Tests: * -* MAKQUE,OPNQUE,DELQUE * -* RDQUE,CRDQUE,WRQUE,CWRQUE * -* * -**********************************/ -declare - 1 qcbA static, - 2 link fixed(15), - 2 name character(8) initial ('QueueA '), - 2 msglen fixed(15) initial (10), - 2 nmbmsgs fixed(15) initial (2), - 2 dqph pointer, - 2 nqph pointer, - 2 msgin pointer, - 2 msgout pointer, - 2 msgcnt fixed(15), - 2 buffer (2), - 3 lnk pointer, - 3 character(10); - -declare - 1 uqcbA, - 2 pointer pointer, - 2 msgadr pointer; - -declare - 1 uqcbB static, - 2 pointer pointer, - 2 msgadr pointer, - 2 name character(8) initial ('QueueB '); - -declare - msgA character(10), - msgB character(10); - -put skip(2) list ('Queue Tests:'); -on endfile (sysin) - goto abtsprtest; - -uqcbA.pointer = addr (qcbA); -uqcbA.msgadr = addr (msgA); -uqcbB.msgadr = addr (msgB); -call makque (addr (qcbA)); - -put skip(2) list (' Testing Conditional Write Queue'); -do i = 1 to 10 while (cwrque (addr (uqcbA))); - put edit (' Message #',i) (skip,a,f(2)); -end; -put skip list (' Queue is full.'); - -put skip(2) list (' Testing Conditional Read Queue'); -do i = 1 to 10 while (crdque (addr (uqcbA))); - put edit (' Message #',i) (skip,a,f(2)); -end; -put skip list (' Queue is empty.'); - -unspec (localpd.link) = '0000'b4; -localpd.priority = 100; -localpd.stkptr = addr (localstk(255)); -localpd.console = pd.console; -localpd.memseg = pd.memseg; -localstk(255) = queuetest; -call crproc (addr (localpd)); - -do while (~opnque (addr (uqcbB))); - call delay (1); /* until qcbB created */ -end; -put skip list (' Enter character(10) message:'); -do while (true); - put skip list ('->'); - get edit (msgA) (a); - call wrque (addr (uqcbA)); - call rdque (addr (uqcbB)); - put edit ('<-',msgB) (skip,a,a(10)); -end; - -/********************************** -* * -* Abort Specified Process Test: * -* * -**********************************/ -declare - 1 abtpb static, - 2 pda bit(16) initial ('0000'b4), - 2 termcode bit(16) initial ('ffff'b4), - 2 name character(8) initial ('LocalPD '), - 2 console fixed(7); - -abtsprtest: - -get edit (v) (a); /* clear input buffer */ - -put skip(2) list ('Abort Specified Process Test:'); -put skip list (' Aborting LocalPD.'); -abtpb.console = pd.console; -if abtspr (addr (abtpb)) then - do; - put skip list ('->Abort successful'); - end; -else - do; - put skip list ('->Abort Failed'); - goto error; - end; -if ~delque (addr (qcbA)) then - do; - put skip list ('*** Unable to delete QueueA ***'); - call term('0000'b4); - end; -if ~delque (uqcbB.pointer) then - do; - put skip list ('*** Unable to delete QueueB ***'); - call term('0000'b4); - end; - - -/*************************************** -**************************************** -**** **** -**** Call external procedure **** -**** "part2" for other tests **** -**** **** -*********************************** -**********************************/ - -call part2(); - - -/********************************** -* * -* Termination Test: * -* * -**********************************/ - -put skip(2) list ('Termination Test:'); -call term ('0000'b4); - -/********************************** -* * -* Unrecoverable Error: * -* * -**********************************/ - -error: - -put skip list ('*** Unrecoverable Error ***'); -call disabl(); -do while (true); - end; - -end mpmtest; - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/MPMCALLB.PLI b/software/CPM/CPM25_PLI80_v14/MPMCALLB.PLI deleted file mode 100644 index 4574ec6..0000000 --- a/software/CPM/CPM25_PLI80_v14/MPMCALLB.PLI +++ /dev/null @@ -1,323 +0,0 @@ -/************************************************************ -* Direct MP/M Operating System Call Test Program (Cont'd) * -* See comments at the beginning of the MPMCALLA.PLI program.* -************************************************************/ - -part2: - -procedure; /* external MP/M I/O entry points */ - -%replace - true by '1'b, - false by '0'b; - -%include 'mpmdio.dcl'; - -declare - sysin file, - oldpriority fixed(7), - v character(254) varying, - i fixed; - -declare - pdadr pointer, - 1 pd based (pdadr), - 2 link pointer, - 2 status fixed(7), - 2 priority fixed(7), - 2 stkptr pointer, - 2 name character(8), - 2 console fixed(7), - 2 memseg fixed(7), - 2 b fixed(15), - 2 thread pointer, - 2 dmadr pointer, - 2 slct bit(8); -/* 2 dcnt fixed(15), - 2 searchl fixed(7), - 2 searcha pointer, - 2 drvact bit(16), - 2 registers (20) fixed(7), - 2 scratch fixed(15); -*/ - -pdadr = rpdadr(); /* get current running pd adr */ -oldpriority = pd.priority; - -declare - upper character(27) static initial - ('ABCDEFGHIJKLMNOPQRSTUVWXYZ '), - lower character(27) static initial - ('abcdefghijklmnopqrstuvwxyz '); - - -/********************************** -* * -* Local procedures used during * -* testing. * -* * -**********************************/ - -clresptest: - -procedure (stringadr) returns (pointer); -declare - stringadr pointer, - string based (stringadr) character(27); - -put edit ('->STRING proc passed: ',string) - (skip,a,a(27)); -return (addr (lower)); -end clresptest; - - -/********************************** -* * -* Delay Test: * -* * -**********************************/ - -put skip(2) list ('Delay Test:'); -put skip list ('->a dot will be printed each second'); -put list ('for ten seconds '); -do i = 1 to 10; - call delay (60); - put edit ('.') (a); -end; - -/********************************** -* * -* Disptach Test: * -* * -**********************************/ - -put skip(2) list ('Dispatch Test:'); -call dsptch(); -put skip list ('->dispatch successful.'); - -/********************************** -* * -* Console Tests: * -* ATTCON, DETCON already tested * -* SETCON not tested * -* ASNCON tested in send CLI cmd * -* GETCON * -* * -**********************************/ - -put skip(2) list ('Console Test:'); -put edit ('->current console is #',getcon()) - (skip,a,f(2)); - -/********************************** -* * -* Send CLI Command Test: * -* This example shows how to run * -* a program in another memory * -* segment and then get the con- * -* sole back to the main program.* -* E.G. as in a menu-driven * -* application. * -* * -**********************************/ -declare - 1 clicmd, - 2 dslct bit(8), /* default disk / user code */ - 2 console fixed(7), /* console number */ - 2 line character(128); - -declare - 1 apb static, - 2 console fixed(7), - 2 name character(8) initial ('cli '), - 2 match bit(8) initial ('00'b4); - -put skip(2) list ('Send CLI Command Test:'); -on endfile (sysin) - goto clresptst; - -pdadr = rpdadr(); /* get current running pd adr */ -oldpriority = pd.priority; -clicmd.dslct = pd.slct; -clicmd.console = pd.console; -apb.console = pd.console; -do while (true); - put skip list (' Enter CLI Command: '); - get edit (clicmd.line) (a); - if ~asncon (addr (apb)) then - do; - put skip list ('*** Failed to assign Cli the console ***'); - end; - else - do; - call setpri (197); - call sclicd (addr (clicmd)); - call attcon(); - call setpri (oldpriority); - end; - end; - -/********************************** -* * -* Call Resident System Proc Test: * -* * -**********************************/ -declare - 1 cpb, - 2 nameadr pointer, - 2 paramadr pointer; - -declare - aparam pointer; - -declare - procname character(8) static initial ('STRING '); - -declare - 1 stringqcb static, - 2 link fixed(15), - 2 name character(8) initial ('STRING '), - 2 msglen fixed(15) initial (2), - 2 nmbmsgs fixed(15) initial (1), - 2 dqph pointer, - 2 nqph pointer, - 2 msgin pointer, - 2 msgout pointer, - 2 msgcnt fixed(15), - 2 buffer pointer; - -declare - 1 stringuqcb, - 2 pointer pointer, - 2 msgadr pointer; - -declare - stringprocadr entry (fixed) variable returns(pointer); - -declare - rtnstringadr pointer, - rtnstring based (rtnstringadr) character(27); - -clresptst: - -get edit (v) (a); /* clear input buffer */ -put skip(2) list ('Call Resident System Process Test:'); -call makque (addr (stringqcb)); -stringuqcb.pointer = addr (stringqcb); -stringuqcb.msgadr = addr (stringprocadr); -stringprocadr = clresptest; -call wrque (addr (stringuqcb)); -cpb.nameadr = addr (procname); -cpb.paramadr = addr (aparam); -aparam = addr (upper); -unspec (rtnstringadr) = clresp (addr (cpb)); - -put edit ('->STRING proc returned:',rtnstring) - (skip,a,a(27)); - -if ~delque (addr (stringqcb)) then - do; - put skip list ('*** Unable to delete stringqcb ***'); - call term ('0000'b4); - end; -put skip list ('->Call clresp test complete.'); - -/********************************** -* * -* Parse Filename Test: * -* * -**********************************/ -declare - done bit(1); - -declare - line character(80); - -declare - 1 pfcb, - 2 flname pointer, - 2 fcb pointer; - -declare - delimptr pointer, - delim based (delimptr) character(1); - -declare - oldptr pointer, - old based (oldptr) character(10); - -declare - 1 afcb, - 2 name, - 3 drive fixed(7), - 3 fname character(8), - 3 ftype character(3); - -put skip(2) list ('Parse Filename Test:'); -on endfile (sysin) - goto gettodtest; - -put skip list (' Enter string of filenames to be parsed,'); -put list ('separated by commas:'); -do while (true); - put skip list ('->'); - get edit (line) (a); - line = substr (line,1,index (line,' ')-1) || ascii (13); - pfcb.flname = addr (line); - pfcb.fcb = addr (afcb); - oldptr = addr (line); - done = false; - pfcb.flname = parse (addr (pfcb)); - do while (~done & (unspec (pfcb.flname) ~= 'ffff'b4)); - oldptr = pfcb.flname; - put edit (' ',ascii (afcb.drive+64),': ', - afcb.fname,' ',afcb.ftype) - (skip,a,a,a,a(8),a,a(3)); - if unspec (pfcb.flname) = '0000'b4 then - do; - done = true; - end; - else - do; - delimptr = pfcb.flname; - if delim = ',' then - do; - unspec (i) = unspec (pfcb.flname); - i = i + 1; - unspec (pfcb.flname) = unspec (i); - end; - pfcb.flname = parse (addr (pfcb)); - end; - end; - if ~done then - do; - put skip list (' *** Bad Entry *** ->'); - put edit (old) (a(10)); - end; -end; - -/********************************** -* * -* Time and Date Test: * -* * -**********************************/ -declare - 1 tod, - 2 date fixed(15), - 2 time, - 3 hour bit(8), - 3 min bit(8), - 3 sec bit(8); - -gettodtest: - -get edit (v) (a); /* clear input buffer */ -put skip(2) list ('Time and Date Test:'); -call gettod (addr (tod)); -put edit ('-> ',tod.date,' ',tod.hour,':',tod.min,':',tod.sec) - (skip,a,f(5),a,b4(2),a,b4(2),a,b4(2)); - - -end part2; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/MPMDIO.ASM b/software/CPM/CPM25_PLI80_v14/MPMDIO.ASM deleted file mode 100644 index 368f4bd..0000000 --- a/software/CPM/CPM25_PLI80_v14/MPMDIO.ASM +++ /dev/null @@ -1,495 +0,0 @@ - name 'MPMDIO' - title 'Direct MP/M Calls From PL/I-80' -; -; Note: The CP/M function get version number (#12) has been -; included in this module. If you wish to link both the -; DIOMOD and the MPMDIO, you must remove the function -; from this module. -; -;*********************************************************** -;* * -;* MP/M calls from pl/i for direct i/o * -;* * -;* This interface is re-entrant. * -;* * -;*********************************************************** - public amemrq ;absolute memory request (#128) - public rmemrq ;relocatable memory request (#129) - public memfr ;memory free (#130) - public poll ;poll device (#131) - public flgwt ;flag wait (#132) - public flgset ;flag set (#133) - public makque ;make queue (#134) - public opnque ;open queue (#135) - public delque ;delete queue (#136) - public rdque ;read queue - unconditional (#137) - public crdque ;conditional read queue (#138) - public wrque ;write queue - unconditional (#139) - public cwrque ;conditional write queue (#140) - public delay ;delay (#141) - public dsptch ;dispatch (#142) - public term ;terminate calling process (#143) - public crproc ;create process (#144) - public setpri ;set process priority (#145) - public attcon ;attach console (#146) - public detcon ;detach console (#147) - public setcon ;set console (#148) - public asncon ;assign console (#149) - public sclicd ;send CLI command (#150) - public clresp ;call resident system process (#151) - public parse ;parse filename (#152) - public getcon ;get console number (#153) - public sysdat ;return system data page adr (#154) - public gettod ;get time and date (#155) - public rpdadr ;return process descr adr (#156) - public abtspr ;abort specified process (#157) - - public disabl ;disable interrupts - public enable ;enable interrupts - - public vers ;CP/M function - get version number (#12) -; -; - extrn ?bdos -; -;*********************************************************** -;* * -;* equates for interface to mp/m xdos * -;* * -;*********************************************************** -amemrqf equ 128 ;absolute memory request -rmemrqf equ 129 ;relocatable memory request -memfrf equ 130 ;memory free -pollf equ 131 ;poll device -flgwtf equ 132 ;flag wait -flgsetf equ 133 ;flag set -makquef equ 134 ;make queue -opnquef equ 135 ;open queue -delquef equ 136 ;delete queue -rdquef equ 137 ;read queue - unconditional -crdquef equ 138 ;conditional read queue -wrquef equ 139 ;write queue - unconditional -cwrquef equ 140 ;conditional write queue -delayf equ 141 ;delay -dsptchf equ 142 ;dispatch -termf equ 143 ;terminate calling process -crprocf equ 144 ;create process -setprif equ 145 ;set process priority -attconf equ 146 ;attach console -detconf equ 147 ;detach console -setconf equ 148 ;set console -asnconf equ 149 ;assign console -sclicdf equ 150 ;send CLI command -clrespf equ 151 ;call resident system process -parsef equ 152 ;parse filename -getconf equ 153 ;get console number -sysdatf equ 154 ;return system data page adr -gettodf equ 155 ;get time and date -rpdadrf equ 156 ;return process descr adr -abtsprf equ 157 ;abort specified process - -versf equ 12 ;get version number (CP/M function) -; -; utility functions -;*********************************************************** -;* * -;* general purpose routines used upon entry * -;* * -;*********************************************************** -getp1i: - call getp1 - jmp ?bdos ;return through bdos - -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 parameter to DE -getp2i: ;(equivalent to getp2) - call getp1 - inx h - mov d,m ;get high byte as well - jmp ?bdos ;return through bdos -; -getp3i: ;get single word parameter to DE - ;perform bdos call and then compliment result - call getp2i - cma - ret -; -;*********************************************************** -;* * -;*********************************************************** -amemrq: ;absolute memory request (#128) - ;1->addr(memdscr) - mvi c,amemrqf ;abs mem rqst function - jmp getp3i ;DE = .memdscr - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -rmemrq: ;relocatable memory request (#129) - ;1->addr(memdscr) - mvi c,rmemrqf ;rel mem rqst function - jmp getp3i ;DE = .memdscr - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -memfr: ;memory free (#130) - ;1->addr(memdscr) - mvi c,memfrf ;memory free function - jmp getp2i ;DE = .memdscr - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -poll: ;poll device (#131) - ;1->fixed(7) poll device number - mvi c,pollf ;poll function - jmp getp1i ;device number to E - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -flgwt: ;flag wait (#132) - ;1->fixed(7) flag number - mvi c,flgwtf ;flag wait function - call getp1i ;flag number to E - cma - ret -; -;*********************************************************** -;* * -;*********************************************************** -flgset: ;flag set (#133) - ;1->fixed(7) flag number - mvi c,flgsetf ;flag set function - call getp1i ;flag number to E - cma - ret -; -;*********************************************************** -;* * -;*********************************************************** -makque: ;make queue (#134) - ;1->addr(qcb) - mvi c,makquef ;make queue function - jmp getp2i ;DE = .qcb - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -opnque: ;open queue (#135) - ;1->addr(uqcb) - mvi c,opnquef ;open queue function - jmp getp3i ;DE = .uqcb - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -delque: ;delete queue (#136) - ;1->addr(qcb) - mvi c,delquef ;delete queue function - jmp getp3i ;DE = .qcb - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -rdque: ;read queue - unconditional (#137) - ;1->addr(uqcb) - mvi c,rdquef ;read queue function - jmp getp2i ;DE = .uqcb - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -crdque: ;conditional read queue (#138) - ;1->addr(uqcb) - mvi c,crdquef ;conditional read queue function - jmp getp3i ;DE = .uqcb - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -wrque: ;write queue - unconditional (#139) - ;1->addr(uqcb) - mvi c,wrquef ;write queue function - jmp getp2i ;DE = .uqcb - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -cwrque: ;conditional write queue (#140) - ;1->addr(uqcb) - mvi c,cwrquef ;conditional write queue function - jmp getp3i ;DE = .uqcb - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -delay: ;delay (#141) - ;1->number of ticks to delay - mvi c,delayf ;delay function - jmp getp2i ;DE = #ticks - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -dsptch: ;dispatch (#142) - mvi c,dsptchf ;dispatch function - jmp ?bdos ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -term: ;terminate calling process (#143) - ;1->terminate code - mvi c,termf ;terminate function - jmp getp2i ;DE = terminate code, where - ; if D = FF then keep mem seg - ; if E = FF term sys process - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -crproc: ;create process (#144) - ;1->addr(pdadr) - mvi c,crprocf ;create process function - jmp getp2i ;DE = .pdadr - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -setpri: ;set process priority (#145) - ;1->fixed(7) priority - mvi c,setprif ;set priority function - jmp getp1i ;priority to E - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -attcon: ;attach console (#146) - mvi c,attconf ;attach console function - jmp ?bdos ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -detcon: ;detach console (#147) - mvi c,detconf ;detach console function - jmp ?bdos ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -setcon: ;set console (#148) - ;1->fixed(7) console - mvi c,setconf ;set console function - jmp getp1i ;console to E - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -asncon: ;assign console (#149) - ;1->addr(apb) - mvi c,asnconf ;assign console function - jmp getp3i ;DE = .apb - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -sclicd: ;send CLI command (#150) - ;1->addr(clicmd) - mvi c,sclicdf ;send CLI command function - jmp getp2i ;DE = .clicmd - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -clresp: ;call resident system process (#151) - ;1->addr(cpb) - call getp1 ;DE = .cpb - inx h - mov d,m - xchg - mov c,m - inx h - mov b,m ;BC = cpb.name - inx h - mov d,h - mov e,l ;DE = .cpb.param - lxi h,-14 - dad sp - sphl ;make room for uqcb+2 on stk - push d -; -; Stack Structure: -; -; +-----------------------+ -; | Return Address | -; +-----------------------+ -; | | -; uqcb.name(0) - name(7) -; | | -; +-----------------------+ -; | uqcb.msgadr | ---+ -; +-----------------------+ | -; | uqcb.pointer | | -; +-----------------------+ | -; | (space for .pliproc) | <--+ -; +-----------------------+ -; S--->| .cpb.param | -; +-----------------------+ -; - mov d,h - mov e,l - inx h - inx h - inx h - inx h - mov m,e - inx h - mov m,d ;uqcb.msgadr <- - inx h - mvi e,8 -clresploop: - ldax b - mov m,a - inx b - inx h - dcr e - jnz clresploop - lxi b,-12 - dad b ;HL = .uqcb - mvi c,opnquef - xchg - call ?bdos ;open the cpb.name queue - inr a - lxi h,0001h - pop d ;DE = cpb.param - jz clresprtn ;queue not found - lxi h,2 - dad sp - mvi c,rdquef - push d - xchg - call ?bdos ;read proc adr from queue - pop d ;DE = cpb.param - pop h ;HL = procadr - push h - lxi b,clresprtn - push b ;setup return addr - push h - xchg - ret ;call pliproc (param) -clresprtn: ;return here from pliproc call - push h ;save returned result - lxi h,4 - dad sp - xchg ;DE = .uqcb - mvi c,wrquef - call ?bdos ;write proc adr to queue - pop d ;DE = result returned from pliproc - lxi h,14 - dad sp - sphl ;discard uqcb on stack - xchg - ret ;return with HL = pliproc() - ; -;*********************************************************** -;* * -;*********************************************************** -parse: ;parse filename (#152) - ;1->addr(pfcb) - mvi c,parsef ;parse filename function - jmp getp2i ;DE = .pfcb - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -getcon: ;get console number (#153) - mvi c,getconf ;get console function - jmp ?bdos ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -sysdat: ;return system data page adr (#154) - mvi c,sysdatf ;get system data pg adr fn - jmp ?bdos ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -gettod: ;get time and date (#155) - ;1->addr(todadr) - mvi c,gettodf ;get time and date function - jmp getp2i ;DE = .todadr - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -rpdadr: ;return process descr adr (#156) - mvi c,rpdadrf ;return Proc dscr adr fn - jmp ?bdos ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -abtspr: ;abort specified process (#157) - ;1->addr(abtpb) - mvi c,abtsprf ;abort specified proc fn - jmp getp3i ;DE = .abtpb - ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** -disabl: ;disable interrupts - di - ret -; -;*********************************************************** -;* * -;*********************************************************** -enable: ;enable interrupts - ei - ret -; -;*********************************************************** -;* * -;*********************************************************** -vers: ;get version number (#12) CP/M function - mvi c,versf - jmp ?bdos ;return through bdos -; -;*********************************************************** -;* * -;*********************************************************** - end - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/MPMDIO.DCL b/software/CPM/CPM25_PLI80_v14/MPMDIO.DCL deleted file mode 100644 index 95ea165..0000000 --- a/software/CPM/CPM25_PLI80_v14/MPMDIO.DCL +++ /dev/null @@ -1,35 +0,0 @@ -declare - amemrq entry (pointer) returns (bit(1)), - rmemrq entry (pointer) returns (bit(1)), - memfr entry (pointer), - poll entry (fixed(7)), - flgwt entry (fixed(7)) returns (bit(1)), - flgset entry (fixed(7)) returns (bit(1)), - makque entry (pointer), - opnque entry (pointer) returns (bit(1)), - delque entry (pointer) returns (bit(1)), - rdque entry (pointer), - crdque entry (pointer) returns (bit(1)), - wrque entry (pointer), - cwrque entry (pointer) returns (bit(1)), - delay entry (fixed(15)), - dsptch entry, - term entry (bit(16)), - crproc entry (pointer), - setpri entry (fixed(7)), - attcon entry, - detcon entry, - setcon entry (fixed(7)), - asncon entry (pointer) returns (bit(1)), - sclicd entry (pointer), - clresp entry (pointer) returns (bit(16)), - parse entry (pointer) returns (pointer), - getcon entry returns (fixed(7)), - sysdat entry returns (pointer), - gettod entry (pointer), - rpdadr entry returns (pointer), - abtspr entry (pointer) returns (bit(1)), - - disabl entry, - enable entry; - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/NETWORK.PLI b/software/CPM/CPM25_PLI80_v14/NETWORK.PLI deleted file mode 100644 index af36cfc..0000000 --- a/software/CPM/CPM25_PLI80_v14/NETWORK.PLI +++ /dev/null @@ -1,267 +0,0 @@ -/******************************************************/ -/* This program finds the shortest path between nodes */ -/* in a network. It has 8 internal procedures: */ -/* SETUP, CONNECT, FIND, PRINT_ALL, PRINT_PATHS, */ -/* SHORTEST_DISTANCE, PRINT_ROUTE, and FREE_ALL. */ -/******************************************************/ -network: - procedure options(main); - %replace - true by '1'b, - false by '0'b, - citysize by 20, - infinite by 32767; - declare - sysin file; - declare - 1 city_node based, - 2 city_name character(citysize) varying, - 2 total_distance fixed, - 2 investigate bit, - 2 city_list pointer, - 2 route_head pointer; - declare - 1 route_node based, - 2 next_city pointer, - 2 route_distance fixed, - 2 route_list pointer; - declare - city_head pointer; - - do while(true); - call setup(); - if city_head = null then - stop; - call print_all(); - call print_paths(); - call free_all(); - end; - -/******************************************************/ -/* This procedure reads two cities and then calls the */ -/* procedure CONNECT to establish the connection (in */ -/* both directions) between the cities. */ -/******************************************************/ - setup: - procedure; - declare - distance fixed, - (city1, city2) character(citysize) varying; - on endfile(sysin) goto eof; - city_head = null; - put skip list('Type "City1, Dist, City2"'); - put skip; - do while(true); - get list(city1, distance, city2); - call connect(city1, distance, city2); - call connect(city2, distance, city1); - end; - eof: - end setup; - -/******************************************************/ -/* This procedure establishes a single route_node to */ -/* connect the first city to the second city by */ -/* calling the FIND procedure twice; once for the */ -/* first city and once for the second city. */ -/******************************************************/ - connect: - procedure(source_city, distance, destination_city); - declare - source_city character(citysize) varying, - destination_city character(citysize) varying, - distance fixed, - (r, s, d) pointer; - - s = find(source_city); - d = find(destination_city); - allocate route_node set (r); - r->route_distance = distance; - r->next_city = d; - r->route_list = s->route_head; - s->route_head = r; - end connect; - -/******************************************************/ -/* This procedure searches the list of cities and */ -/* returns a pointer to the requested city_node. */ -/******************************************************/ - find: - procedure(city) returns(pointer); - declare - city character(citysize) varying, - (p, q) pointer; - - do p = city_head - repeat(p->city_list) while(p^=null); - if city = p->city_name then - return(p); - end; - allocate city_node set(p); - p->city_name = city; - p->city_list = city_head; - city_head = p; - p->total_distance = infinite; - p->route_head = null; - return(p); - end find; - -/******************************************************/ -/* This procedure starts at the city_head and displays*/ -/* all the cities in the city_list. */ -/******************************************************/ - print_all: - procedure; - declare - (p, q) pointer; - - do p = city_head - repeat(p->city_list) while(p^=null); - put skip list(p->city_name,':'); - do q = p->route_head - repeat(q->route_list) while(q^=null); - put skip list(q->route_distance,'miles to', - q->next_city->city_name); - end; - end; - end print_all; - -/******************************************************/ -/* This procedure reads a destination city, calls the */ -/* SHORTEST_DISTANCE procedure, and sets the */ -/* total_distance field in each city_node to the */ -/* total distance from the destination city. */ -/******************************************************/ - print_paths: - procedure; - declare - city character(citysize) varying; - - on endfile(sysin) goto eof; - do while(true); - put skip list('Type Destination '); - get list(city); - call shortest_distance(city); - on endfile(sysin) goto eol; - do while(true); - put skip list('Type Start '); - get list(city); - call print_route(city); - end; - eol: revert endfile(sysin); - end; - eof: - end print_paths; - -/******************************************************/ -/* This procedure is the heart of the program. It */ -/* takes an input city (the destination), and computes*/ -/* the minimum total distance from every city in the */ -/* network to the destination. It then records this */ -/* minimum value in the total_distance field of every */ -/* city_node. */ -/******************************************************/ - shortest_distance: - procedure(city); - declare - city character(citysize) varying; - declare - bestp pointer, - (d, bestd) fixed, - (p, q, r) pointer; - do p = city_head - repeat(p->city_list) while(p^=null); - p->total_distance = infinite; - p->investigate = false; - end; - p = find(city); - p->total_distance = 0; - p->investigate = true; - do while(true); - bestp = null; - bestd = infinite; - do p = city_head - repeat(p->city_list) while(p^=null); - if p->investigate then - do; - if p->total_distance < bestd then - do; - bestd = p->total_distance; - bestp = p; - end; - end; - end; - if bestp = null then - return; - bestp->investigate = false; - do q = bestp->route_head - repeat(q->route_list) while(q^=null); - r = q->next_city; - d = bestd + q->route_distance; - if d < r->total_distance then - do; - r->total_distance = d; - r->investigate = true; - end; - end; - end; - end shortest_distance; - -/******************************************************/ -/* This procedure displays the best route from the */ -/* input city to the destination. */ -/******************************************************/ - print_route: - procedure(city); - declare - city character(citysize) varying; - declare - (p,q) pointer, - (t,d) fixed; - p = find(city); - do while(true); - t = p->total_distance; - if t = infinite then - do; - put skip list('(No Connection)'); - return; - end; - if t = 0 then - return; - put skip list(t,'miles remain,'); - q = p->route_head; - do while(q^=null); - p = q->next_city; - d = q->route_distance; - if t = d + p->total_distance then - do; - put list(d,'miles to',p->city_name); - q = null; - end; - else - q = q->route_list; - end; - end; - end print_route; - -/******************************************************/ -/* This procedure frees all the storage allocated */ -/* by the program while processing the network. */ -/******************************************************/ - free_all: - procedure; - declare - (p, q) pointer; - do p = city_head - repeat(p->city_list) while(p^=null); - do q = p->route_head - repeat(q->route_list) while(q^=null); - free q->route_node; - end; - free p->city_node; - end; - end free_all; - -end network; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/OPTIMIST (2).PLI b/software/CPM/CPM25_PLI80_v14/OPTIMIST (2).PLI deleted file mode 100644 index 2aae57f..0000000 --- a/software/CPM/CPM25_PLI80_v14/OPTIMIST (2).PLI +++ /dev/null @@ -1,49 +0,0 @@ -/******************************************************/ -/* This program demonstrates PL/I character string */ -/* processing by turning a negative sentence into a */ -/* positive one. */ -/******************************************************/ -optimist: - procedure options(main); - %replace - true by '1'b, - false by '0'b, - nwords by 5; - declare - negative (1:nwords) character(8) varying static initial - (' never',' none',' nothing',' not',' no'), - positive (1:nwords) character(10) varying static initial - (' always',' all',' something','',' some'), - upper character(28) static initial - ('ABCDEFGHIJKLMNOPQRSTUVWXYZ. '), - lower character(28) static initial - ('abcdefghijklmnopqrstuvwxyz. '), - sent character(254) varying, - word character(32) varying, - (i,j) fixed; - - do while(true); - put skip list('What''s up? '); - sent = ' '; - do while - (substr(sent,length(sent)) ^= '.'); - get list (word); - sent = sent !! ' ' !! word; - end; - sent = translate(sent,lower,upper); - if verify(sent,lower) ^= 0 then - sent = ' that''s an interesting idea.'; - do i = 1 to nwords; - j = index(sent,negative(i)); - if j ^= 0 then - sent = substr(sent,1,j-1) !! - positive(i) !! - substr(sent,j+length(negative(i))); - end; - put list('Actually,'!!sent); - put skip; - end; - -end optimist; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/OPTIMIST.COM b/software/CPM/CPM25_PLI80_v14/OPTIMIST.COM deleted file mode 100644 index bb2c5a7..0000000 Binary files a/software/CPM/CPM25_PLI80_v14/OPTIMIST.COM and /dev/null differ diff --git a/software/CPM/CPM25_PLI80_v14/OPTIMIST.PLI b/software/CPM/CPM25_PLI80_v14/OPTIMIST.PLI deleted file mode 100644 index 545dd68..0000000 --- a/software/CPM/CPM25_PLI80_v14/OPTIMIST.PLI +++ /dev/null @@ -1,44 +0,0 @@ -optimist: - proc options(main); - %replace - true by '1'b, - false by '0'b, - nwords by 6; - dcl - negative (1:nwords) char(8) var static initial - (' never',' none',' nothing',' not',' no',' turkey'), - positive (1:nwords) char(10) var static initial - (' always',' all',' something','',' some',' good guy'), - upper char(28) static initial - ('ABCDEFGHIJKLMNOPQRSTUVWXYZ. '), - lower char(28) static initial - ('abcdefghijklmnopqrstuvwxyz. '); - dcl - sent char(254) var, - word char(32) var; - dcl - (i,j) fixed; - - do while(true); - put skip list('What''s up? '); - sent = ' '; - do while - (substr(sent,length(sent)) ^= '.'); - get list (word); - sent = sent !! ' ' !! word; - end; - sent = translate(sent,lower,upper); - if verify(sent,lower) ^= 0 then - sent = ' that''s an interesting idea.'; - do i = 1 to nwords; - j = index(sent,negative(i)); - if j ^= 0 then - sent = substr(sent,1,j-1) !! - positive(i) !! - substr(sent,j+length(negative(i))); - end; - put list('Actually,'!!sent); - put skip; - end; - end optimist; - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/PLI.COM b/software/CPM/CPM25_PLI80_v14/PLI.COM deleted file mode 100644 index 2bfc759..0000000 Binary files a/software/CPM/CPM25_PLI80_v14/PLI.COM and /dev/null differ diff --git a/software/CPM/CPM25_PLI80_v14/PLI0.OVL b/software/CPM/CPM25_PLI80_v14/PLI0.OVL deleted file mode 100644 index 46d15d9..0000000 Binary files a/software/CPM/CPM25_PLI80_v14/PLI0.OVL and /dev/null differ diff --git a/software/CPM/CPM25_PLI80_v14/PLI1.OVL b/software/CPM/CPM25_PLI80_v14/PLI1.OVL deleted file mode 100644 index 69479ba..0000000 Binary files a/software/CPM/CPM25_PLI80_v14/PLI1.OVL and /dev/null differ diff --git a/software/CPM/CPM25_PLI80_v14/PLI2.OVL b/software/CPM/CPM25_PLI80_v14/PLI2.OVL deleted file mode 100644 index 3961589..0000000 Binary files a/software/CPM/CPM25_PLI80_v14/PLI2.OVL and /dev/null differ diff --git a/software/CPM/CPM25_PLI80_v14/PLILIB.IRL b/software/CPM/CPM25_PLI80_v14/PLILIB.IRL deleted file mode 100644 index 3e3344f..0000000 Binary files a/software/CPM/CPM25_PLI80_v14/PLILIB.IRL and /dev/null differ diff --git a/software/CPM/CPM25_PLI80_v14/RECORD.DCL b/software/CPM/CPM25_PLI80_v14/RECORD.DCL deleted file mode 100644 index 3a22c82..0000000 --- a/software/CPM/CPM25_PLI80_v14/RECORD.DCL +++ /dev/null @@ -1,9 +0,0 @@ - dcl - 1 record, - 2 name character(30) varying, - 2 addr character(30) varying, - 2 city character(20) varying, - 2 state character(10) varying, - 2 zip fixed decimal(6), - 2 phone character(12) varying; - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/RELNOTES.PRN b/software/CPM/CPM25_PLI80_v14/RELNOTES.PRN deleted file mode 100644 index 8d1c831..0000000 Binary files a/software/CPM/CPM25_PLI80_v14/RELNOTES.PRN and /dev/null differ diff --git a/software/CPM/CPM25_PLI80_v14/REPORT.PLI b/software/CPM/CPM25_PLI80_v14/REPORT.PLI deleted file mode 100644 index 6a440cc..0000000 --- a/software/CPM/CPM25_PLI80_v14/REPORT.PLI +++ /dev/null @@ -1,55 +0,0 @@ -/******************************************************/ -/* This program reads an employee data base and */ -/* prints a list of paychecks. */ -/******************************************************/ -report: - procedure options(main); - declare - 1 employee static, - 2 name character(30) varying, - 2 address, - 3 street character(30) varying, - 3 city character(10) varying, - 3 state character(12) varying, - 3 zip fixed decimal(5), - 2 age fixed decimal(3), - 2 wage fixed decimal(5,2), - 2 hours fixed decimal(5,1); - - declare - i fixed, - dashes character(15) static initial - ('$--------------'), - buff character(20) varying, - (grosspay, withhold) fixed decimal(7,2), - (repfile, empfile) file; - - open file(empfile) keyed environment(f(128),b(4000)) - title ('$1.EMP'); - open file(repfile) stream print environment(b(2000)) - title('$2.$2'); - - put list('Set Top of Forms, Press Return'); - get skip; - - do while('1'b); - read file(empfile) into(employee); - if name = 'EOF' then - stop; - put file(repfile) skip(2); - buff = '[' !! name !! ']^m^j'; - write file(repfile) from (buff); - grosspay = wage * hours; - withhold = grosspay * .15; - buff = grosspay - withhold; - do i = 1 to 15 - while (substr(buff,i,1) = ' '); - end; - i = i - 1; - substr(buff,1,i) = substr(dashes,1,i); - write file (repfile) from(buff); - end; - -end report; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/RETRIEVE.PLI b/software/CPM/CPM25_PLI80_v14/RETRIEVE.PLI deleted file mode 100644 index b2669c0..0000000 --- a/software/CPM/CPM25_PLI80_v14/RETRIEVE.PLI +++ /dev/null @@ -1,56 +0,0 @@ -/******************************************************/ -/* This program reads a name and address data file */ -/* and displays the information on request. */ -/******************************************************/ -retrieve: - procedure options(main); - -%include 'record.dcl'; -%replace - true by '1'b, - false by '0'b; - - declare - (sysprint, input) file, - filename character(14) varying, - (lower, upper) character(30) varying, - eofile bit(1); - - open file(sysprint) print title('$con'); - put list('Name and Address Retrieval, File Name: '); - get list(filename); - - do while(true); - lower = 'AAAAAAAAAAAAAAAAAAAAAAAAAAAAAA'; - upper = 'zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz'; - put skip(2) list('Type Lower, Upper Bounds: '); - get list(lower,upper); - if lower = 'EOF' then - stop; - - open file(input) stream input environment(b(1024)) - title(filename); - eofile = false; - do while (^eofile); - get file(input) list(name); - eofile = (name = 'EOF'); - if ^eofile then - do; - get file(input) - list(addr,city,state,zip,phone); - if name >= lower & name <= upper then - do; - put page skip(3)list(name); - put skip list(addr); - put skip list(city,state); - put skip list(zip); - put skip list(phone); - end; - end; - end; - close file(input); - end; - -end retrieve; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/REVERSE.PLI b/software/CPM/CPM25_PLI80_v14/REVERSE.PLI deleted file mode 100644 index 9d9de6e..0000000 --- a/software/CPM/CPM25_PLI80_v14/REVERSE.PLI +++ /dev/null @@ -1,54 +0,0 @@ -/******************************************************/ -/* This program reads a sentence and reverses it. */ -/******************************************************/ -reverse: - procedure options(main); - declare - sentence pointer, - 1 wordnode based (sentence), - 2 word character(30) varying, - 2 next pointer; - - do while('1'b); - call read_it(); - if sentence = null then - stop; - call write_it(); - end; - - read_it: - procedure; - declare - newword character(30) varying, - newnode pointer; - sentence = null; - put skip list('What''s up? '); - do while('1'b); - get list(newword); - if newword = '.' then - return; - allocate wordnode set (newnode); - newnode->next = sentence; - sentence = newnode; - word = newword; - end; - end read_it; - - write_it: - procedure; - declare - p pointer; - put skip list('Actually, '); - do while (sentence ^= null); - put list(word); - p = sentence; - sentence = next; - free p->wordnode; - end; - put list('.'); - put skip; - end write_it; - -end reverse; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/REVERT.PLI b/software/CPM/CPM25_PLI80_v14/REVERT.PLI deleted file mode 100644 index 211d912..0000000 --- a/software/CPM/CPM25_PLI80_v14/REVERT.PLI +++ /dev/null @@ -1,34 +0,0 @@ -/******************************************************/ -/* This program is nonfunctional. Its purpose is to */ -/* illustrate how PL/I executes the ON and REVERT */ -/* statements. */ -/******************************************************/ -auto_revert: - procedure options(main); - declare - i fixed, - sysin file; - - do i = 1 to 10000; - call p(i,exit); - exit: - end; - - P: - procedure (index,lab); - declare - (t, index) fixed, - lab label; - - on endfile(sysin) - goto lab; - - put skip list(index,':'); - get list(t); - if t = index then - goto lab; - end P; /* implicit REVERT supplied here */ - -end auto_revert; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/RFACT.PLI b/software/CPM/CPM25_PLI80_v14/RFACT.PLI deleted file mode 100644 index c9b8fc5..0000000 --- a/software/CPM/CPM25_PLI80_v14/RFACT.PLI +++ /dev/null @@ -1,24 +0,0 @@ -/******************************************************/ -/* This program evaluates the Factorial function (n!) */ -/* using recursion. */ -/******************************************************/ -rfact: - procedure options(main); - declare - i fixed; - do i = 0 repeat(i+1); - put skip list('factorial(',i,')=',factorial(i)); - end; - stop; - - factorial: - procedure(i) returns(fixed) recursive; - declare - i fixed; - if i = 0 then return (1); - return (i * factorial(i-1)); - end factorial; - -end rfact; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/RMAC.COM b/software/CPM/CPM25_PLI80_v14/RMAC.COM deleted file mode 100644 index 87b62da..0000000 Binary files a/software/CPM/CPM25_PLI80_v14/RMAC.COM and /dev/null differ diff --git a/software/CPM/CPM25_PLI80_v14/SAMPLE.PLI b/software/CPM/CPM25_PLI80_v14/SAMPLE.PLI deleted file mode 100644 index 2c9a5c1..0000000 --- a/software/CPM/CPM25_PLI80_v14/SAMPLE.PLI +++ /dev/null @@ -1,41 +0,0 @@ -sample: - procedure options(main); - declare - c character(10) varying, - i fixed binary(15); - - do; - put skip list('Input: '); - get list(c); - c = upper(c); /* function reference */ - put skip list('Output: ',c); - end; - - begin; - declare - c float binary(24); - - put skip list('Input: '); - get list(c); - call output(c); /* subroutine invocation */ - end; - - upper: - procedure(c) returns(character(10) varying); - declare - c character(10) varying; - - return(translate(c,'ABCDEFGHIJKLMNOPQRSTUVWXYZ', - 'abcdefghijklmnopqrstuvwxyz')); - end upper; - - output: - procedure(c); - declare - c float binary(24); - - put skip edit(c) (column(20),e(10,2)); - end output; - -end sample; - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/TEST.PLI b/software/CPM/CPM25_PLI80_v14/TEST.PLI deleted file mode 100644 index 7df6c39..0000000 --- a/software/CPM/CPM25_PLI80_v14/TEST.PLI +++ /dev/null @@ -1,35 +0,0 @@ -/***************************************************/ -/* This program computes the largest of three */ -/* FLOAT BINARY numbers x, y, and z */ -/***************************************************/ -test: - procedure options(main); - declare - (a,b,c) float binary; - - put list ('Type Three Numbers: '); - get list (a,b,c); - put list ('The Largest Value is',max3(a,b,c)); - - /* this procedure computes the largest of x, y, and z */ - max3: - procedure(x,y,z) returns(float binary); - declare - (x,y,z,max) float binary; - - if x > y then - if x > z then - max = x; - else - max = z; - else - if y > z then - max = y; - else - max = z; - return(max); - end max3; - -end test; - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/UPDATE.PLI b/software/CPM/CPM25_PLI80_v14/UPDATE.PLI deleted file mode 100644 index 7ce9729..0000000 --- a/software/CPM/CPM25_PLI80_v14/UPDATE.PLI +++ /dev/null @@ -1,67 +0,0 @@ -/******************************************************/ -/* This program allows you to retrieve and update */ -/* individual records in an employee data base using */ -/* a keyed file. */ -/******************************************************/ -update: - procedure options(main); - declare - 1 employee static, - 2 name character(30) varying, - 2 address, - 3 street character(30) varying, - 3 city character(10) varying, - 3 state character(12) varying, - 3 zip fixed decimal(5), - 2 age fixed decimal(3), - 2 wage fixed decimal(5,2), - 2 hours fixed decimal(5,1); - - declare - 1 keylist (100), - 2 keyname character(30) varying, - 2 keyval fixed binary; - - declare - (i, endlist) fixed, - eolist bit(1) static initial('0'b), - matchname character(30) varying, - (emp, keys) file; - - open file(emp) update direct environment(f(128)) - title ('$1.EMP'); - - open file(keys) stream environment(b(4000)) - title('$1.key'); - - do i = 1 to 100 while(^eolist); - get file(keys) list(keyname(i),keyval(i)); - eolist = keyname(i) = 'EOF'; - end; - - do while('1'b); - put skip list('Employee: '); - get list(matchname); - if matchname = 'EOF' then - stop; - do i = 1 to 100; - if matchname = keyname(i) then - do; - read file(emp) into(employee) - key(keyval(i)); - put skip list('Address: ', - street, city, state, zip); - put skip list(' '); - get list(street, city, state, zip); - put list('Hours:',hours,': '); - get list(hours); - write file(emp) from (employee) - keyfrom(keyval(i)); - end; - end; - end; - -end update; - - - \ No newline at end of file diff --git a/software/CPM/CPM25_PLI80_v14/XREF.COM b/software/CPM/CPM25_PLI80_v14/XREF.COM deleted file mode 100644 index 32c57ae..0000000 Binary files a/software/CPM/CPM25_PLI80_v14/XREF.COM and /dev/null differ diff --git a/software/CPM/CPM25_PLI80_v14/Z80.LIB b/software/CPM/CPM25_PLI80_v14/Z80.LIB deleted file mode 100644 index 4f29a00..0000000 --- a/software/CPM/CPM25_PLI80_v14/Z80.LIB +++ /dev/null @@ -1,457 +0,0 @@ -; @CHK MACRO USED FOR CHECKING 8 BIT DISPLACMENTS -; -@CHK MACRO ?DD ;; USED FOR CHECKING RANGE OF 8-BIT DISP.S - IF (?DD GT 7FH) AND (?DD LT 0FF80H) - 'DISPLACEMENT RANGE ERROR - Z80 LIB' - ENDIF - ENDM -LDX MACRO ?R,?D - @CHK ?D - DB 0DDH,?R*8+46H,?D - ENDM -LDY MACRO ?R,?D - @CHK ?D - DB 0FDH,?R*8+46H,?D - ENDM -STX MACRO ?R,?D - @CHK ?D - DB 0DDH,70H+?R,?D - ENDM -STY MACRO ?R,?D - @CHK ?D - DB 0FDH,70H+?R,?D - ENDM -MVIX MACRO ?N,?D - @CHK ?D - DB 0DDH,36H,?D,?N - ENDM -MVIY MACRO ?N,?D - @CHK ?D - DB 0FDH,36H,?D,?N - ENDM -LDAI MACRO - DB 0EDH,57H - ENDM -LDAR MACRO - DB 0EDH,5FH - ENDM -STAI MACRO - DB 0EDH,47H - ENDM -STAR MACRO - DB 0EDH,4FH - ENDM - -LXIX MACRO ?NNNN - DB 0DDH,21H - DW ?NNNN - ENDM -LXIY MACRO ?NNNN - DB 0FDH,21H - DW ?NNNN - ENDM -LDED MACRO ?NNNN - DB 0EDH,5BH - DW ?NNNN - ENDM -LBCD MACRO ?NNNN - DB 0EDH,4BH - DW ?NNNN - ENDM -LSPD MACRO ?NNNN - DB 0EDH,07BH - DW ?NNNN - ENDM -LIXD MACRO ?NNNN - DB 0DDH,2AH - DW ?NNNN - ENDM -LIYD MACRO ?NNNN - DB 0FDH,2AH - DW ?NNNN - ENDM -SBCD MACRO ?NNNN - DB 0EDH,43H - DW ?NNNN - ENDM -SDED MACRO ?NNNN - DB 0EDH,53H - DW ?NNNN - ENDM -SSPD MACRO ?NNNN - DB 0EDH,73H - DW ?NNNN - ENDM -SIXD MACRO ?NNNN - DB 0DDH,22H - DW ?NNNN - ENDM -SIYD MACRO ?NNNN - DB 0FDH,22H - DW ?NNNN - ENDM -SPIX MACRO - DB 0DDH,0F9H - ENDM -SPIY MACRO - DB 0FDH,0F9H - ENDM -PUSHIX MACRO - DB 0DDH,0E5H - ENDM -PUSHIY MACRO - DB 0FDH,0E5H - ENDM -POPIX MACRO - DB 0DDH,0E1H - ENDM -POPIY MACRO - DB 0FDH,0E1H - ENDM -EXAF MACRO - DB 08H - ENDM -EXX MACRO - DB 0D9H - ENDM -XTIX MACRO - DB 0DDH,0E3H - ENDM -XTIY MACRO - DB 0FDH,0E3H - ENDM - -LDI MACRO - DB 0EDH,0A0H - ENDM -LDIR MACRO - DB 0EDH,0B0H - ENDM -LDD MACRO - DB 0EDH,0A8H - ENDM -LDDR MACRO - DB 0EDH,0B8H - ENDM -CCI MACRO - DB 0EDH,0A1H - ENDM -CCIR MACRO - DB 0EDH,0B1H - ENDM -CCD MACRO - DB 0EDH,0A9H - ENDM -CCDR MACRO - DB 0EDH,0B9H - ENDM - -ADDX MACRO ?D - @CHK ?D - DB 0DDH,86H,?D - ENDM -ADDY MACRO ?D - @CHK ?D - DB 0FDH,86H,?D - ENDM -ADCX MACRO ?D - @CHK ?D - DB 0DDH,8EH,?D - ENDM -ADCY MACRO ?D - @CHK ?D - DB 0FDH,8EH,?D - ENDM -SUBX MACRO ?D - @CHK ?D - DB 0DDH,96H,?D - ENDM -SUBY MACRO ?D - @CHK ?D - DB 0FDH,96H,?D - ENDM -SBCX MACRO ?D - @CHK ?D - DB 0DDH,9EH,?D - ENDM -SBCY MACRO ?D - @CHK ?D - DB 0FDH,9EH,?D - ENDM -ANDX MACRO ?D - @CHK ?D - DB 0DDH,0A6H,?D - ENDM -ANDY MACRO ?D - @CHK ?D - DB 0FDH,0A6H,?D - ENDM -XORX MACRO ?D - @CHK ?D - DB 0DDH,0AEH,?D - ENDM -XORY MACRO ?D - @CHK ?D - DB 0FDH,0AEH,?D - ENDM -ORX MACRO ?D - @CHK ?D - DB 0DDH,0B6H,?D - ENDM -ORY MACRO ?D - @CHK ?D - DB 0FDH,0B6H,?D - ENDM -CMPX MACRO ?D - @CHK ?D - DB 0DDH,0BEH,?D - ENDM -CMPY MACRO ?D - @CHK ?D - DB 0FDH,0BEH,?D - ENDM -INRX MACRO ?D - @CHK ?D - DB 0DDH,34H,?D - ENDM -INRY MACRO ?D - @CHK ?D - DB 0FDH,34H,?D - ENDM -DCRX MACRO ?D - @CHK ?D - DB 0DDH,035H,?D - ENDM -DCRY MACRO ?D - @CHK ?D - DB 0FDH,35H,?D - ENDM - -NEG MACRO - DB 0EDH,44H - ENDM -IM0 MACRO - DB 0EDH,46H - ENDM -IM1 MACRO - DB 0EDH,56H - ENDM -IM2 MACRO - DB 0EDH,5EH - ENDM - - -BC EQU 0 -DE EQU 2 -HL EQU 4 -IX EQU 4 -IY EQU 4 -DADC MACRO ?R - DB 0EDH,?R*8+4AH - ENDM -DSBC MACRO ?R - DB 0EDH,?R*8+42H - ENDM -DADX MACRO ?R - DB 0DDH,?R*8+09H - ENDM -DADY MACRO ?R - DB 0FDH,?R*8+09H - ENDM -INXIX MACRO - DB 0DDH,23H - ENDM -INXIY MACRO - DB 0FDH,23H - ENDM -DCXIX MACRO - DB 0DDH,2BH - ENDM -DCXIY MACRO - DB 0FDH,2BH - ENDM - -BIT MACRO ?N,?R - DB 0CBH,?N*8+?R+40H - ENDM -SETB MACRO ?N,?R - DB 0CBH,?N*8+?R+0C0H - ENDM -RES MACRO ?N,?R - DB 0CBH,?N*8+?R+80H - ENDM - -BITX MACRO ?N,?D - @CHK ?D - DB 0DDH,0CBH,?D,?N*8+46H - ENDM -BITY MACRO ?N,?D - @CHK ?D - DB 0FDH,0CBH,?D,?N*8+46H - ENDM -SETX MACRO ?N,?D - @CHK ?D - DB 0DDH,0CBH,?D,?N*8+0C6H - ENDM -SETY MACRO ?N,?D - @CHK ?D - DB 0FDH,0CBH,?D,?N*8+0C6H - ENDM -RESX MACRO ?N,?D - @CHK ?D - DB 0DDH,0CBH,?D,?N*8+86H - ENDM -RESY MACRO ?N,?D - @CHK ?D - DB 0FDH,0CBH,?D,?N*8+86H - ENDM - -JR MACRO ?N - DB 18H,?N-$-1 - ENDM -JRC MACRO ?N - DB 38H,?N-$-1 - ENDM -JRNC MACRO ?N - DB 30H,?N-$-1 - ENDM -JRZ MACRO ?N - DB 28H,?N-$-1 - ENDM -JRNZ MACRO ?N - DB 20H,?N-$-1 - ENDM -DJNZ MACRO ?N - DB 10H,?N-$-1 - ENDM - -PCIX MACRO - DB 0DDH,0E9H - ENDM -PCIY MACRO - DB 0FDH,0E9H - ENDM - -RETI MACRO - DB 0EDH,4DH - ENDM -RETN MACRO - DB 0EDH,45H - ENDM - -INP MACRO ?R - DB 0EDH,?R*8+40H - ENDM -OUTP MACRO ?R - DB 0EDH,?R*8+41H - ENDM -INI MACRO - DB 0EDH,0A2H - ENDM -INIR MACRO - DB 0EDH,0B2H - ENDM -IND MACRO - DB 0EDH,0AAH - ENDM -INDR MACRO - DB 0EDH,0BAH - ENDM -OUTI MACRO - DB 0EDH,0A3H - ENDM -OUTIR MACRO - DB 0EDH,0B3H - ENDM -OUTD MACRO - DB 0EDH,0ABH - ENDM -OUTDR MACRO - DB 0EDH,0BBH - ENDM - - -RLCR MACRO ?R - DB 0CBH, 00H + ?R - ENDM -RLCX MACRO ?D - @CHK ?D - DB 0DDH, 0CBH, ?D, 06H - ENDM -RLCY MACRO ?D - @CHK ?D - DB 0FDH, 0CBH, ?D, 06H - ENDM -RALR MACRO ?R - DB 0CBH, 10H+?R - ENDM -RALX MACRO ?D - @CHK ?D - DB 0DDH, 0CBH, ?D, 16H - ENDM -RALY MACRO ?D - @CHK ?D - DB 0FDH, 0CBH, ?D, 16H - ENDM -RRCR MACRO ?R - DB 0CBH, 08H + ?R - ENDM -RRCX MACRO ?D - @CHK ?D - DB 0DDH, 0CBH, ?D, 0EH - ENDM -RRCY MACRO ?D - @CHK ?D - DB 0FDH, 0CBH, ?D, 0EH - ENDM -RARR MACRO ?R - DB 0CBH, 18H + ?R - ENDM -RARX MACRO ?D - @CHK ?D - DB 0DDH, 0CBH, ?D, 1EH - ENDM -RARY MACRO ?D - @CHK ?D - DB 0FDH, 0CBH, ?D, 1EH - ENDM -SLAR MACRO ?R - DB 0CBH, 20H + ?R - ENDM -SLAX MACRO ?D - @CHK ?D - DB 0DDH, 0CBH, ?D, 26H - ENDM -SLAY MACRO ?D - @CHK ?D - DB 0FDH, 0CBH, ?D, 26H - ENDM -SRAR MACRO ?R - DB 0CBH, 28H+?R - ENDM -SRAX MACRO ?D - @CHK ?D - DB 0DDH, 0CBH, ?D, 2EH - ENDM -SRAY MACRO ?D - @CHK ?D - DB 0FDH, 0CBH, ?D, 2EH - ENDM -SRLR MACRO ?R - DB 0CBH, 38H + ?R - ENDM -SRLX MACRO ?D - @CHK ?D - DB 0DDH, 0CBH, ?D, 3EH - ENDM -SRLY MACRO ?D - @CHK ?D - DB 0FDH, 0CBH, ?D, 3EH - ENDM -RLD MACRO - DB 0EDH, 6FH - ENDM -RRD MACRO - DB 0EDH, 67H - ENDM - \ No newline at end of file diff --git a/software/CPM/CPM26_TPASCAL_v300a/cmdlin.pas b/software/CPM/CPM26_TPASCAL_v300a/cmdlin.pas deleted file mode 100644 index f9ef0df..0000000 Binary files a/software/CPM/CPM26_TPASCAL_v300a/cmdlin.pas and /dev/null differ diff --git a/software/CPM/CPM26_TPASCAL_v300a/lister.pas b/software/CPM/CPM26_TPASCAL_v300a/lister.pas deleted file mode 100644 index 47bc609..0000000 Binary files a/software/CPM/CPM26_TPASCAL_v300a/lister.pas and /dev/null differ diff --git a/software/CPM/CPM26_TPASCAL_v300a/mc-mod00.inc b/software/CPM/CPM26_TPASCAL_v300a/mc-mod00.inc deleted file mode 100644 index 405a57e..0000000 --- a/software/CPM/CPM26_TPASCAL_v300a/mc-mod00.inc +++ /dev/null @@ -1,43 +0,0 @@ -{.PA} -{*******************************************************************} -{* SOURCE CODE MODULE: MC-MOD00 *} -{* PURPOSE: Micellaneous utilities an commands. *} -{*******************************************************************} - - -procedure Msg(S: AnyString); -begin - GotoXY(1,24); - ClrEol; - Write(S); -end; - -procedure Flash(X: integer; S: AnyString; Blink: boolean); -begin - HighVideo; - GotoXY(X,23); - Write(S); - if Blink then - begin - repeat - GotoXY(X,23); - Blink:=not Blink; if Blink then HighVideo else LowVideo; - Write(S); - Delay(175); - until KeyPressed; - end; - LowVideo; -end; - -procedure Auto; -begin - AutoCalc:=not AutoCalc; - if AutoCalc then Flash(65,'AutoCalc: ON ',false) - else Flash(65,'AutoCalc: OFF',false); -end; - -then Flash(65,'AutoCalc: ON ',false) - else Flash(65,'AutoCalc: OFF',false); -end; - - \ No newline at end of file diff --git a/software/CPM/CPM26_TPASCAL_v300a/mc-mod01.inc b/software/CPM/CPM26_TPASCAL_v300a/mc-mod01.inc deleted file mode 100644 index 0b24989..0000000 --- a/software/CPM/CPM26_TPASCAL_v300a/mc-mod01.inc +++ /dev/null @@ -1,74 +0,0 @@ -{.PA} - -{*******************************************************************} -{* SOURCE CODE MODULE: MC-MOD01 *} -{* PURPOSE: Display grid and initialize all cells *} -{* in the spread sheet. *} -{*******************************************************************} - - - -procedure Grid; -var I: integer; - Count: Char; -begin - HighVideo; - For Count:='A' to FXMax do - begin - GotoXY(XPos[Count],1); - Write(Count); - end; - GotoXY(1,2); - for I:=1 to FYMax do writeln(I:2); - LowVideo; - if AutoCalc then Flash(65,'AutoCalc: ON' ,false) - else Flash(65,'AutoCalc: OFF',false); - Flash(33,' Type / for Commands',false); -end; - - -procedure Init; -var - I: ScreenIndex; - J: Integer; - LastName: string[2]; -begin - for I:='A' to FXMAX do - begin - for J:=1 to FYMAX do - begin - with Screen[I,J] do - begin - CellStatus:=[Txt]; - Contents:=''; - Value:=0; - DEC:=2; { Default number of decimals } - FW:=10; { Default field whith } - end; - end; - end; - AutoCalc:=True; - FX:='A'; FY:=1; { First field in upper left corner } -end; - -procedure Clear; -begin - HighVideo; - GotoXY(1,24); ClrEol; - Write('Clear this worksheet? (Y/N) '); - repeat Read(Kbd,Ch) until Upcase(Ch) in ['Y','N']; - Write(Upcase(Ch)); - if UpCase(Ch)='Y' then - begin - ClrScr; - Init; - Grid; - end; -end; - - -nd; -end; - - - \ No newline at end of file diff --git a/software/CPM/CPM26_TPASCAL_v300a/mc-mod02.inc b/software/CPM/CPM26_TPASCAL_v300a/mc-mod02.inc deleted file mode 100644 index e6a1881..0000000 --- a/software/CPM/CPM26_TPASCAL_v300a/mc-mod02.inc +++ /dev/null @@ -1,150 +0,0 @@ -{.PA} -{*******************************************************************} -{* SOURCE CODE MODULE: MC-MOD02 *} -{* PURPOSE: Display values in cells and move between *} -{* cells in the spread sheet. *} -{*******************************************************************} - - -procedure FlashType; -begin - with Screen[FX,FY] do - begin - GotoXY(1,23); - Write(FX,FY:2,' '); - if Formula in CellStatus then write('Formula:') else - if Constant in CellStatus then Write('Numeric ') else - if Txt in CellStatus then Write('Text '); - GotoXY(1,24); ClrEol; - if Formula in CellStatus then Write(Contents); - end; -end; - - -{ The following procedures move between the Cells on the calc sheet.} -{ Each Cell has an associated record containing its X,Y coordinates } -{ and data. See the type definition for "Cell". } - -procedure GotoCell(GX: ScreenIndex; GY: integer); -begin - with Screen[GX,GY] do - begin - HighVideo; - GotoXY(XPos[GX],GY+1); - Write(' '); - GotoXY(XPos[GX],GY+1); - if Txt in CellStatus then Write(Contents) - else - begin - if DEC>=0 then Write(Value:FW:DEC) - else Write(Value:FW); - end; - FlashType; - GotoXY(XPos[GX],GY+1); - end; - LowVideo; -end; - -{.CP20} - -procedure LeaveCell(FX:ScreenIndex;FY: integer); -begin - with Screen[FX,FY] do - begin - GotoXY(XPos[FX],FY+1); - LowVideo; - if Txt in CellStatus then Write(Contents) - else - begin - if DEC>=0 then Write(Value:FW:DEC) - else Write(Value:FW); - end; - end; -end; - - -{.CP20} - -procedure Update; -var - UFX: ScreenIndex; - UFY: integer; -begin - ClrScr; - Grid; - for UFX:='A' to FXMax do for UFY:=1 to FYMax do - if Screen[UFX,UFY].Contents<>'' then LeaveCell(UFX,UFY); - GotoCell(FX,FY); -end; - -{.CP20} - -procedure MoveDown; -var Start: integer; -begin - LeaveCell(FX,FY); - Start:=FY; - repeat - FY:=FY+1; - if FY>FYMax then FY:=1; - until (Screen[FX,FY].CellStatus*[OverWritten,Locked]=[]) or (FY=Start); - if FY<>Start then GotoCell(FX,FY); -end; - -{.CP20} - -procedure MoveUp; -var Start: integer; -begin - LeaveCell(FX,FY); - Start:=FY; - repeat - FY:=FY-1; - if FY<1 then FY:=FYMax; - until (Screen[FX,FY].CellStatus*[OverWritten,Locked]=[]) or (FY=Start); - if FY<>Start then GotoCell(FX,FY); -end; - -{.CP20} - -procedure MoveRight; -var Start: ScreenIndex; -begin - LeaveCell(FX,FY); - Start:=FX; - repeat - FX:=Succ(FX); - if FX>FXMax then - begin - FX:='A'; - FY:=FY+1; - if FY>FYMax then FY:=1; - end; - until (Screen[FX,FY].CellStatus*[OverWritten,Locked]=[]) or (FX=Start); - if FX<>Start then GotoCell(FX,FY); -end; - -{.CP20} - -procedure MoveLeft; -var Start: ScreenIndex; -begin - LeaveCell(FX,FY); - Start:=FX; - repeat - FX:=Pred(FX); - if FX<'A' then - begin - FX:=FXMax; - FY:=FY-1; - if FY<1 then FY:=FYMax; - end; - until (Screen[FX,FY].CellStatus*[OverWritten,Locked]=[]) or (FX=Start); - if FX<>Start then GotoCell(FX,FY); -end; - -ellStatus*[OverWritten,Locked]=[]) or (FX=Start); - if FX<>Start then GotoCell(FX,FY); -end; - - \ No newline at end of file diff --git a/software/CPM/CPM26_TPASCAL_v300a/mc-mod03.inc b/software/CPM/CPM26_TPASCAL_v300a/mc-mod03.inc deleted file mode 100644 index 62948f9..0000000 --- a/software/CPM/CPM26_TPASCAL_v300a/mc-mod03.inc +++ /dev/null @@ -1,195 +0,0 @@ -{.PA} -{*******************************************************************} -{* SOURCE CODE MODULE: MC-MOD03 *} -{* PURPOSE: Read, Save and Print a spread sheet. *} -{* Display on-line manual. *} -{*******************************************************************} - -type - String3 = string[3]; - -var - FileName: string[14]; - Line: string[100]; - -function Exist(FileN: AnyString): boolean; -var F: file; -begin - {$I-} - assign(F,FileN); - reset(F); - {$I+} - if IOResult<>0 then Exist:=false - else Exist:=true; -end; - - -procedure GetFileName(var Line: AnyString; FileType:String3); -begin - Line:=''; - repeat - Read(Kbd,Ch); - if Upcase(Ch) in ['A'..'Z',^M] then - begin - write(Upcase(Ch)); - Line:=Line+Ch; - end; - until (Ch=^M) or (length(Line)=8); - if Ch=^M then Delete(Line,Length(Line),1); - if Line<>'' then Line:=Line+'.'+FileType; -end; - -{.CP20} - -procedure Save; -var I: screenIndex; -J: integer; -begin - HighVideo; - Msg('Save: Enter filename '); - GetFileName(Filename,'MCS'); - if FileName<>'' then - begin - Assign(MCFile,FileName); - Rewrite(MCFile); - for I:='A' to FXmax do - begin - for J:=1 to FYmax do - write(MCfile,Screen[I,J]); - end; - Grid; - Close(MCFile); - LowVideo; - GotoCell(FX,FY); - end; -end; - -{.CP30} - -procedure Load; -begin - HighVideo; - Msg('Load: Enter filename '); - GetFileName(Filename,'MCS'); - if (Filename<>'') then if (not exist(FileName)) then - repeat - Msg('File not Found: Enter another filename '); - GetFileName(Filename,'MCS'); - until exist(FileName) or (FileName=''); - if FileName<>'' then - begin - ClrScr; - Msg('Please Wait. Loading definition...'); - Assign(MCFile,FileName); - Reset(MCFile); - for FX:='A' to FXmax do - for FY:=1 to FYmax do read(MCFile,Screen[FX,FY]); - FX:='A'; FY:=1; - LowVideo; - UpDate; - end; - GotoCell(FX,FY); -end; - - -{.PA} - -procedure Print; -var - I: screenIndex; - J,Count, - LeftMargin: Integer; - P: string[20]; - MCFile: Text; -begin - HighVideo; - Msg('Print: Enter filename "P" for Printer> '); - GetFileName(Filename,'LST'); - Msg('Left margin > '); Read(LeftMargin); - if FileName='P.LST' then FileName:='Printer'; - Msg('Printing to: ' + FileName + '....'); - Assign(MCFile,FileName); - Rewrite(MCFile); - For Count:=1 to 5 do Writeln(MCFile); - for J:=1 to FYmax do - begin - Line:=''; - for I:='A' to FXmax do - begin - with Screen[I,J] do - begin - while (Length(Line)0 then Str(Value:FW:DEC,P) else Str(Value:FW,P); - Line:=Line+P; - end; - end else Line:=Line+Contents; - end; { With } - end; { One line } - For Count:=1 to LeftMargin do Write(MCFile,' '); - writeln(MCFile,Line); - end; { End Column } - Grid; - Close(MCFile); - LowVideo; - GotoCell(FX,FY); -end; - -{.PA} - -procedure Help; -var - H: text; - HelpFileName: string[14]; - Line: string[80]; - I,J: integer; - Bold: boolean; - -begin - if Exist('MC.HLP') then - begin - Assign(H,'MC.HLP'); - Reset(H); - while not Eof(H) do - begin - Readln(H,Line); - ClrScr; I:=1; Bold:=false; LowVideo; - repeat - For J:=1 to Length(Line) do - begin - if Line[J]=^B then - begin - Bold:=not Bold; - if Bold then HighVideo else LowVideo; - end else write(Line[J]); - end; - Writeln; - I:=I+1; - Readln(H,Line); - until Eof(H) or (I>23) or (Copy(Line,1,3)='.PA'); - GotoXY(26,24); HighVideo; - write('<<< Please press any key to continue >>>'); - LowVideo; - read(Kbd,Ch); - end; - GotoXY(20,24); HighVideo; - write('<<< Please press to start MicroCalc >>>'); - LowVideo; - Readln(Ch); - UpDate; - end else { Help file did not exist } - begin - Msg('To get help the file MC.HLP must be on your disk. Press '); - repeat Read(kbd,Ch) until Ch=^M; - GotoCell(FX,FY); - end; -end; - -toCell(FX,FY); - end; -end; - - \ No newline at end of file diff --git a/software/CPM/CPM26_TPASCAL_v300a/mc-mod04.inc b/software/CPM/CPM26_TPASCAL_v300a/mc-mod04.inc deleted file mode 100644 index f3cd95c..0000000 --- a/software/CPM/CPM26_TPASCAL_v300a/mc-mod04.inc +++ /dev/null @@ -1,294 +0,0 @@ -{.PA} -{*******************************************************************} -{* SOURCE CODE MODULE: MC-MOD04 *} -{* PURPOSE: Evaluate formulas. *} -{* Recalculate spread sheet. *} -{* *} -{* NOTE: This module contains recursive procedures *} -{* and is for computer scientists only. *} -{*******************************************************************} - -var - Form: Boolean; - -{$A-} -procedure Evaluate(var IsFormula: Boolean; { True if formula} - var Formula: AnyString; { Fomula to evaluate} - var Value: Real; { Result of formula } - var ErrPos: Integer);{ Position of error } -const - Numbers: set of Char = ['0'..'9']; - EofLine = ^M; - -var - Pos: Integer; { Current position in formula } - Ch: Char; { Current character being scanned } - EXY: string[3]; { Intermidiate string for conversion } - -{ Procedure NextCh returns the next character in the formula } -{ The variable Pos contains the position ann Ch the character } - - procedure NextCh; - begin - repeat - Pos:=Pos+1; - if Pos<=Length(Formula) then - Ch:=Formula[Pos] else Ch:=eofline; - until Ch<>' '; - end { NextCh }; - - - function Expression: Real; - var - E: Real; - Opr: Char; - - function SimpleExpression: Real; - var - S: Real; - Opr: Char; - - function Term: Real; - var - T: Real; - - function SignedFactor: Real; - - function Factor: Real; - type - StandardFunction = (fabs,fsqrt,fsqr,fsin,fcos, - farctan,fln,flog,fexp,ffact); - StandardFunctionList = array[StandardFunction] of string[6]; - - const - StandardFunctionNames: StandardFunctionList =('ABS','SQRT','SQR','SIN','COS', - 'ARCTAN','LN','LOG','EXP','FACT'); - var - E,EE,L: Integer; { intermidiate variables } - Found:Boolean; - F: Real; - Sf:StandardFunction; - OldEFY, { Current cell } - EFY, - SumFY, - Start:Integer; - OldEFX, - EFX, - SumFX:ScreenIndex; - CellSum: Real; - - function Fact(I: Integer): Real; - begin - if I > 0 then begin Fact:=I*Fact(I-1); end - else Fact:=1; - end { Fact }; - -{.PA} - begin { Function Factor } - if Ch in Numbers then - begin - Start:=Pos; - repeat NextCh until not (Ch in Numbers); - if Ch='.' then repeat NextCh until not (Ch in Numbers); - if Ch='E' then - begin - NextCh; - repeat NextCh until not (Ch in Numbers); - end; - Val(Copy(Formula,Start,Pos-Start),F,ErrPos); - end else - if Ch='(' then - begin - NextCh; - F:=Expression; - if Ch=')' then NextCh else ErrPos:=Pos; - end else - if Ch in ['A'..'G'] then { Maybe a cell reference } - begin - EFX:=Ch; - NextCh; - if Ch in Numbers then - begin - F:=0; - EXY:=Ch; NextCh; - if Ch in Numbers then - begin - EXY:=EXY+Ch; - NextCh; - end; - Val(EXY,EFY,ErrPos); - IsFormula:=true; - if (Constant in Screen[EFX,EFY].CellStatus) and - not (Calculated in Screen[EFX,EFY].CellStatus) then - begin - Evaluate(Form,screen[EFX,EFY].contents,f,ErrPos); - Screen[EFX,EFY].CellStatus:=Screen[EFX,EFY].CellStatus+[Calculated] - end else if not (Txt in Screen[EFX,EFY].CellStatus) then - F:=Screen[EFX,EFY].Value; - if Ch='>' then - begin - OldEFX:=EFX; OldEFY:=EFY; - NextCh; - EFX:=Ch; - NextCh; - if Ch in Numbers then - begin - EXY:=Ch; - NextCh; - if Ch in Numbers then - begin - EXY:=EXY+Ch; - NextCh; - end; - val(EXY,EFY,ErrPos); - Cellsum:=0; - for SumFY:=OldEFY to EFY do - begin - for SumFX:=OldEFX to EFX do - begin - F:=0; - if (Constant in Screen[SumFX,SumFY].CellStatus) and - not (Calculated in Screen[SumFX,SumFY].CellStatus) then - begin - Evaluate(Form,Screen[SumFX,SumFY].contents,f,errPos); - Screen[SumFX,SumFY].CellStatus:= - Screen[SumFX,SumFY].CellStatus+[Calculated]; - end else if not (Txt in Screen[SumFX,SumFY].CellStatus) then - F:=ScrEEn[SumFX,SumFY].Value; - Cellsum:=Cellsum+f; - f:=Cellsum; - end; - end; - end; - end; - end; - end else - begin - found:=false; - for sf:=fabs to ffact do - if not found then - begin - l:=Length(StandardFunctionNames[sf]); - if copy(Formula,Pos,l)=StandardFunctionNames[sf] then - begin - Pos:=Pos+l-1; NextCh; - F:=Factor; - case sf of - fabs: f:=abs(f); - fsqrt: f:=sqrt(f); - fsqr: f:=sqr(f); - fsin: f:=sin(f); - fcos: f:=cos(f); - farctan: f:=arctan(f); - fln : f:=ln(f); - flog: f:=ln(f)/ln(10); - fexp: f:=exp(f); - ffact: f:=fact(trunc(f)); - end; - Found:=true; - end; - end; - if not Found then ErrPos:=Pos; - end; - Factor:=F; - end { function Factor}; -{.PA} - - begin { SignedFactor } - if Ch='-' then - begin - NextCh; SignedFactor:=-Factor; - end else SignedFactor:=Factor; - end { SignedFactor }; - - begin { Term } - T:=SignedFactor; - while Ch='^' do - begin - NextCh; t:=exp(ln(t)*SignedFactor); - end; - Term:=t; - end { Term }; - - - begin { SimpleExpression } - s:=term; - while Ch in ['*','/'] do - begin - Opr:=Ch; NextCh; - case Opr of - '*': s:=s*term; - '/': s:=s/term; - end; - end; - SimpleExpression:=s; - end { SimpleExpression }; - - begin { Expression } - E:=SimpleExpression; - while Ch in ['+','-'] do - begin - Opr:=Ch; NextCh; - case Opr of - '+': e:=e+SimpleExpression; - '-': e:=e-SimpleExpression; - end; - end; - Expression:=E; - end { Expression }; - - -begin { procedure Evaluate } - if Formula[1]='.' then Formula:='0'+Formula; - if Formula[1]='+' then delete(Formula,1,1); - IsFormula:=false; - Pos:=0; NextCh; - Value:=Expression; - if Ch=EofLine then ErrPos:=0 else ErrPos:=Pos; -end { Evaluate }; - -{.PA} - -procedure Recalculate; -var - RFX: ScreenIndex; - RFY:integer; - OldValue: real; - Err: integer; - -begin - LowVideo; - GotoXY(1,24); ClrEol; - Write('Calculating..'); - for RFY:=1 to FYMax do - begin - for RFX:='A' to FXMax do - begin - with Screen[RFX,RFY] do - begin - if (Formula in CellStatus) then - begin - CellStatus:=CellStatus+[Calculated]; - OldValue:=Value; - Evaluate(Form,Contents,Value,Err); - if OldValue<>Value then - begin - GotoXY(XPos[RFX],RFY+1); - if (DEC>=0) then Write(Value:FW:DEC) - else Write(Value:FW); - end; - end; - end; - end; - end; - GotoCell(FX,FY); -end; -FW); - end; - end; - end; - end; - end; - GotoCell(FX,FY); -end; - \ No newline at end of file diff --git a/software/CPM/CPM26_TPASCAL_v300a/mc-mod05.inc b/software/CPM/CPM26_TPASCAL_v300a/mc-mod05.inc deleted file mode 100644 index 8f838ee..0000000 --- a/software/CPM/CPM26_TPASCAL_v300a/mc-mod05.inc +++ /dev/null @@ -1,394 +0,0 @@ -{.PA} -{*******************************************************************} -{* SOURCE CODE MODULE: MC-MOD05 *} -{* PURPOSE: Read the contents of a cell and update *} -{* associated cells. *} -{*******************************************************************} - - -{ Procedure GetLine will let the user type and/or edit a string of } -{ maximum length "MAX". The string will start at cursor position: } -{ ColNO,LineNO. If ErrPos <> 0 then the cursor will jump to position } -{ ErrPos in the string. If the last parameter is "True" then all } -{ characters entered will be translated to upper case. } -{ If the user at anytimes types then the string returned } -{ contain $FF to indicate that editing was aborted. } - - -procedure GetLine(var S: AnyString; { String to edit } - ColNO,LineNO, { Where start line } - MAX, { Max length } - ErrPos: integer; { Where to begin } - UpperCase:Boolean); { True if auto Upcase } -var - X: integer; - InsertOn: boolean; - OkChars: set of Char; - - - procedure GotoX; - begin - GotoXY(X+ColNo-1,LineNo); - end; - -begin - OkChars:=[' '..'}']; - InsertOn:=true; - X:=1; GotoX; - Write(S); - if Length(S)=1 then X:=2; - if ErrPos<>0 then X:=ErrPos; - GotoX; - repeat - Read(Kbd,Ch); - if UpperCase then Ch:=UpCase(Ch); - case Ch of - ^[: begin - S:=chr($FF); { abort editing } - Ch:=^M; - end; - ^D: begin { Move cursor right } - X:=X+1; - if (X>length(S)+1) or (X>MAX) then X:=X-1; - GotoX; - end; - ^G: begin { Delete right char } - if X<=Length(S) then - begin - Delete(S,X,1); - Write(copy(S,X,Length(S)-X+1),' '); - GotoX; - end; - end; - ^S,^H: begin { Move cursor left } - X:=X-1; - if X<1 then X:=1; - GotoX; - end; - ^F: begin { Move cursor to end of line } - X:=Length(S)+1; - GotoX; - end; - ^A: begin { Move cursor to beginning of line } - X:=1; - GotoX; - end; - #127: begin { Delete left char } - X:=X-1; - if (Length(S)>0) and (X>0) then - begin - Delete(S,X,1); - Write(copy(S,X,Length(S)-X+1),' '); - GotoX; - if X<1 then X:=1; - end else X:=1; - end; - ^V: InsertOn:= not InsertOn; - -{.PA} - - else - begin - if Ch in OkChars then - begin - if InsertOn then - begin - insert(Ch,S,X); - Write(copy(S,X,Length(S)-X+1),' '); - end else - begin - write(Ch); - if X=length(S) then S:=S+Ch - else S[X]:=Ch; - end; - if Length(S)+1<=MAX then X:=X+1 - else OkChars:=[]; { Line too Long } - GotoX; - end else - if Length(S)+1<=Max then - OkChars:= [' '..'}']; { Line ok again } - end; - end; - until CH=^M; -end; - - -{.PA} - - -procedure GetCell(FX: ScreenIndex;FY: Integer); -var - S: AnyString; - NewStat: Set of Attributes; - ErrorPosition: Integer; - I: ScreenIndex; - Result: Real; - Abort: Boolean; - IsForm: Boolean; - -{ Procedure ClearCells clears the current cell and its associated } -{ cells. An associated cell is a cell overwritten by data from the } -{ current cell. The data can be text in which case the cell has the } -{ attribute "OverWritten". If the data is a result from an expression} -{ and the field with is larger tahn 11 then the cell is "Locked" } - - procedure ClearCells; - begin - I:=FX; - repeat - with Screen[I,FY] do - begin - GotoXY(XPos[I],FY+1); - write(' '); I:=Succ(I); - end; - until ([OverWritten,Locked]*Screen[I,FY].CellStatus=[]); - { Cell is not OVerWritten not Locked } - end; - -{.CP20} -{ The new type of the cell is flashed at the bottom of the screen } -{ Notice that a constant of type array is used to indicate the type } - - procedure FlashType; - begin - HighVideo; - GotoXY(5,23); - LowVideo; - end; - -{.CP20} -{ Procedure GetFormula repeats calling the procedure GetLine and } -{ Evaluate until the line read by GetLine contains a valid formula. } -{ Evaluate returns an error position in the string evaluated. If } -{ this position is non zero GetLine is called. If the user types } -{ ESC in GetLine to abort the editing then the string returned from } -{ Getline will contain $FF and te original value of the cell will } -{ be restored later. } - - procedure GetFormula; - begin - FlashType; - repeat - GetLine(S,1,24,70,ErrorPosition,True); - if S<>Chr($FF) then - begin - Evaluate(IsForm,S,Result,ErrorPosition); - if ErrorPosition<>0 then - Flash(15,'Error at cursor'+^G,false) - else Flash(15,' ',false); - end; - until (ErrorPosition=0) or (S=Chr($FF)); - if IsForm then NewStat:=NewStat+[Formula]; - end; - -{.CP20} -{ Procedure GetText calls the procedure GetLine with the current } -{ cells X,Y position as parameters. This means that text entering } -{ takes place direcly at the cells posion on the screen. } - - procedure GetText; - begin - FlashType; - with Screen[FX,FY] do GetLine(S,XPos[FX],FY+1,70,ErrorPosition,False); - end; - -{.CP20} -{ Procedure EditCell loads a copy of the current cells contents in } -{ in the variable S before calling either GetText or GetFormula. In } -{ this way no changes are made to the current cell. } - - procedure EditCell; - begin - with Screen[FX,FY] do - begin - S:=Contents; - if Txt in CellStatus then GetText else GetFormula; - end; - end; - -{.PA} -{ Procedure UpdateCells is a little more complicated. Basically it } -{ makes sure to tag and untag cells which has been overwritten or } -{ cleared from data from another cell. It also updates the current } -{ with the new type and the contents which still is in the temporaly } -{ variable "S". } - - - procedure UpdateCells; - var - Flength: Integer; - begin - Screen[FX,FY].Contents:=S; - if Txt in NewStat {Screen[FX,FY].CellStatus} then - begin - I:=FX; FLength:=Length(S); - repeat - I:=Succ(I); - with Screen[I,FY] do - begin - FLength:=Flength-11; - if (Flength>0) then - begin - CellStatus:=[Overwritten,Txt]; - Contents:=''; - end else - begin - if OverWritten in CellStatus then - begin - CellStatus:=[Txt]; - GotoCell(I,FY);LeaveCell(I,FY); - end; - end; - end; - until (I=FXMax) or (Screen[I,FY].Contents<>''); - Screen[FX,FY].CellStatus:=[Txt]; - end else { string changed to formula or constant } - begin { Event number two } - I:=FX; - repeat - with Screen[I,FY] do - begin - if OverWritten in CellStatus then - begin - CellStatus:=[Txt]; - Contents:=''; - end; - I:=Succ(I); - end; - until not (OverWritten in Screen[I,FY].CellStatus); - with Screen[FX,FY] do - begin - CellStatus:=[Constant]; - if IsForm then CellStatus:=CellStatus+[Formula]; - Value:=Result; - end; - end; - end; - - -{.PA} -{ Procedure GetCell finnaly starts here. This procedure uses all } -{ all the above local procedures. First it initializes the temporaly } -{ variable "S" with the last read character. It then depending on } -{ this character calls GetFormula, GetText, or EditCell. } - -begin { procedure GetCell } - S:=Ch; ErrorPosition:=0; Abort:=false; - NewStat:=[]; - if Ch in ['0'..'9','+','-','.','(',')'] then - begin - NewStat:=[Constant]; - if not (Formula in Screen[FX,FY].CellStatus) then - begin - GotoXY(11,24); ClrEol; - ClearCells; - GetFormula; - end else - begin - Flash(15,'Edit formula Y/N?',true); - repeat read(Kbd,Ch) until UpCase(CH) in ['Y','N']; - Flash(15,' ',false); - if UpCase(Ch)='Y' then EditCell Else Abort:=true; - end; - end else - begin - if Ch=^[ then - begin - NewStat:=(Screen[FX,FY].CellStatus)*[Txt,Constant]; - EditCell; - end else - begin - if formula in Screen[FX,FY].CellStatus then - begin - Flash(15,'Edit formula Y/N?',true); - repeat read(Kbd,Ch) until UpCase(CH) in ['Y','N']; - Flash(15,' ',false); - if UpCase(Ch)='Y' then EditCell Else Abort:=true; - end else - begin - NewStat:=[Txt]; - ClearCells; - GetText; - end; - end; - end; - if not Abort then - begin - if S<>Chr($FF) then UpDateCells; - GotoCell(FX,FY); - if AutoCalc and (Constant in Screen[FX,FY].CellStatus) then Recalculate; - if Txt in NewStat then - begin - GotoXY(3,FY+1); Clreol; - For I:='A' to FXMax do - LeaveCell(I,FY); - end; - end; - Flash(15,' ',False); - GotoCell(FX,FY); -end; - -{.PA} -{ Procedure Format is used to } - - -procedure Format; -var - J,FW,DEC, - FromLine,ToLine: integer; - Lock: Boolean; - - - procedure GetInt(var I: integer; Max: Integer); - var - S: string[8]; - Err: Integer; - Ch: Char; - begin - S:=''; - repeat - repeat Read(Kbd,Ch) until Ch in ['0'..'9','-',^M]; - if Ch<>^M then - begin - Write(Ch); S:=S+Ch; - Val(S,I,Err); - end; - until (I>=Max) or (Ch=^M); - if I>Max then I:=Max; - end; - -begin - HighVideo; - Msg('Format: Enter number of decimals (Max 11): '); - GetInt(DEC,11); - Msg('Enter Cell whith remember if larger than 10 next column will lock: '); - GetInt(FW,20); - Msg('From which line in column '+FX+': '); - GetInt(FromLine,FYMax); - Msg('To which line in column '+FX+': '); - GetInt(ToLine,FYMax); - if FW>10 then Lock:=true else Lock:=False; - for J:=FromLine to ToLine do - begin - Screen[FX,J].DEC:=DEC; - Screen[FX,J].FW:=FW; - with Screen[Succ(FX),J] do - begin - if Lock then - begin - CellStatus:=CellStatus+[Locked,Txt]; - Contents:=''; - end else CellStatus:=CellStatus-[Locked]; - end; - end; - NormVideo; - UpDate; - GotoCell(FX,FY); -end; - -Video; - UpDate; - GotoCell(FX,FY); -end; - - \ No newline at end of file diff --git a/software/CPM/CPM26_TPASCAL_v300a/mc.hlp b/software/CPM/CPM26_TPASCAL_v300a/mc.hlp deleted file mode 100644 index 2048b3a..0000000 --- a/software/CPM/CPM26_TPASCAL_v300a/mc.hlp +++ /dev/null @@ -1,145 +0,0 @@ - INTRODUCTION - -MicroCalc is a tiny spread sheet program a la VisiCalc. It is -provided with the TURBO-Pascal system as an example program. - -Since MicroCalc is only a demonstation program it has its limita- -tions (which you may have fun eliminating): - - * You cannot copy formulas from one cell to others. - * You cannot insert and delete lines or columns. - -In spite of its limitations MicroCalc does provide some interest- -ing features among which are: - - * 11 digits floating point reals (Thanks to TURBO Pascal!) - * Full set of mathematical functions (SIN,COS,LN,EXP etc.) - * Built in line editor for text and formula editing. - * Text can be entered across cells. - * Once entered a formula is protected from accidental erasure. -.PA - - -In addition to this MicroCalc offers all the usual features of a -spread sheet program: - - - * Load a spread sheet from the disk. - * Save a spread sheet on the disk. - * Automatic recalculation after each entry. (May be disabled). - * Print the spread sheet on the printer. - * Clear the current spread sheet. - -The spread sheet is an electronic piece of paper on which you can -enter text, numbers and formulas and have MicroCalc do calcula- -tions automatically. - -The next page shows the electronic spread sheet. -.PA ----------------------------------------------------------------- - A B C D .... - 1 22.00 - 2 1.00 - 3 2.00 - 4 3.00 - 5 28.00 - . - . -A 5 Formula: -(A1+A2+A3+A4+A5) ------------------------------------------------------------------ - -In the example the next last line shows that the active cell is -cell A5 and that A5 contains a formula: (A1+A2+A3+A4) which -means that the numbers in A1,A2,A3 and A4 should be added and -placed in A5. - -The formula can be abbreviated to: (A1>A4) meaning: add all cells -from A1 to A4. -.PA - -You move the cursor around just like you do in the TURBO editor: - - (Up) - Ctrl-E - (Left) Ctrl-S Ctrl-G (Right) - Ctrl-X - (Down) - -A cell may contain a number, a formula or some text. The type of of the cell -and its coordinates are shown in the bottom left corner of the screen: - -A 5 Formula: (Means that the current cell is A5 and that it - contains a formula) - -A 1 Text (Cell A1 contains text) - -A 2 Numeric (Cell A2 contains a number and no cell references) - -.PA - Summary of MicroCalc - Cells are denoted A1 through G21 giving a total of 147 cells. - -Summary of standard functions and operators: -SIN, COS, ARCT, ABS, FACT, EXP, LN, +,-,/,* -Futhermore the operator '>' can be used to denote a range of cells to add. - -Entering data -To enter data in any field move the cursor to the cell and enter the -data. MicroCalc automatically determines if the field is numeric or a -a text field. - - -When moving between fields: -^S,^D,^E,^X move left right up and down. - -When editing a field -^S,^D moves left and right. ^A,^F moves to beginning/end of line. -DEL,^G deletes left or right character. -ESC makes it possible to regret changes and to edit an existing cell. -.PA - - - Summary of commands - - - / will restore the screen - Q will Quit MicroCalc - L will Load a spread sheet from the disk. - S will Save a spread sheet on the disk. - R will Recalculate - P will Print the spread sheet. - F makes it possible to change the output format for numbers. - A switches Autocalc ON and OFF - -Note: to use scientific notation use the the F command and enter minus one - -1 for the number of decimals. - -.PA - - EXAMPLES - -The following are examples of valid cell formulas: - -A1+(B2-C7) subtract cell C7 from B2 and add the result to cell A1 -(A1>A23) the sum of cells: A1,A2,A3..A23 -(A1>B5) the sum of cells: A1..A5 and B1..B5 - -The formulas may be as complicated as you want:  - -SIN(A1)*COS(A2)/((1.2*A8)+LN(FACT(A8)+8.9E-3))+(C1>C5) - -To edit an existing formula or text simply move to the cell and -press ESC, make your changes and press . If you make -a mistake you may press ESC again, the old value of the cell will -then be restored. - -To try MicroCalc now you may use the /L command and load the file: -CALCDEMO. - - - try MicroCalc now you may use the /L command and load the file: -CALCDEMO. - - - \ No newline at end of file diff --git a/software/CPM/CPM26_TPASCAL_v300a/mc.pas b/software/CPM/CPM26_TPASCAL_v300a/mc.pas deleted file mode 100644 index 445ecdb..0000000 --- a/software/CPM/CPM26_TPASCAL_v300a/mc.pas +++ /dev/null @@ -1,160 +0,0 @@ -program MicroCalc; -{ - MICROCALC DEMONSTRATION PROGRAM Version 1.00A - - This program is Copyrighted by Borland International, Inc. - 1983, 1984, 1985 and is hereby donated to the public domain for - non-commercial use only. Dot commands are for the program - lister: LISTT.PAS (available with our TURBO TUTOR): - - .PA, .CP20, etc... - - INSTRUCTIONS - 1. Compile this program using the TURBO.COM compiler. - a. Use the O command from the main menu to select Options. - b. Select the C option to generate a .COM file. - c. Select the Q option to Quit the Options menu. - d. Select the M option to specify the Main file - e. Type "MC" and hit - f. Type C to compile the program to disk - g. Type R to run the program - - 2. Exit the program by typing: /Q -} - -{$R-,U-,V-,X-,A+,C-} - - -const - FXMax: Char = 'G'; { Maximum number of columns } - FYMax = 21; { Maximum number of lines } - -type - Anystring = string[255]; - ScreenIndex = 'A'..'G'; - Attributes = (Constant,Formula,Txt,OverWritten,Locked,Calculated); - -{ The spreadsheet is made out of Cells every Cell is defined as } -{ the following record: } - - CellRec = record - CellStatus: set of Attributes; { Status of cell (see type def.) } - Contents: String[70]; { Contains a formula or some text } - Value: Real; { Last calculated cell value } - DEC,FW: 0..20; { Decimals and Cell Whith } - end; - - Cells = array[ScreenIndex,1..FYMax] of CellRec; - -const - XPOS: array[ScreenIndex] of integer = (3,14,25,36,47,58,68); - -var - Screen: Cells; { Definition of the spread sheet } - FX: ScreenIndex; { Culumn of current cell } - FY: Integer; { Line of current cell } - Ch: Char; { Last read character } - MCFile: file of CellRec; { File to store sheets in } - AutoCalc: boolean; { Recalculate after each entry? } - - -{ The following include files contain procedures used in MicroCalc. } -{ In the following source code there is a reference after each } -{ procedure call indicating in which module the procedure is located.} - -{ If you want a printer listing of the following modules then you } -{ must let the include directives start in column one and then use } -{ the TLIST program to generate a listing. } - - {$I MC-MOD00.INC Miscelaneous procedures } - {$I MC-MOD01.INC Initialization procedures } - {$I MC-MOD02.INC Commands to move between fields } - {$I MC-MOD03.INC Commands to Load,Save,Print } - {$I MC-MOD04.INC Evaluating an expression in a cell } - {$I MC-MOD05.INC Reading a cell definition and Format command} - - -{.PA} -{*********************************************************************} -{* START OF MAIN PROGRAM PROCEDURES *} -{*********************************************************************} - - -{ Procedure Commands is activated from the main loop in this program } -{ when the user type a semicolon. Commands then activates a procedure} -{ which will execute the command. These procedures are located in the} -{ above modules. } -{ For easy reference the source code module number is shown in a } -{ comment on the right following the procedure call. } - -procedure Commands; -begin - GotoXY(1,24); - HighVideo; - Write('/ restore, Quit, Load, Save, Recalculate, Print, Format, AutoCalc, Help '); - Read(Kbd,Ch); - Ch:=UpCase(Ch); - case Ch of { In module } - 'Q': Halt; - 'F': Format; { 04 } - 'S': Save; { 03 } - 'L': Load; { 03 } - 'H': Help; { 03 } - 'R': Recalculate; { 05 } - 'A': Auto; { 00 } - '/': Update; { 01 } - 'C': Clear; { 01 } - 'P': Print; { 03 } - end; - Grid; { 01 } - GotoCell(FX,FY); { 02 } -end; - -{ Procedure Hello says hello and activates the help procedure if the } -{ user presses anything but Return } - -procedure Wellcome; - - procedure Center(S: AnyString); - var I: integer; - begin - for I:=1 to (80-Length(S)) div 2 do Write(' '); - writeln(S); - end; - -begin { procedure Wellcome } - ClrScr; GotoXY(1,9); - Center('Welcome to MicroCalc. A Turbo demonstation program'); - Center('Copyright 1983 by Borland International Inc. '); - Center('Press any key for help or to start'); - GotoXY(40,12); - Read(Kbd,Ch); - if Ch<>^M then Help; -end; - -{.PA} -{*********************************************************************} -{* THIS IS WHERE THE PROGRAM STARTS EXECUTING *} -{*********************************************************************} - -begin - Init; { 01 } - Wellcome; - ClrScr; Grid; { 01 } - GotoCell(FX,FY); - repeat - Read(Kbd,Ch); - case Ch of - ^E: MoveUp; { 02 } - ^X,^J: MoveDown; { 02 } - ^D,^M,^F: MoveRight; { 02 } - ^S,^A: MoveLeft; { 02 } - '/': Commands; - ^[: GetCell(FX,FY); { 04 } - else - if Ch in [' '..'~'] then - GetCell(FX,FY); { 04 } - end; - until true=false; { (program stops in procedure Commands) } -end. - \ No newline at end of file diff --git a/software/CPM/CPM26_TPASCAL_v300a/mcdemo.mcs b/software/CPM/CPM26_TPASCAL_v300a/mcdemo.mcs deleted file mode 100644 index a197eb9..0000000 Binary files a/software/CPM/CPM26_TPASCAL_v300a/mcdemo.mcs and /dev/null differ diff --git a/software/CPM/CPM26_TPASCAL_v300a/read.me b/software/CPM/CPM26_TPASCAL_v300a/read.me deleted file mode 100644 index 4310c95..0000000 --- a/software/CPM/CPM26_TPASCAL_v300a/read.me +++ /dev/null @@ -1,184 +0,0 @@ - - Welcome to TURBO PASCAL Version 3.0! - ------------------------------------ - - In spite of all efforts, some errors have found their way into - the new TURBO 3.0 manual. This file contains all the necessary - corrections and additions, and we apologize for any inconvenience - this may cause you. - - Please make a working copy of your TURBO disk and store the ori- - ginal in a safe place. For help making a backup copy, please - refer to appendix M of the TURBO PASCAL Reference Manual. - - Now, using your working copy, run TINST to install TURBO.COM for - your terminal. Installation procedures are discussed in Chapter - One and Appendix L. - - - ******************************************* - * * - * Need help with TURBO? Please see * - * Appendix N in your Reference Manual * - * for answers to common questions. * - * * - ******************************************* - - - ------------------- - - - Contents of the READ.ME File - ---------------------------- - 1. CORRECTIONS to the 3.0 Reference Manual [ All versions ] - 2. OMMISSIONS from the 3.0 Reference Manual [ All versions ] - 3. New FEATURES [ CP/M-80 ] - 4. ADDITIONAL FILE LIST [ CP/M-80 ] - - - ------------------- - - - CORRECTIONS - ----------- - - -Page 253 - MOV AL,[BP-1] ------------------------- - The correct statement is: MOV AL,[BP+4] - - -Page 293 - TURBO-BCD will compile and run any program ------------------------------------------------------ - Well - almost. The Real functions Sin, Cos, ArcTan, Ln, Exp, - and Sqrt and the pre-declared constant Pi are not available - in TURBOBCD. - - - ------------------- - - - OMISSIONS - --------- - - -User Written Error Handlers ---------------------------- - In Turbo Pascal 3.0 you may write your own error handler, - which is called in case of an I/O or Run-time error. The - procedure must have the following header: - - procedure Error(ErrNo, ErrAddr: Integer); - - The name of the procedure and its parameters are unim- - portant, as long as it is a procedure with two value - parameters of type Integer. - - The value passed in ErrNo is the error type and number. The - most significant byte, i.e. "Hi(ErrNo)", contains the error - type, and the least significant byte, i.e. "Lo(ErrNo)", - contains the error number (see Appendix F or G in the Turbo - Pascal Manual). - - The following error types are defined: - - 0 User Break (Ctrl-C). - 1 I/O error. - 2 Run-time error. - - In case of a user interrupt (Ctrl-C), the low byte of - "ErrNo" is always 1. "ErrAddr" contains the address (offset - in Code Segment for 16 bit versions) of the error. - - To activate the error handler, assign its offset address - to the standard variable "ErrorPtr", i.e. - - ErrorPtr:=Ofs(Error); { 16 bit } or - ErrorPtr:=Addr(Error); { 8 bit } - - There are no limits to what an error handler may do. Typi- - cally it will close all open files, output an error mes- - sage, and call the Halt standard procedure to terminate the - program. If an error handler returns, i.e. if it does - not call Halt, or if an error occurs within an error - handler, Turbo Pascal will itself output the error message - and terminate the program. - - - - - ------------------- - - - NEW FEATURES OF CP/M-80 IMPLEMENTATION OF - TURBO 3.0 - - AN OVERVIEW - - ----------------------------------------- - -Inline ------- - A constant identifier used in an INLINE statement does not - always generate two bytes of code. - -Files ------ - New FIB formats. - Optional 4th parameter on Blockread/Write returns number of - blocks actually read. - SeekEoln function. - SeekEof function. - - -Misc. ------ - Exit procedure - To exit the current block - OvrDrive procedure - To specify the drive on which to find overlays - ParamCount function - Gives number of characters in the command buffer - ParamStr function - Gives the string of characters in the command line - -Overlays --------- - - Overlay files are opened and closed every time they are - accessed. Therefore, there is never a need to specifically - close an overlay file. - - The Y compiler directive is no longer supported. Instead, - the OvrPath (MS-DOS) or OvrDrive (CP/M) standard proce- - dures may be used to specify the drive and subdirectory - in which overlay files reside. - - Please note that run-time error F0 indicates that your over- - lay file is missing or is called recursively. (This error - number is omitted from the Reference Manual but is included - elsewhere in this file.) - - - ------------------- - - TURBO PASCAL Version 3.0 - CP/M-80 - Additional File List - - In addition to the list of files mentioned in Chapter 1 of - your TURBO Reference Manual, the following files are included - on your TURBO disk: - - Sample programs - --------------- - LISTER PAS - simple program to list your Pascal source - CMDLIN PAS - get parameters from the command line - - MC PAS - sample spreadsheet program - MAIN MODULE - MC-MOD00 INC - sample spreadsheet program - INCLUDE MODULE 00 - MC-MOD01 INC - sample spreadsheet program - INCLUDE MODULE 01 - MC-MOD02 INC - sample spreadsheet program - INCLUDE MODULE 02 - MC-MOD03 INC - sample spreadsheet program - INCLUDE MODULE 03 - MC-MOD04 INC - sample spreadsheet program - INCLUDE MODULE 04 - MC-MOD05 INC - sample spreadsheet program - INCLUDE MODULE 05 - MC HLP - spreadsheet help file - MCDEMO MCS - spreadsheet data file (not for use with TURBO-87) - - --------------------------------------------------------------------- - - \ No newline at end of file diff --git a/software/CPM/CPM26_TPASCAL_v300a/tinst.com b/software/CPM/CPM26_TPASCAL_v300a/tinst.com deleted file mode 100644 index f730496..0000000 Binary files a/software/CPM/CPM26_TPASCAL_v300a/tinst.com and /dev/null differ diff --git a/software/CPM/CPM26_TPASCAL_v300a/tinst.dta b/software/CPM/CPM26_TPASCAL_v300a/tinst.dta deleted file mode 100644 index b933622..0000000 Binary files a/software/CPM/CPM26_TPASCAL_v300a/tinst.dta and /dev/null differ diff --git a/software/CPM/CPM26_TPASCAL_v300a/tinst.msg b/software/CPM/CPM26_TPASCAL_v300a/tinst.msg deleted file mode 100644 index cc25774..0000000 --- a/software/CPM/CPM26_TPASCAL_v300a/tinst.msg +++ /dev/null @@ -1,123 +0,0 @@ -1 TURBO Pascal installation menu. -2 Choose installation item from the following: -3 -4 [S]creen installation | [C]ommand installation | [Q]uit -5 -6 Enter S, C, or Q: -10 Duplicate definition. Error occurred between question -11 Commands starting with the same letter must have the same length. - Error occurred between question -12 The total maximum length of commands are execeeded -13 -> - - -14 CURSOR MOVEMENTS: - -20 Character left -21 Alternative -22 Character right -23 Word left -24 Word right -25 Line up -26 Line down -27 Scroll down -28 Scroll up -29 Page up -30 Page down -31 To left on line -32 To right on line -33 To top of page -34 To bottom of page -35 To top of file -36 To end of file -37 To begining of block -38 To end of block -39 To last cursor position - - -15 INSERT & DELETE: - -40 Insert mode on/off -41 Insert line -42 Delete line -43 Delete to end of line -44 Delete right word -45 Delete character under cursor -46 Delete left character -47 Alternative - - -16 BLOCK COMMANDS: - -48 Mark block begin -49 Mark block end -50 Mark single word -51 Hide/display block -52 Copy block -53 Move block -54 Delete block -55 Read block from disk -56 Write block to disk - - -17 MISC. EDITING COMMANDS: - -57 End edit -58 Tab -59 Auto tab on/off -60 Restore line -61 Find -62 Find & replace -63 Repeat last find -64 Control character prefix - -101 Nothing - ^Q: Quit, ^R: Last page, ^C: Next page, : Select terminal: - Wait Sorting Definitions - Change to: - (Y/N)? - y - n - Text file name: - Command: - Numeric entry expected - Legal range is - , please re-enter: - Choose one of the following terminals: - None of the above ( Max. 20 Characters ) - Delete a definition ( Max. 20 Characters ) - Which terminal? (Enter no. or ^Q to exit): - Delete terminal? (Enter no. or ^Q to exit): - Do you want to modify this definition before installation? - Terminal type: - Send an initialization string to the terminal? - Initializaion defined as a command string? (No = a file) - Send a reset string to the terminal - Reset defined as a command? (No = a file) - CURSOR LEAD-IN command: - CURSOR POSITIONING COMMAND to send between line and column: - CURSOR POSITIONING COMMAND to send after both line and column: - Column first - OFFSET to add to LINE: - OFFSET to add to COLUMN: - Binary address - Number of ASCII digits (2 or 3): - CLEAR SCREEN command: - Does CLEAR SCREEN also HOME cursor - HOME command: - DELETE LINE command: - INSERT LINE command: - ERASE TO END OF LINE command: - START HIGHLIGHTING command: - END HIGHLIGHTING command: - Number of rows (lines) on your screen: - Number of columns on your screen: - Delay after CURSOR ADDRESS (0-255 ms): - Delay after CLEAR, DELETE and INSERT (0-255 ms): - Delay after ERASE TO END OF LINE and HIGHLIGHT (0-255 ms): - Is this definition correct? - Hardware dependent information - Operating frequency of your microprocessor in MHz (for delays): -pendent information - Operating frequency of your microprocessor in MHz (for delays): - \ No newline at end of file diff --git a/software/CPM/CPM26_TPASCAL_v300a/turbo.com b/software/CPM/CPM26_TPASCAL_v300a/turbo.com deleted file mode 100644 index 892b18c..0000000 Binary files a/software/CPM/CPM26_TPASCAL_v300a/turbo.com and /dev/null differ diff --git a/software/CPM/CPM26_TPASCAL_v300a/turbo.msg b/software/CPM/CPM26_TPASCAL_v300a/turbo.msg deleted file mode 100644 index 701b32b..0000000 --- a/software/CPM/CPM26_TPASCAL_v300a/turbo.msg +++ /dev/null @@ -1,101 +0,0 @@ - are not allowed - can not be - constant - does not - expression - identifier - file - here - Integer - File -Illegal - or -Undefined - match - real -String -Textfile - out of range - variable - overflow - expected - type -Invalid - pointer -01';' -02':' -03',' -04'(' -05')' -06'=' -07':=' -08'[' -09']' -10'.' -11'..' -12BEGIN -13DO -14END -15OF -17THEN -18TO DOWNTO -20Boolean -21  -22  -23  -24  -25  -26  -27  -28Pointer -29Record -30Simple -31Simple -32 -33 -34 -35 -36Type -37Untyped -40 label -41Unknown syntax error -42 in preceding definitions -43Duplicate label -44Type mismatch -45 -46 and CASE selector -47Operand(s) operator -48 result -49  length -50 length -51 subrange base -52Lower bound > upper bound -53Reserved word -54 assignment -55 exceeds line -56Error in integer -57Error in -58 character in -60s -61 s ands -62Structureds -63s -64s and untypeds -65Untypeds -66I/O -67 s must be parameters -68 componentss -69dering of fields -70Set base -71 GOTO -72Label not within current block -73 FORWARD procedure(s) -74INLINE error -75 use of ABSOLUTE -90 not found -91Unexpected end of source -97Too many nested WITH's -98Memory -99Compilerd WITH's -98Memory -99Compiler \ No newline at end of file diff --git a/software/CPM/CPM26_TPASCAL_v300a/turbo.ovr b/software/CPM/CPM26_TPASCAL_v300a/turbo.ovr deleted file mode 100644 index bd9292e..0000000 Binary files a/software/CPM/CPM26_TPASCAL_v300a/turbo.ovr and /dev/null differ diff --git a/software/CPM/CPM27_WORDSTAR_v30/INSTALL.COM b/software/CPM/CPM27_WORDSTAR_v30/INSTALL.COM deleted file mode 100644 index e21b8bf..0000000 Binary files a/software/CPM/CPM27_WORDSTAR_v30/INSTALL.COM and /dev/null differ diff --git a/software/CPM/CPM27_WORDSTAR_v30/MAILMRGE.OVR b/software/CPM/CPM27_WORDSTAR_v30/MAILMRGE.OVR deleted file mode 100644 index 2089e62..0000000 Binary files a/software/CPM/CPM27_WORDSTAR_v30/MAILMRGE.OVR and /dev/null differ diff --git a/software/CPM/CPM27_WORDSTAR_v30/MERGPRIN.OVR b/software/CPM/CPM27_WORDSTAR_v30/MERGPRIN.OVR deleted file mode 100644 index 5826d6e..0000000 Binary files a/software/CPM/CPM27_WORDSTAR_v30/MERGPRIN.OVR and /dev/null differ diff --git a/software/CPM/CPM27_WORDSTAR_v30/READ.ME b/software/CPM/CPM27_WORDSTAR_v30/READ.ME deleted file mode 100644 index c8d9003..0000000 --- a/software/CPM/CPM27_WORDSTAR_v30/READ.ME +++ /dev/null @@ -1,88 +0,0 @@ -CP/M WordStar patch for VT100 up to 5 colors. - -Features : -WordStar patch for ANSI/vt100 terminals like Linux Console or X11 xterm. -Works with CP/M 2.2 (or MP/M) with fixed height and fixed width at offset 232h and 233h (default values are actually 24x80). -Get console height and width dynamically from SCB Bdos #49 (for use with CP/M Plus). -Could do the same with CP/M 2.2 (or MP/M) as CP/M Plus if SCB Bdos #49 return non-0 values for height and width. -Support for up to 120 lines of 250 columns (e.g. 43 or 44 lines of 132 columns CRT mode) with limitations. - -Send sequence codes to delete and insert line on screen. -Orange (customizable at offset 33Dh) background color instead of simple reverse video (only with color compatible vt100 terminals). -Bright status line (number one) instead of reverse video. -Blue (customizable at offset 31Ch) foreground color for latest flags column (only with color compatible vt100 terminals). -Up to five colors (white/orange/black/bright/blue). -Bright and reverse video only with non-color vt100 terminals. - -Works with Zilog Z80 or Intel 8080/8085. No use of Z80 specific op-codes. -Fit in exact amount of bytes for patches. No extra memory needed. -Works with WS 3.3 pre-patched with WINSTALL.COM - - -Installation procedure: Patch yourself your copy of WS.COM with this WS3.HEX file. -C>WINSTALL - -... - -The changes made during this session of INSTALL are stored -in a temporary file. You may now save these changes in your -installed file C:WS.COM. - -These are your current values: - -Terminal : DEC VT-100 -Printer : Standard Printer -Communications protocol : No protocol -Driver : Primary list device - - ***** EXIT OPTIONS MENU ***** - -A Save the changes made during this INSTALL session -B Quit this session of INSTALL without saving changes -C Change any of your choices / Remain in INSTALL - - Enter the letter of your choice (A/B/C). - - - -Your new installed WordStar file is C:WS.COM. - - -You are returning to the operating system. - - -C>TYPE WS3.HEX -:03010000C30046F3 -:1C02320018500000000000000000000000000000000000000000000000C3BB02C8 -:20025000031B5B4B000000031B5B4D000000031B5B4C0000000000051B5B34336D00051BD0 -:200270005B30306D000000000000000000000000000000000000000000C90000C9000A05A5 -:01029000006D -:02029300FF006A -:0302A000C307038E -:2002BB00CDE9027DCDF3023E3BCD06017CCDF3023E48CD06017DB7210B37113030C2E1029A -:2002DB00213031113232226A02EB227102C93E1BCD06013E5BC306013C06FFD60A04D2F6B8 -:2002FB0002F578C4F402F1C63AC30601F5573A33023DBC21A00236000165020A5EC21E039F -:20031B001E222FB7CA36037AB7FA36030A2F02CDE9027BCDF4023E6DCD0601F1FE0BC24386 -:10033B00033E21CDF4023E3BE67FCD060136C3C919 -:20460000112A460E31CD0500B7CA10463C323202112C460E31CD0500B7CA27463CFEFADAFF -:0E46200024463EFA323302C3FC2C1C001A0062 -:00000001FF - -C>SID WS.COM -CP/M 3 SID - Version 3.0 -NEXT MSZE PC END -4600 4600 0100 DAFF -#Rws3.hex -NEXT MSZE PC END -462E 462E 0100 DAFF -#Wws.com -008Bh record(s) written. -#g0 - -C>device console [lines=44,columns=132] - -Console width set to 132 columns -Console page set to 44 lines - - -C>ws \ No newline at end of file diff --git a/software/CPM/CPM27_WORDSTAR_v30/WIMSGS.OVR b/software/CPM/CPM27_WORDSTAR_v30/WIMSGS.OVR deleted file mode 100644 index 4d804ea..0000000 Binary files a/software/CPM/CPM27_WORDSTAR_v30/WIMSGS.OVR and /dev/null differ diff --git a/software/CPM/CPM27_WORDSTAR_v30/WS.COM b/software/CPM/CPM27_WORDSTAR_v30/WS.COM deleted file mode 100644 index 00e29ef..0000000 Binary files a/software/CPM/CPM27_WORDSTAR_v30/WS.COM and /dev/null differ diff --git a/software/CPM/CPM27_WORDSTAR_v30/WSMSGS.OVR b/software/CPM/CPM27_WORDSTAR_v30/WSMSGS.OVR deleted file mode 100644 index ece7473..0000000 Binary files a/software/CPM/CPM27_WORDSTAR_v30/WSMSGS.OVR and /dev/null differ diff --git a/software/CPM/CPM27_WORDSTAR_v30/WSOVLY1.OVR b/software/CPM/CPM27_WORDSTAR_v30/WSOVLY1.OVR deleted file mode 100644 index f4944d1..0000000 Binary files a/software/CPM/CPM27_WORDSTAR_v30/WSOVLY1.OVR and /dev/null differ diff --git a/software/CPM/CPM27_WORDSTAR_v30/WSU.COM b/software/CPM/CPM27_WORDSTAR_v30/WSU.COM deleted file mode 100644 index b6c93ed..0000000 Binary files a/software/CPM/CPM27_WORDSTAR_v30/WSU.COM and /dev/null differ diff --git a/software/CPM/CPM27_WORDSTAR_v30/ws3.hex b/software/CPM/CPM27_WORDSTAR_v30/ws3.hex deleted file mode 100644 index 6eccd67..0000000 Binary files a/software/CPM/CPM27_WORDSTAR_v30/ws3.hex and /dev/null differ diff --git a/software/CPM/CPM28_PLM80/ASM80.EXE b/software/CPM/CPM28_PLM80/ASM80.EXE deleted file mode 100644 index 05e2dcd..0000000 Binary files a/software/CPM/CPM28_PLM80/ASM80.EXE and /dev/null differ diff --git a/software/CPM/CPM28_PLM80/PLM80.EXE b/software/CPM/CPM28_PLM80/PLM80.EXE deleted file mode 100644 index ea84ddf..0000000 Binary files a/software/CPM/CPM28_PLM80/PLM80.EXE and /dev/null differ diff --git a/software/CPM/CPM28_PLM80/README.TXT b/software/CPM/CPM28_PLM80/README.TXT deleted file mode 100644 index 8132758..0000000 --- a/software/CPM/CPM28_PLM80/README.TXT +++ /dev/null @@ -1,128 +0,0 @@ - The accompanying software is being provided by Intel Corporation in -response to your request for this software. - - This software is considered proprietary, is copyrighted, and is provided -to you under the same terms of the Intel Software License Agreement provided -with the original product at the time of purchase. A copy of the license -agreement is included in this file for your reference. - - If you or your company can not agree to the terms set forth in this -agreement, do not decompress (unzip) this file any further. Instead, -please immediately delete all files that are contained in the compressed -file and any that were transferred to other media and notify Intel at -1-800-628-8686 that you have done so. - - The software contained in this compressed file has been virus -scanned prior to compression for the protection of your system. By using -the command below, you are agreeing to the terms and conditions of the -Software License Agreement included in this file. - - To decompress the software contained on this media enter the following -command and parameters at the DOS prompt; - - intel [-d] [outpath] - - Where; - intel is the compressed self-extracting file - OPTIONAL: - d is used if you wish to retain any sub-directories - that may be contained in . - outpath is the destination directory path. - - EXAMPLE: intel -d C:\INTEL\MCS96 - - BY USING THIS SOFTWARE, YOU ARE AGREEING TO BE BOUND BY THE - TERMS OF THIS AGREEMENT. DO NOT USE THIS SOFTWARE UNTIL YOU - HAVE CAREFULLY READ AND AGREED TO THE FOLLOWING TERMS AND - CONDITIONS. IF YOU DO NOT AGREE TO THE TERMS OF THIS AGREEMENT, - PROMPTLY RETURN THE SOFTWARE AND ANY ACCOMPANYING ITEMS. - - IF YOU USE THIS SOFTWARE, YOU WILL - BE BOUND BY THE TERMS OF THIS AGREEMENT - -LICENSE: Intel grants you the right to use the enclosed software program -(the "Software"). You will not use, copy, modify, rent, sell or transfer -the Software or any portion thereof except as provided in this Agreement. - -Intel also grants you the royalty-free right to reproduce and distribute -executable files created using this Software and any runtime modules -included with this Software provided: a) they are distributed as a part of -your software product and b) you agree to indemnify, hold harmless, and -defend Intel against any claims or lawsuits that arise from the use or -distribution of your software product. - -You may: -1. Use the Software on a single computer; -2. Copy the Software solely for backup or archival purposes. - -RESTRICTIONS: -You Will Not: -1. Use the Software or cause the Software to be used on more than one - computer at the same time including using the Software across a - network system; -2. Sublicense the Software; -3. Reverse engineer, decompile, or disassemble the Software; -4. Copy the Software except as provided in this Agreement; - -TRANSFER: You may transfer the Software to another party if the receiving -party agrees to the terms of this Agreement and you retain no copies of the -Software and accompanying documentation. - -Transfer of the license terminates your right to use the Software. - -OWNERSHIP AND COPYRIGHT OF SOFTWARE: Title to the Software and all -copies thereof remain with Intel or its vendors. The Software is copyrighted -and is protected by United States copyright laws and international treaty -provisions. You will not remove the copyright notice from the Software. You -agree to prevent any unauthorized copying of the Software. - -WARRANTY: Intel warrants that it has the right to license you to use the -Software. Intel warrants that the media on which the Software is furnished -will be free from defects in material and workmanship under normal use for a -period of ninety (90) days from the date of purchase. Intel's entire -liability and your exclusive remedy shall be the replacement of the Software -if the media on which the Software is furnished proves to be defective. This -warranty is void if the media defect has resulted from accident, abuse, -or misapplication. Any replacement of media will be warranted for the -remainder of the original warranty period or thirty (30) days, whichever is -longer. - -DISCLAIMER: Except as provided above, the Software is provided "AS IS" -without warranty of any kind. - - LIMITATION OF LIABILITY: THE ABOVE WARRANTIES ARE THE ONLY - WARRANTIES OF ANY KIND EITHER EXPRESS OR IMPLIED INCLUDING - WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR - PURPOSE. NEITHER INTEL NOR ITS VENDORS SHALL BE LIABLE FOR ANY - LOSS OF PROFITS, LOSS OF USE, INTERRUPTION OF BUSINESS, NOR FOR - INDIRECT, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY - KIND WHETHER UNDER THIS AGREEMENT OR OTHERWISE. - -AUDIT: Intel reserves the right to conduct or have conducted audits to -verify your compliance with this Agreement. - -TERMINATION OF THIS LICENSE: Intel may terminate this license at any time if -you are in breach of any of its terms and conditions. Upon termination, you -will immediately destroy the Software or return all copies of the Software -and documentation to Intel along with any copies you have made. - -U.S. GOVERNMENT RESTRICTED RIGHTS: The Software and documentation -are provided with "RESTRICTED RIGHTS." Use, duplication or disclosure by the -Government is subject to restrictions as set forth in FAR52.227-14 and -DFAR252.227-7013 et seq. or its successor. The use of this Software by the -Government constitutes acknowledgement of Intel's proprietary rights in the -Software. - -EXPORT LAWS: You agree and certify that neither the Software nor the direct -product thereof is intended to be shipped either directly or indirectly to -country groups Q, S, W, Y, Z, Afghanistan or the People's Republic of China, -unless a validated export license is obtained from the -U.S. Department of Commerce. - -APPLICABLE LAW: This Agreement is governed by the laws of the state of -California and the United States, including patent and copyright laws. Any -claim arising out of this Agreement will be brought in Santa Clara County, -California. -MPS0026-1 2/4/91 - 466864-001 - INTEL END USER SOFTWARE LICENSE AGREEMENT diff --git a/software/CPM/CPM29_ZSID_v14/READ.ME b/software/CPM/CPM29_ZSID_v14/READ.ME deleted file mode 100644 index 9b9e8cc..0000000 --- a/software/CPM/CPM29_ZSID_v14/READ.ME +++ /dev/null @@ -1,10 +0,0 @@ -This is ZSID v1.4. It is a Z80 debugger. There were evidently a couple of -problems with this program. The files in this ZIP file are : - -ZSID.COM - The original unmodified program. -ZSID-FIX.DOC - A file describing a patch. -ZSID-PAT.COM - ZSID.COM with the above patch applied. - -ZSID.PAT - A file describing a different patch. This patch has NOT - been applied to the ZSID.CON file. - diff --git a/software/CPM/CPM29_ZSID_v14/ZSID-FIX.DOC b/software/CPM/CPM29_ZSID_v14/ZSID-FIX.DOC deleted file mode 100644 index 6052ea7..0000000 --- a/software/CPM/CPM29_ZSID_v14/ZSID-FIX.DOC +++ /dev/null @@ -1,74 +0,0 @@ - - - **************************************************************** - - PATCH TO MAKE ZSID.COM THE SAME DUMP DISPLAY AS DDT AND SID - - RESEARCH BY DATAFACS SYSTEMS, INC. - - **************************************************************** - - - DO THE FOLLOWING: - - ZSID ZSID.COM - - S125F 5F AF <--- PUT THIS IN HIT RETURN - 1260 ?? . "" - - S12C0 CD 00 <---- PUT THIS IN HIT RETURN - 12C1 ?? 00 "" - 12C2 ?? 00 "" - 12C3 06 ?? <---- LEAVE THIS ALONE - 12C4 06 01 <---- PUT THIS IN HIT RETURN - 12C5 ?? . "" - -* S12E1 CD 00 <---- PUT THIS IN HIT RETURN -* 12E2 ?? 00 "" -* 12E3 ?? 00 "" -* 12E4 CD 00 "" -* 12E5 ?? 00 "" -* 12E6 ?? 00 "" - 12E7 13 . <-- **** DONE **** - - CONTROL C OR G0 ZERO AND SAVE THE PROPER AMOUNT - - - IF YOU DON'T TRUST THIS SAVE IT AS A DIFFERENT NAME FIRST - - ******* HAVE FUN AND ENJOY ****** - -* CALLS THE SAME ADDRESS - ------------------------------------------------------------------ - -Addendum by Bob Fisher - De Paul University - -The above patch MAY work, but it depends on what address your cpm -runs at. Try instead the following: - - S125F - 125F 5F AF (SAME AS ABOVE) - 1260 ?? . - - S12C0 CD 18 (PUT IN A RELATIVE JUMP) - 12C1 ?? 01 - 12C2 ?? 00 (THIS DOESN'T MATTER) - 12C3 06 06 (DON'T CHANGE) - 12C4 06 01 - 12C5 ?? . - - S12E1 - 12E1 CD 18 (ANOTHER RELATIVE JUMP) - 12E2 ?? 04 - 12E3 ?? ?? - 12E4 CD 18 (YET ANOTHER RELATIVE JUMP) - 12E5 ?? 01 - 12E6 ?? . - -When ZSID relocates itself an offset is added to bytes 12c2, 12e3, and -12e6. The previous patch left this offset to be interpreted as an opcode. -The result can be benign or disastrous depending on the size of your -cpm. - - \ No newline at end of file diff --git a/software/CPM/CPM29_ZSID_v14/ZSID-PAT.COM b/software/CPM/CPM29_ZSID_v14/ZSID-PAT.COM deleted file mode 100644 index 30423c9..0000000 Binary files a/software/CPM/CPM29_ZSID_v14/ZSID-PAT.COM and /dev/null differ diff --git a/software/CPM/CPM29_ZSID_v14/ZSID.COM b/software/CPM/CPM29_ZSID_v14/ZSID.COM deleted file mode 100644 index 221c0ae..0000000 Binary files a/software/CPM/CPM29_ZSID_v14/ZSID.COM and /dev/null differ diff --git a/software/CPM/CPM29_ZSID_v14/ZSID.PAT b/software/CPM/CPM29_ZSID_v14/ZSID.PAT deleted file mode 100644 index 7aa2319..0000000 --- a/software/CPM/CPM29_ZSID_v14/ZSID.PAT +++ /dev/null @@ -1,37 +0,0 @@ -======== -Newsgroups: comp.os.cpm -Subject: Re: CP/M web page has new stuff -From: hp@kbbs.org (Holger Petersen) -Date: Mon, 25 Aug 1997 07:19:08 GMT - -timolmst@cyberramp.net writes: - -> Also, ZSID binary is now available. - -Could you please mention the patch from "Dr. Dobbs Journal #62, Dec 1981 -page 519: ZSID Bug and (Risky?) Patch" ? -It changed the byte at 02AE from C2 to C3. - -Befor, some adresses of FF80 to FFFF would be handled bad in (A)ssemble, -(F)ill, (M)ove and (D)ump - commands: - -A>ZSID -ZSID VERS 1.4 -#A100 -0100 LD HL,0FF7F -0103 LD HL,0FF80 -0106 LD HL,0FFFF -0109 -#L100,108 - 0100 LD HL,FF7F - 0103 LD HL,0080 - 0106 LD HL,00FF - 0109 - -=========================== - -Some months later, I got a letter from Digital Research which 'begged' -for the allowence to use this patch, which I did... - -Greetings, Holger - diff --git a/software/CPM/CPM30_WORDSTAR_v400/ANAGRAM.COM b/software/CPM/CPM30_WORDSTAR_v400/ANAGRAM.COM deleted file mode 100644 index 0579d84..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/ANAGRAM.COM and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/CHAPTER1.DOC b/software/CPM/CPM30_WORDSTAR_v400/CHAPTER1.DOC deleted file mode 100644 index 7546433..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/CHAPTER1.DOC +++ /dev/null @@ -1,2 +0,0 @@ -Thió ió chapteò 1. - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/CHAPTER2.DOC b/software/CPM/CPM30_WORDSTAR_v400/CHAPTER2.DOC deleted file mode 100644 index 883bf15..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/CHAPTER2.DOC +++ /dev/null @@ -1,2 +0,0 @@ -Thió ió chapteò 2. - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/CHAPTER3.DOC b/software/CPM/CPM30_WORDSTAR_v400/CHAPTER3.DOC deleted file mode 100644 index e65f09c..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/CHAPTER3.DOC +++ /dev/null @@ -1,2 +0,0 @@ -Thió ió chapteò 3. - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/DIARY.DOC b/software/CPM/CPM30_WORDSTAR_v400/DIARY.DOC deleted file mode 100644 index cb3e9cb..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/DIARY.DOC +++ /dev/null @@ -1,74 +0,0 @@ - Trið Diary - -Septembeò 10 - -Whaô  á wonderfuì citù Londoî is¡ We'vå beeî herå twï  dayó  anä -havå  beeî  literallù runninç froí onå touò  tï  another®   We'rå -prettù  exhausted¬ anä looë ferwarä tï explorinç á fe÷ sightó  oî -ouò own. - -Thió  morninç wå tooë á touò thaô begaî aô Trafalgaò Square®   Wå -tooë  thå  undergrounä (theiò worä foò subway©  froí  ouò  hotel® -We'vå  founä  thå  Londoî undergrounä tï bå á greaô  waù  tï  geô -arounä  anä  lesó  costlù thaî taxis® Wå haä  á  whirlwinä  touò -seeinç  Parliament¬  thå Toweò oæ London¬ Toweò Bridge¬  anä  thå -changinç  oæ thå guarä aô thå palace® Mosô impressivå  werå  thå -crowî jeweló iî thå Toweò oæ London. - -Wå  havå beiî tourinç sï mucè thaô thió afternoon¬ wå decideä  tï -dï  á  littlå  shopping®   Wå wenô tï onå  oæ  thå  worlä  famouó -departmenô  stores® Thå enormitù oæ thå placå waó  overwhelming® -Wå founä wå werå morå comfortablå shoppinç inthå smalleò shops® É -boughô á wooì scaræ anä á teá set. - -Hydå Parë ió walkinç distancå froí ouò hotel® Sï aô thå enä oæ á -hectiã day¬ wå decideä á strolì througè thå parë waó jusô whaô wå -needed®   Wå endeä uð sittinç oî á parë bencè foò abouô aî  hour® -Thå peoplå-watchinç waó fun® Alì thå classiã Englisè  characteró -passeä  beforå uó ­­ meî iî derbù ható anä piî  stripes¬  nannieó -pushinç babù carriages¬ anä bobbieó amonç them. - -Ouò  morninç  touò  guidå saiä nï visiô  tï  Londoî  ió  completå -withouô  teá  aô thå Ritú Hotel® Sï froí Hydå Park wå  walkeä  á -shorô distancå uð Picadillù anä haä á mosô memorablå testime® Iô -waó  reallù á smalì meal¬ witè hoô disheó beinç offereä witè  thå -usuaì farå oæ scones¬ cookies¬ anä cakes. - -Afteò sufficientlù stuffinç ourselveó aô teatime¬ wå walkeä á biô -more® Buô thå Londoî rusè houò goô tï uó sï wå decideä tï taëe iî -á moviå ratheò thaî trù tï geô bacë tï thå hotel® Somehow¬  I'vå -gotteî enougè energù tï writå thió entrù iî mù trið diary®   I'vå -haä á trulù wonderfuì daù® É lovå thió city. - -Septembeò 12 - -I'vå  goô tï catcè uð oî twï dayó oæ diarù entries® Wå  wenô  tï -thå theateò lasô night¬ anä goô bacë tï thå hoteì toï latå tï  dï -anù writing. - -Yesterday¬  wå tooë á breaë froí organizeä tours¬ anä decideä  tï -visiô  severaì  Londoî siteó oî ouò own® Iî thå morninç  wå  wenô  tï -Westminsteò  Abbey® Wå boughô á guidebooë anä tooë  á  leisurelù -touò oæ thå church® - -Iî thå afternoon¬ wå visiteä thå Britisè Museum® Thå placå ió sï -hugå  thaô iô ió impossiblå tï eveî thinë oæ coverinç iô  alì  iî Šonå afternoon® Buô wå tooë á quicë touò anä sa÷ thå Magná Carta¬ -thå Rosettá Stone¬ anä á hugå collectioî oæ originaì  manuscriptó -anä  musicaì scoreó ­­ Bach¬ Handel¬ Beethoven¬  Keats¬  Shelley¬ -Dickenó, anä manù more. - -Today¬  wå lefô Londoî anä tooë á daù touò tï Stratforä-oî-Avon¬  thå -birthplacå  oæ Williaí Shakespeare® Wå wenô bù buó witè á  largå -grouð  buô thå touò guidå waó sï welì informeä thaô iô  waó  welì -wortè  it® Wå covereä á loô iî onå daù anä eveî tooë timå foò  á -leisurelù luncè aô á locaì hotel. - -Stratforä-oî-Avoî   ió  á  picturesquå  littlå  towî  anä   stilì -maintainó  itó  Elizabethaî  flavor®   Mosô  buildingó  arå   thå -originaló  anä havå beeî verù welì preserved® Wå enjoyeä  seeinç -alì thå siteó relateä tï Shakespeare'ó life. - -Tomorro÷ ió ouò lasô daù iî London® We'lì havå tï makå thå  mosô -oæ it! - - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/DICTSORT.COM b/software/CPM/CPM30_WORDSTAR_v400/DICTSORT.COM deleted file mode 100644 index 04c821b..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/DICTSORT.COM and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/FIND.COM b/software/CPM/CPM30_WORDSTAR_v400/FIND.COM deleted file mode 100644 index e036680..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/FIND.COM and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/HOMONYMS.TXT b/software/CPM/CPM30_WORDSTAR_v400/HOMONYMS.TXT deleted file mode 100644 index 8385548..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/HOMONYMS.TXT and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/HYEXCEPT.TXT b/software/CPM/CPM30_WORDSTAR_v400/HYEXCEPT.TXT deleted file mode 100644 index 51673a9..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/HYEXCEPT.TXT +++ /dev/null @@ -1,358 +0,0 @@ -CON-TROL-LABLE -EQ-UABLE -IN-SA-TIABLE -NE-GO-TIABLE -SO-CIABLE -TURN-TABLE -UN-CON-TROLLABLE -UN-SO-CIABLE - -DE-PEND-ENT -IN-DE-PEND-ENT - -ANY-THING -BAL-DING -DAR-LING -DUMP-LING -ERR-ING -EVE-NING -EVERY-THING -FAR-THING -FOUND-LING -INK-LING -MAIN-SPRING -NEST-LING -OFF-SPRING -PLAY-THING -SAP-LING -SHOE-STRING -SIB-LING -SOME-THING -STAR-LING -STER-LING -UN-ERR-ING -UP-SWING -WEAK-LING -YEAR-LING - -CIV-I-LIZE -CRYS-TAL-LIZE -IM-MO-BI-LIZE -ME-TA-BO-LIZE -MO-BI-LIZE -MO-NOP-O-LIZE -STA-BI-LI*ZE -TAN-TA-LIZE -UN-CIV-I-LIZED - -PAL-ATE -IN-CLEM-ENT -BAR-ON-ESS -LI-ON-ESS -EU-LOGY -PED-A-GOGY -LUS-CIOUS -AT-MOS-PHERE -MET-AL -NON-METAL -PET-AL -POST-AL -RENT-AL -CAT-ION -COM-BAT-IVE -STAT-URE -BECK-ON -BES-TIAL -COM-A-TOSE -COME-BACK -CO-ME-DIAN -COMP-TROLLER -CONE-FLOWER -CO-NUN-DRUM -EQUIPPED -HANDLE-BAR -INCH-WORM -INK-BLOT -INN-KEEPER -IN-TE-RIOR -MIN-IS-TER -MIN-IS-TRY -NONE-THE-LESS -QUA-DRILLE -SOM-ER-SAULT -SU-PE-RIOR -U-NA-NIM-ITY -U-NAN-I-MOUS -UNC-TUOUS -DEBT-OR -AC-KNOW-LEDGE -DE-DUCT-I*BLE -EX-ACT-I-TUDE -IN-EX-ACT-I-TUDE -PRE-DICT-*ABLE -RE-SPECT-*ABLE -UN-PRE-DICT-ABLE -VICT-UAL -NEEDLE-WORK -IDLER -BUFF-ER -OFF-BEAT -OFF-HAND -OFF-PRINT -OFF-SHOOT -OFF-SHORE -STIFF-EN -LEFT-IST -LEFT-OVER -LIFT-OFF -SOFT-HEARTED -EGG-SHELL -EGG-PLANT -EGG-NOG -EGG-HEAD -COGNAC -FOR-EIGN-ER -VIGNETTE -HOGS-HEAD -CHILD-ISH -ELD-EST -GOLD-EN -HOLD-OUT -HOLD-OVER -HOLD-UP -SELF-ISH -BULL-ISH -CREST-FALLEN -DIS-TILL-*E*RY -FALL-OUT -LULL-ABY -ROLL-AWAY -SELL-OUT -WALL-EYE -PSALM-IST -ELSE-WHERE -FALSE-HOOD -CON-SULT-ANT -VOLT-AGE -RE-SOLV-ABLE -RE-VOLV-ER -SOLV-ABLE -UN-SOLV-ABLE -BEACH-COMBER -BOMB-ER -CLIMB-ER -PLUMB-ER -DAMP-EN -DAMP-EST -CLINCH-ER -LAUNCH-ER -LUNCH-EON -RANCH-ER -TRENCH-ANT -AN-NOUNCER -BOUNCER -FENCER -HENCE-FORTH -MINCE-MEAT -SI-LENCER -BIND-ERY -BOUND-ARY -COM-MEND-*A-*T*ORY -DE-PEND-ABLE -EX-PEND-ABLE -FIEND-ISH -LAND-OWNER -OUT-LAND-ISH -ROUND-ABOUT -SEND-OFF -STAND-OUT -UN-DER-STAND-ABLE -CHANGE-OVER -HANG-OUT -HANG-OVER -HA-RANGUE -ME-RINGUE -ORANGE-ADE -TONGUE -VENGE-ANCE -SENSE-LESS -AC-COUNT-ANT -ANT-ACID -ANT-EATER -COUNT-ESS -PER-CENT-*AGE -REP-RE-SENTATIVE -ANT-HILL -PENT-HOUSE -AC-CEPT-ABLE -AC-CEPTOR -ADAPT-ABLE -ADAPT-ER -CRYPT-ANALYSIS -IN-TER-RU*P*T-*I*BLE -AN-TIQ-UI*TY -INEQ-UITY -INIQ-UITY -LIQ-UEFY -LIQ-UID -LIQ-UI-D*A*T*E -LIQ-UI-D*A-*T*ION -LIQ-UOR -PRE-REQ-UI-SITE -REQ-UI-SI-TION -SUB-SEQUENCE -U-BIQ-UI-TOUS -AB-SORB-ENT -CARB-ON -HERBAL -IM-PERT-TURB-ABLE -ARCH-ERY -ARCH-AN-GEL -RE-SEARCH-ER -UN-SEARCH-ABLE -AC-CORD-ANCE -BOARD-ER -CHORDAL -HARD-EN -HARD-EST -HAZ-ARD-OUS -JEOP-ARD-IZE -RE-CORDER -STAND-ARD-IZE -STEW-ARD-ESS -YARD-AGE -SURF-ER -MORGUE -CURL-I-CUE -AF-FIRM-*A*T*IVE -CON-FORM-*ITY -DE-FORM-ITY -IN-FORM-A*NT -NON-CON-FORM-IST -CAV-ERN-OUS -DIS-CERN-IBLE -MOD-ERN-IZE -TURN-ABOUT -TURN-OVER -UN-GOV-ERN-ABLE -WEST-ERN-IZE -HARP-IST -SHARPEN -TORQUE -COARS-EN -IR-RE-VERS-IBLE -NURSE-MAID -NURS-ERY -RE-HEARS-AL -RE-VERS-IBLE -WORS-EN -ART-IST -CON-VERT-IBLE -COURT-YARD -FORE-SHORT-EN -HEART-ACHE -HEART-ILY -SHORT-EN -APART-HEID -COURT-HOUSE -EARTH-EN-WARE -NORTH-EAST -NORTH-ERN -PORT-HOLE -NERV-OUS -OB-SERV-A*BLE -OB-SERVER -PRE-SERV-*A*T*I*VE -SERV-ER - -SERV-ICE-ABLE -PRE-SCHOOL -CON-DE-SCEND -CRE-SCENDO -DE-CRE-SCENDO -DE-SCEND-ENT -DE-SCENT -PLEB-I-SCITE -RE-SCIND -SEA-SCAPE -ASKANCE -SNAKE-SKIN -WHISK-ER -COLE-SLAW -RATTLE-SNAKE -CLASS-IFY -CLASS-ROOM -CROSS-OVER -DIS-MISS-*AL -EX-PRESS-*I*BLE -IM-PASS-ABLE -LESS-EN -PASS-ABLE -TOSS-UP -UN-CLASS-I-FIED -AR-MI-STICE -ASTIG-MA-TISM -ASTIR -ASTONISH-MENT -BLAST-OFF -BY-STAND-ER -CANDLE-STICK -CAST-AWAY -CAST-OFF -CON-TEST-ANT -CO-STAR -DE-TEST-ABLE -DI-GEST-IBLE -EAST-ERN -EX-IST-ENCE -FORE-STALL -IN-CON-TEST-ABLE -IN-DI-GES*T-*I*BLE -IN-EX-HAUST-IBLE -LIFE-STYLE -LIME-STONE -LIVE-STOCK -MILE-STONE -NON-EX-IST-ENT -PER-SIST-ENT -PHO-TO-STAT -RE-START-ED -RE-STATE-MENT -RE-STORE -SHY-STER -SIDE-STEP -SMOKE-STACK -SUG-GEST-*I*BLE -THERMO-STAT -WASTE-BAS-KET -WASTE-LAND -MAST-HEAD -POST-HU-MOUS -PRIEST-HOOD -SIDE-SWIPE -WATT-METER -BE-TWEEN -KIB-ITZER -BUZZ-ER -AL-GO-RITHM -BIB-LI-OG-RAPHY -BI-NO-MIAL -CEN-TER -COM-PUT-A*BIL-ITY -DEC-LA-RA-TION -DE-GREE -ES-TAB-LISH -GEN-ER-ATOR -HAP-HAZARD -NEG-LI-GIBLE -PE-RI-ODIC -POLY-NO-MIAL -PRE-VIOUS -PROB-ABIL-ITY -PROB-ABLE -PRO-CE-DURE -PUB-LI-CA-TION -PUB-LISH -RE-PLACE-MENT -WHEN-EVER - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/HYPHEN.COM b/software/CPM/CPM30_WORDSTAR_v400/HYPHEN.COM deleted file mode 100644 index f37eae9..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/HYPHEN.COM and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/LOOKUP.COM b/software/CPM/CPM30_WORDSTAR_v400/LOOKUP.COM deleted file mode 100644 index 460bdfa..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/LOOKUP.COM and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/MAINDICT.CMP b/software/CPM/CPM30_WORDSTAR_v400/MAINDICT.CMP deleted file mode 100644 index b36ede7..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/MAINDICT.CMP and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/MARKFIX.COM b/software/CPM/CPM30_WORDSTAR_v400/MARKFIX.COM deleted file mode 100644 index 2bb6078..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/MARKFIX.COM and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/MOVEPRN.COM b/software/CPM/CPM30_WORDSTAR_v400/MOVEPRN.COM deleted file mode 100644 index 63e864f..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/MOVEPRN.COM and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/PATCH.LST b/software/CPM/CPM30_WORDSTAR_v400/PATCH.LST deleted file mode 100644 index 7a4a98f..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/PATCH.LST +++ /dev/null @@ -1,1877 +0,0 @@ - ; - ;In order to minimize changes to the locations of User area - ;data, the origin is forced here to 180H above the start of - ;the TPA. - ; - ORG TPA+180H ;Always start user area in same spot - - ; - ;This jump table provides commonly used subroutines for use - ;by custom subroutines in the User areas. It must not be - ;modified in any way. - ; - - ; - ;To output a character to the terminal from within your - ; custom subroutines, call DISPLA with the character - ; to be output in the accumulator (A register). All - ; registers will be preserved. - ; -0280 DISPLA:: -0280 C3 0CB6 JMP CO ;Display character routine - - ; - ;To output a string to the terminal that is in the normal - ; user area format (count followed by bytes), call - ; STRING with HL pointing to the string to be output. - ; Upon returning, HL points to the byte following the - ; string. - ; -0283 STRING:: -0283 C3 17C6 JMP STROUT ;Display string routine - - ; - ;To use WordStar's standard list output drivers, call the - ; following subroutines. In all cases, all registers - ; except for the PSW are unchanged by the subroutines. - ; -0286 LSTOUT: ;Prints char in A. -0286 C3 0000* JMP LO - -0289 LSOSTA: ;Returns output status to A (0 if busy). -0289 C3 0000* JMP LOSTAT - -028C LSTIN: ;Inputs char from printer to A. (Only -028C C3 0000* JMP LI ;works if custom ULISTI exists.) - -028F LSISTA: ;Returns input status to A (0 if no char). -028F C3 0000* JMP LISTAT ;(Only works if custom ULISTA.) - -0292 LSTRNG: ;Send string to list device. (HL points - -0292 C3 0000* JMP LSTSTR ;to string, count byte first, just like - ;console strings). - - ; - ;This flag is used if WordStar is on a multi-user system. It should - ;be set to zero on single-user systems. Each bit of MPMFLG is used - ;as follows: - ; - ; Bit Meaning - ; - ; - ; 0 If 0, WordStar will issue a SYSTEM RESET when logging - ; onto a removable disk drive. If 1, no reset will - ; occur, and the operating system itself must handle - ; any disk swapping. - ; - ; 1 If 1, users can share documents. Before opening a - ; document to edit, WordStar will check to see if temporary - ; files with that document name (e.g. FILENAME.$A$) - ; already exist. If such files exist, WordStar will open - ; the document as a protected document, preventing any - ; changes to it. If 0, WordStar will delete existing - ; temporary files when opening the document for editing. - ; - ; 2 If 1, users can share printer. MP/M function calls are - ; issued to attach and detach the list device. If 0, - ; the printer is assumed to be always attached. - ; - ; 3 If 1, WordStar will issue frequent MP/M "dispatch to - ; next task" function calls to assure that multiple users - ; have balanced access to the computer. If 0, WordStar - ; assumes that only one user is on the computer at a time. - ; If the operating system itself can load share adequately - ; (such as MP/M 8/16 systems), set this bit to 0. - ; - ; 4-6 Reserved. - ; - ; 7 If 1, TurboDOS 1.3 operating system. WordStar will not - ; check the disk drive write protect vector, will not check - ; printer busy status, and will issue the TurboDos printer - ; detach call when done printing. If 0, CP/M or MP/M. - ; WordStar does not support TurboDos 1.2. - ; - ;If you are using MP/M, bits 0, 1 and 2 should all be set to 1. Bit 3 - ;should be set for older versions of MP/M. If you are running on a - ;networked system, only bit 1 should be set. If you are using TurboDos - ;1.3 in a multi-user environment, bits 1 and 7 should be set. If you - ;are using single-user TurboDos, only bit 7 should be set. - ; -0295 MPMFLG:: -0295 00 DB 0 ;Zero for single-user systems - -0296 00 DB 0 ;Reserved - - ; - ;SHARE specifies how WordStar will handle two users in a shared file - ;system who attempt to edit the same file. If 0, the second user - ;will be denied access to the file. If 1, the second user can - ;view as much of the file as can be loaded into memory, but he - ;cannot modify the file. - ; -0297 SHARE:: -0297 01 DB 1 ;Allow viewing (protected edit) - -0298 00 00 00 DB 0,0,0 ;Reserved - - ; - ;The function key table allows you to program any function keys that - ;your terminal supports into one or more other keystrokes. Note that - ;on many terminals, the function keys generate a sequence of characters - ;where the first character is a control code. Since WordStar probably - ;uses this same code for one its commands, a timer is used to determine - ;when the "burst" of characters from the function key is done. - ;This works because the terminal will usually send the function - ;key characters at close to full baud rate. At 9600 baud, each character - ;takes 1/960 of a second to send, or close to one millisecond. That - ;means that three characters would take approximately three milliseconds. - ;There is no way that even the fastest human typist could type that - ;fast! Therefore, this method will usually work. - ; - ;Each function key in the table below is represented by two strings. - ;The first describes the "burst" from the key. The second is what it - ;should be translated into. You may not use string indirections in - ;this table (size of -1 followed by address). - ; - ;The end of the function key table is indicated when the size of the - ;function key string is zero. If you have more function keys than will - ;fit, you can put a continuation address after the zero to point to more - ;table. The table at that address must be the same format as this - ;one. No continuation is indicated by an address of zero. - ; - ;One character "bursts" will not work here. If you need to translate - ;a single character into something else, use the user console input - ;routine UCONI. - ; - ;Warning! Terminals or computers that have their own type-ahead - ;buffering may cause problems with this approach since it will be more - ;likely that characters other than just function keys will be "burst" - ;into WordStar by it. - ; - -029B FUNDLY:: -029B 00 DB 0 ;Milliseconds of delay between characters - ;of function key burst (if zero, no - ;function keys are implemented). See - ;section on delays below before adjusting - ;FUNDLY for your system. - -029C 01 DB CTRLA ;Character that starts each burst - ;(set to 0FFh to disable) - -029D FUNTBL:: -029D 03 DB 3 ;Three chars in burst -029E 01 40 0D DB CTRLA,'@',CR ;Function key 1 -02A1 02 DB 2 ;Two chars in replacement -02A2 0B 42 DB CTRLK,'B' ;Mark beginning of block - -02A4 03 DB 3 -02A5 01 41 0D DB CTRLA,'A',CR ;Function key 2 -02A8 02 DB 2 -02A9 0B 4B DB CTRLK,'K' ;Mark end of block - -02AB 03 DB 3 -02AC 01 42 0D DB CTRLA,'B',CR ;Function key 3 -02AF 02 DB 2 -02B0 0B 43 DB CTRLK,'C' ;Copy marked block - -02B2 03 DB 3 -02B3 01 43 0D DB CTRLA,'C',CR ;Function key 4 -02B6 02 DB 2 -02B7 0B 56 DB CTRLK,'V' ;Move marked block - -02B9 03 DB 3 -02BA 01 44 0D DB CTRLA,'D',CR ;Function key 5 -02BD 02 DB 2 -02BE 0B 59 DB CTRLK,'Y' ;Delete marked block - -02C0 03 DB 3 -02C1 01 45 0D DB CTRLA,'E',CR ;Function key 6 -02C4 02 DB 2 -02C5 11 46 DB CTRLQ,'F' ;Find string - -02C7 03 DB 3 -02C8 01 46 0D DB CTRLA,'F',CR ;Function key 7 -02CB 02 DB 2 -02CC 11 41 DB CTRLQ,'A' ;Search and replace - -02CE 03 DB 3 -02CF 01 47 0D DB CTRLA,'G',CR ;Function key 8 -02D2 01 DB 1 -02D3 0C DB CTRLL ;Repeat last find or replace again - -02D4 03 DB 3 -02D5 01 48 0D DB CTRLA,'H',CR ;Function key 9 -02D8 02 DB 2 -02D9 0B 44 DB CTRLK,'D' ;Save document - -02DB 03 DB 3 -02DC 01 49 0D DB CTRLA,'I',CR ;Function key 10 -02DF 02 DB 2 -02E0 0B 51 DB CTRLK,'Q' ;Abandon editing - -02E2 03 DB 3 -02E3 01 4A 0D DB CTRLA,'J',CR ;Function key 11 -02E6 06 DB 6 -02E7 11 46 10 DB CTRLQ,'F',CTRLP ;Find end of paragraph -02EA 0D 0D 0D DB CR,CR,CR - -02ED 03 DB 3 -02EE 01 4B 0D DB CTRLA,'K',CR ;Function key 12 -02F1 08 DB 8 -02F2 11 46 10 DB CTRLQ,'F',CTRLP ;Find beginning of paragraph -02F5 0D 0D 42 0D DB CR,CR,'B',CR,CTRLD -02F9 04 - -02FA 00 DB 0 ;End of table -02FB 0000 DW 0 ;No continuation - - REPT 128-($-FUNTBL) ;Allow 128 bytes for table - DB 0 - ENDM - -031D 00 00 DB 0,0 ;Reserved - - ; - ; TERMINAL PATCH AREA - ; - ;This section contains the user-modifiable constants and - ; routines for hardware-dependent terminal functions - ; and characteristics required by the editor. - ; - ;There are three types of patches in this area. One can - ; patch data values (HITE, WID) which describe the - ; terminal, strings (CLEAD1, ERAEOL) which define - ; control sequences, or actual microprocessor - ; instructions. - ; - ;For the string sequences, the first byte of the patch - ; indicates the number of bytes in the string, - ; followed by that many string bytes. If there is - ; insufficient room for the whole string, the format - ; can be modified by putting a -1 (0FFH) where the - ; number of bytes would go, and then putting the - ; address in the following two bytes (low order byte - ; first) of the address where the longer patch - ; resides. The longer patch must then be of the - ; normal format which is the number of bytes followed - ; by the string. - ; - ;This area is normally patched for your specific terminal - ; by the interactive INSTALL program. Additional - ; patching to this area is needed only for unusual - ; terminals or video boards, or to meet special - ; requirements, or to enhance or personalize your - ; copy of WordStar. The default user area is - ; set up for this example installation. - ; - - ; - ;Video screen height, width, and wrap-around parameters are required. - ; -031F HITE:: -031F 18 DB 24 ;Must be exact screen height in lines. -0320 WID:: -0320 50 DB 80 ;Must be <= exact screen width in columns. -0321 WRAP:: -0321 FF DB TRUE ;Indicates if terminal wraps around to next - ;line if a character is displayed in WIDth - ;column of screen (set FALSE if it doesn't) - -0322 XONOFF:: -0322 FF DB TRUE ;TRUE if XON/XOFF protocol to be used for - ;the CRT terminal - -0323 SCROLL:: -0323 14 DB 20 ;Number of columns that are horizontally - ;scrolled when cursor moves beyond right - ;or left side of screen. - -0324 DIRSIZ:: -0324 05 DB 5 ;Number of lines available for directory - ;at bottom of screen. If zero, no directory. - -0325 0B DB 11 ;Larger directory for document selection - - ; - ;Delete Display String - ; - ;The following string indicates to WordStar how to display a delete - ;character (hex 7F) on the screen while editing. On terminals that - ;interpret the delete character code into a displayable character, it - ;is recommended that DELSTR be translated into the delete code itself - ;(length of 1, then 7FH). All characters in the string must display. - ; -0326 DELSTR:: -0326 03 DB 3 ;Number of chars in string -0327 44 45 4C DB 'DEL' ;What is displayed -032A 00 00 DB 0,0 ;Spare bytes - - ; - ;Soft and End of Line Hyphen Display String - ; - ;In order to distinguish soft hyphens from normal hyphens in the text, - ;WordStar will substitute the following string when one is encountered. - ; - -032C SHYSTR:: -032C 01 DB 1 ;Number of chars in string -032D 3D DB '=' ;What is displayed -032E 00 00 00 00 DB 0,0,0,0 ;Spare bytes - ; - ;Block Marker Strings - ; - ;Block marker strings are displayed on the screen to show the start and - ;end of a block of text. The strings are in the typical format of the - ;length followed by as many characters. Control characters should not - ;be included within these strings because they would not be sent - ;directly to the screen. - ; - -0332 BBLOCK:: -0332 03 DB 3 ;Three chars -0333 3C 42 3E DB '' ;Begin block -0336 00 DB 0 ;1 spare - ; -0337 KBLOCK:: -0337 03 DB 3 ;Three chars -0338 3C 4B 3E DB '' ;End block -033B 00 DB 0 ;1 spare - - ; - ;Special character used when displaying soft spaces with ^OB. - ; -033C SOFTSP:: -033C 2B DB '+' ;Soft spaces show up as plus signs - -033D 00 00 00 00 DB 0,0,0,0,0 ;Reserved -0341 00 - - ; - ;The following string is used at sign-on to describe the type - ;of terminal being used by WordStar. Up to 40 bytes are available - ;for the string, including its null terminator. - ; -0342 CRTID:: -0342 55 6E 69 6E DB 'Uninstalled Terminal',CR,LF,0 ;Terminal name -0346 73 74 61 6C -034A 6C 65 64 20 -034E 54 65 72 6D -0352 69 6E 61 6C -0356 0D 0A 00 -0359 20 20 20 20 DB ' ' ;Extra room -035D 20 20 20 20 -0361 20 20 20 20 -0365 20 20 20 20 -0369 20 - - ; - ;Cursor positioning control sequences are required. - ; - ;Cursor positioning for most terminals is accomplished - ; by sending: - ; - ; 1. A 'lead-in' string of one or more terminal - ; specific characters. - ; 2. The line number, with an offset (often 20H) added. - ; For some terminals, the column number is - ; sent first. - ; 3. For some terminals, another 'lead-in' string. - ; 4. The column (or line) number, with an offset. - ; 5. For some terminals, a terminating string. - ; - ;For most terminals, the line and column number are sent - ; as one-byte binary numbers. Some terminals require - ; that a two- or three-digit ASCII number is sent. - ; - ;For terminals that do not fit the above patterns, you - ; must code your own subroutine. - ; - ;For example, the cursor is positioned on this sample - ; installation by sending: - ; - ; ESCAPE, '=', - ; line number plus 20H, - ; column number plus 20H. - ; -036A CLEAD1:: ;Initial lead-in string -036A 02 DB 2 ;Number of characters -036B 1B DB ESC ;First character -036C 3D DB '=' ;Second character -036D 00 00 DB 0,0 ;Space for two more characters - -036F CLEAD2:: ;Sent between line and column -036F 00 DB 0 ;Number of characters, none in our -0370 00 DB 0 ;example. First character -0371 00 00 00 DB 0,0,0 ;Space for three more characters - -0374 CTRAIL:: ;Terminating string -0374 00 DB 0 ;Number of characters -0375 00 00 00 00 DB 0,0,0,0 ;Space for four characters - -0379 CB4LFG:: ;Send column before line? -0379 00 DB 0 ;Set non-zero to send column first - -037A CUROFF:: ;Cursor offsets - - ;Offset to add to line -037A 20 DB 20H ;Add 20H to line number (0 is top - ;line of screen before offset) - - ;Offset to add to column -037B 20 DB 20H ;Add 20H to column number (0 is - ;left-most column of screen - ;before offset) - -037C ASCUR:: ;Binary/ASCII digit flag -037C 00 DB 0 ;0 to send binary line and column - ;2 to send 2-digit ASCII numbers - ;3 to send 3-digit ASCII numbers - - ; - ;Provision for positioning cursor by user-coded - ; subroutine, instead of under control of above - ; items. For use in exceptional cases only. - ; - ;Insert a JMP instruction to your subroutine in the - ; following three bytes. Whenever the first byte - ; is non-NOP, this location will be called to - ; position the cursor, and the above cursor patch - ; items will be ignored. - ; - ;Your subroutine will receive the line number in the L - ; register (0 = top line), the column number in - ; the H register (0 = left-most column), and the - ; video attributes at the next typing position in - ; the A register. Attributes are represented as - ; described for the VIDATT routine, except that the - ; warning/error bit indicates double-strike. - ; - ;Your subroutine may alter all registers. - ; -037D UCRPOS:: -037D 00 NOP ;Normally NOP, or JMP to your cursor -037E 00 NOP ;positioning routine. -037F C9 RET - - ; - ;Displaying characters on some screens can be significantly faster if the - ;cursor can be turned off. - ; -0380 ONCUR:: ;Turn cursor on by changing to jump -0380 00 NOP ;to custom subroutine. -0381 00 NOP ; L = current cursor line -0382 C9 RET ; H = cursor column - -0383 OFFCUR:: ;Turn cursor off by changing to jump -0383 00 NOP ;to custom subroutine. -0384 00 NOP ; L = current cursor line -0385 C9 RET ; H = cursor column - - ; - ;Everything in the rest of this section is optional. - ; The items relate either to enhanced performance, - ; or for accomodating unusual terminals. - ; - - ; - ;Erase screen. If this function is not available, leave - ; the first byte zero, and the WordStar will either send - ; line feeds, or update a screen of text using ERAEOL - ; below. - ; - ;After the screen is erased, WordStar assumes that the video - ; attributes are set to normal (dim for the example - ; terminal), and that the cursor is at the home position - ; (upper left hand corner). - ; -0386 ERASCR:: -0386 03 DB 3 ;Number of characters -0387 1A DB CTRLZ ;First character (clear screen) -0388 1B 29 DB ESC,')' ;Additional characters (dim) -038A 00 00 00 00 DB 0,0,0,0,0,0 ;Room for 13 more -038E 00 00 -0390 00 00 00 00 DB 0,0,0,0,0,0,0 -0394 00 00 00 - - ; - ;Backspace one character string. If this function is not - ; available, leave the first byte zero, and WordStar - ; will use cursor addressing to backspace. - ; -0397 BAKSPC:: -0397 01 DB 1 ;Number of characters -0398 08 DB BS ;First character -0399 00 00 00 DB 0,0,0 ;Additional characters - - ; - ;Erase to end of line string. If this function is not - ; available, leave the first byte zero, and WordStar - ; will perform the function more slowly via software. - ; -039C ERAEOL:: -039C 02 DB 2 ;Number of characters -039D 1B DB ESC ;First character -039E 54 00 00 DB 'T',0,0 ;Additional characters - - ; - ;Erase to end of screen string. If this function is not - ; available, leave the first byte zero, and WordStar - ; will perform the function more slowly via software. - ; -03A1 ERAEOS:: -03A1 02 DB 2 ;Number of characters -03A2 1B DB ESC ;First character -03A3 59 00 00 DB 'Y',0,0 ;Additional characters - - ; - ;Delete screen line containing the cursor, and move lower - ; lines on the screen up one line. If this function - ; is not available, leave the first byte zero, and - ; WordStar will perform the function more slowly - ; via software. - ; -03A6 LINDEL:: -03A6 02 DB 2 ;Number of characters -03A7 1B DB ESC ;First character -03A8 52 00 00 DB 'R',0,0 ;Additional characters - - ; - ;Insert a blank line on the screen, moving the line - ; containing the cursor, and the lines below it down - ; one line. If this function is not available, leave - ; the first byte zero, and WordStar will perform - ; the function more slowly via software. - ; -03AB LININS:: -03AB 02 DB 2 ;Number of characters -03AC 1B DB ESC ;First character -03AD 45 00 00 DB 'E',0,0 ;Additional characters - - ; - ;WordStar will use LINDEL and LININS to delete or insert a group - ; of lines rather than just displaying a whole new screenful - ; of characters. LINMAX below indicates the maximum number - ; of lines that this would generally be faster than the - ; re-display. Set to zero if don't care. - ; -03B0 LINMAX:: -03B0 05 DB 5 ;Five lines - - ; - ;Terminal initialization string. A string of bytes which - ; will be sent to the terminal at the beginning of a - ; session. See also INISUB. - ; -03B1 TRMINI:: -03B1 FF DB -1 ;Number of bytes -03B2 0386 DW ERASCR ;Use extension mechanism (-1 as byte -03B4 00 00 DB 0,0 ;count) to erase screen as initialization. - - ; - ;Terminal un-initialization string. A string of bytes - ; which will be sent to the terminal at the end of a - ; session. See also UNISUB. - ; -03B6 TRMUNI:: -03B6 02 DB 2 ;Number of bytes -03B7 1B 28 DB ESC,'(' -03B9 00 00 DB 0,0 - - ; - ;User-patchable initialization subroutine. Called before - ; the TRMINI string is sent. This subroutine may be - ; used for special console initialization or other - ; purposes. See UCRPOS comments. - ; -03BB INISUB:: -03BB 00 NOP ;Normally NOP, or JMP to -03BC 00 NOP ;your subroutine -03BD C9 RET - - ; - ;User patchable un-initialization subroutine. Called - ; before the TRMUNI string is sent. This subroutine - ; may be used to 'undo' any special terminal status - ; used for the WordStar. See UCRPOS comments. - ; -03BE UNISUB:: -03BE 00 NOP ;Normally NOP, or JMP to -03BF 00 NOP ;your subroutine -03C0 C9 RET - - ; - ;Video attributes are used in various places on the WordStar display. - ;The following table describes what each bit of an attribute byte - ;means when used within WordStar. Note that when no bit is set, that - ;is the normal condition. - ; - ; Bit WordStar Usage - ; - ; none Normal text - ; 0 Strike-out text - ; 1 Warning & error messages - ; 2 Marked block of text - ; 3 Underlined text - ; 4 Subscripted text - ; 5 Superscripted text - ; 6 Bold text - ; 7 Italic (or ribbon color) - ; - ;For this sample installation, the following translation of attribute - ;bits into video conditions could be used. - ; - ; WordStar Example - ; - ; Normal Dim - ; Warning Blink - ; Marked Inverse - ; Underlined Underline - ; Subscripted Bright - ; Superscripted Bright - ; Highlighted Bright - ; - ;Because each terminal uses such diverse strings to change video - ;attributes, you must provide a custom subroutine at VIDATT to - ;build the proper one for yours. You may be able to take advantage - ;of the fact that many terminals use a binary method to encode the - ;attributes. If you do not wish to use any video attributes, put - ;the customary two NOP's followed by a RET at VIDATT to disable it. - ; - ;The following implementation is for this sample installation. On that - ;terminal the following sequences are required for the different - ;attributes in our table: - ; - ; Attribute Sequence Screen Space - ; - ; Dim ESC ) NO - ; Bright ESC ( NO - ; Normal video ESC G 0 YES - ; Blink ESC G 2 YES - ; Inverse ESC G 4 YES - ; Underline ESC G 8 YES - ; Underline, blink ESC G : YES - ; Underline, inverse ESC G < YES - ; Underline, inverse, blink ESC G > YES - ; - ;However, since the ESC G attributes take up screen space, we cannot - ;use them with WordStar. Therefore, all attributes are highlighted - ;using bright. - - - ; - ;The VIDATT subroutine is used to change video attributes on the screen. - ;On entry, WordStar will supply the attributes that are on in the C - ;register. You must translate them into whatever your particular terminal - ;requires. The following implementation is a sample installation. - ;This subroutine is called only when a video attribute changes. - ; -03C1 VIDATT:: ;Change to NOP, NOP, RET if not needed -03C1 21 03D2 LXI H,vdim -03C4 0C INR C ;Normal video? -03C5 0D DCR C -03C6 CA 0283 JZ STRING - ; -03C9 21 03CF LXI H,vbrite ;Highlight everything else -03CC C3 0283 JMP STRING - ; -03CF 02 1B 28 vbrite: DB 2,ESC,'(' ;Bright -03D2 02 1B 29 vdim: DB 2,ESC,')' ;Dim - - REPT 128-($-VIDATT) ;Allow total of 128 bytes for VIDATT - DB 0 - ENDM - - ; - ;Normally the status line, text and directories are displayed in - ;dim intensity so that bold and doublestruck text can be shown in - ;high intensity. Setting BRITE to 0FFH reverses the usage of - ;bright and dim for the status line, text and directories ;zero - ;normally. - ; -0441 00 BRITE:: DB 0 ;Don't reverse - ;0FFH = normal text bright - - ; - ;Delays are executed after various terminal functions, before - ; the next character is sent to the terminal, to - ; allow response time required by certain terminals - ; when operating at a high baud rate. Set to a - ; larger value if you suffer a loss of characters - ; after a terminal function. - ; - ;Note that an additional delay FUNDLY is located near the - ; function key table FUNTBL above. - ; - ;Each delay is approximately the number of milliseconds - ; on a 4 MHz Z80 processor, about twice as long on - ; a 2 MHz 8080 (in other words, divide delay values - ; in half for a 2 MHz processor to achieve the same - ; results). - ; -0442 DELCUS:: -0442 00 DB 0 ;No delay after cursor positioning - ;(if your terminal works better with - ;5 milliseconds of delay, you would - ;put a "5" here instead) - -0443 DELMIS:: ;Miscellaneous screen delays -0443 00 DB 0 ;No delay - -0444 DXOFF:: ;If XON/XOFF used for terminal, sometimes -0444 07D0 DW 2000 ;a legitimate ^S will be interpreted as an - ;XOFF character. DXOFF is used to time out - ;so that the terminal will continue. - -0446 DLONG:: ;Long delays (like at sign-on) -0446 07D0 DW 2000 ;2 seconds = 2,000 milliseconds - ;(1000 if 8080) - -0448 DMED:: ;Medium delays (like at P, O, or K menus) -0448 03E8 DW 1000 ;1 second = 1,000 milliseconds - ;(500 if 8080) - -044A DSHORT:: ;Short delays (like before help menus) -044A 00C8 DW 200 ;200 milliseconds (100 if 8080) - -044C UPDLY:: ;Position update delay -044C 00C8 DW 200 ;200 milliseconds (100 if 8080) - -044E DDISK:: ;Disk access delay. If character typed -044E 01F4 DW 500 ;during disk access, wait this duration for - ;more characters. 500 milliseconds - -0450 DFAST:: ;Delay when typing fast. Holds off displaying -0450 0032 DW 50 ;the rest of the line briefly - - ; - ;Optional user-supplied console I/O subroutines. You may - ; patch JMP's here to your own console input, console - ; output, and console status subroutines, in which - ; case these routines, instead of the operating - ; system BIOS entry points, will be used for all - ; console I/O. These subroutines may alter all registers. - ; - ;Use of a custom subroutine accessed here is suggested, - ; for example, to drive a video board that cannot be - ; driven via output to the operating system. - ; -0452 UCNSTA:: ;User console status subroutine. -0452 00 NOP ;Normally NOP, or JMP to your own -0453 00 NOP ;subroutine. Must return 0 in A if -0454 C9 RET ;no character ready, 0FFH if one is - ;ready. - -0455 UCONI:: ;User console input subroutine. -0455 00 NOP ;Normally NOP, or JMP to your own -0456 00 NOP ;subroutine. Must return the -0457 C9 RET ;character in A. May be called - ;before a character is ready. If - ;no character is ready, routine - ;must wait until a character is - ;available. - -0458 UCONO:: ;User console output subroutine. -0458 00 NOP ;Normally NOP, or JMP to your own -0459 00 NOP ;subroutine. Subroutine receives -045A C9 RET ;the character in A, video attributes in - ;B, and current cursor address in HL. - - ; - ;This is 128 bytes set aside for anything that the user wishes to use. - ;If more than 128 bytes are required, it is necessary to put them after - ;the main WordStar code which can be determined by looking at the - ;contents of BGNMEM to see where it is. After using as much space as - ;necessary, change BGNMEM to the new beginning of free memory. - ; -045B MORPAT:: -045B 0000 0000 DW 00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00 -045F 0000 0000 -0463 0000 0000 -0467 0000 0000 -046B 0000 0000 -046F 0000 0000 -0473 0000 0000 -0477 0000 0000 -047B 0000 0000 DW 00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00 -047F 0000 0000 -0483 0000 0000 -0487 0000 0000 -048B 0000 0000 -048F 0000 0000 -0493 0000 0000 -0497 0000 0000 -049B 0000 0000 DW 00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00 -049F 0000 0000 -04A3 0000 0000 -04A7 0000 0000 -04AB 0000 0000 -04AF 0000 0000 -04B3 0000 0000 -04B7 0000 0000 -04BB 0000 0000 DW 00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00 -04BF 0000 0000 -04C3 0000 0000 -04C7 0000 0000 -04CB 0000 0000 -04CF 0000 0000 -04D3 0000 0000 -04D7 0000 0000 - - ; - ;CRTPAT is a patch area that may be used by WordStar's installation - ;program. - ; -04DB CRTPAT:: -04DB 0000 0000 DW 00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00 -04DF 0000 0000 -04E3 0000 0000 -04E7 0000 0000 -04EB 0000 0000 -04EF 0000 0000 -04F3 0000 0000 -04F7 0000 0000 -04FB 0000 0000 DW 00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00 -04FF 0000 0000 -0503 0000 0000 -0507 0000 0000 -050B 0000 0000 -050F 0000 0000 -0513 0000 0000 -0517 0000 0000 -051B 0000 0000 DW 00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00 -051F 0000 0000 -0523 0000 0000 -0527 0000 0000 -052B 0000 0000 -052F 0000 0000 -0533 0000 0000 -0537 0000 0000 -053B 0000 0000 DW 00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00 -053F 0000 0000 -0543 0000 0000 -0547 0000 0000 -054B 0000 0000 -054F 0000 0000 -0553 0000 0000 -0557 0000 0000 - - ; - ;The following string is used to describe the name of the default - ;printer used by WordStar. Up to 40 bytes are provided for the - ;string, including its null terminator. - ; -055B PRNID:: -055B 44 72 61 66 DB 'Draft Printer',CR,LF,0 ;Printer name -055F 74 20 50 72 -0563 69 6E 74 65 -0567 72 0D 0A 00 -056B 20 20 20 20 DB ' ' ;Additional room -056F 20 20 20 20 -0573 20 20 20 20 -0577 20 20 20 20 -057B 20 20 20 20 -057F 20 20 20 20 - - ; - ;WordStar uses a default printer driver if none is specified by the - ;user. The following is its name. It may be up to six characters long, - ;null terminated. - ; -0583 DEFPRN:: -0583 44 52 41 46 DB 'DRAFT',0 ;Standard driver -0587 54 00 -0589 20 DB ' ' ;One extra char - - ; - ;The print delay timer is used to time how long the printer is busy - ;before telling the user that it's been busy a long time. This would - ;primarily be used when the printer was in another room and you might - ;not know that it was busy due to a paper jam or being off line. - ; -058A PRNDLY:: ;Delay before saying printer busy -058A 0000 DW 0 ;Zero to disable - - ; - ;Pausing between each page is used if single sheets of paper are being - ;printed. - ; -058C PPAUSE:: -058C 00 DB FALSE ;Continuous form (don't pause) - - ; - ;Many printers can use form feeds to quickly get from one page to the - ;next. If your printer can, setting PFFEED to TRUE will cause WordStar - ;to use form feeds instead of carriage returns and line feeds. - ; - -058D PFFEED:: -058D 00 DB FALSE ;Carriage returns to next page - - ; - ;Some users, like programmers, may want to usually print non-documents. - ;In this case, WordStar prints any lines that begin with a period (dot - ;commands), and expands tab characters (09H) according to the filetype - ;in the EDCOND table elsewhere in the User Area. - ; -058E PNODOC:: -058E 00 DB FALSE ;Don't print as a non-document - - ; - ;Printer protocol flags. Only one of these flags may be set TRUE at - ;one time. If neither flag is set, WordStar assumes all printer busy - ;handshaking is done externally to WordStar (requires ULISTA and ULSTI - ;subroutines below). - ; - -058F LXOFF:: ;Printer XON/XOFF protocol. -058F 00 DB FALSE - -0590 LETX:: ;Printer ETX/ACK protocol. -0590 00 DB FALSE - -0591 LCHRMX:: ;Maximum chars before sending ETX. -0591 80 DB 128 ;Half of buffer size. - - ; - ;User list device output subroutines are used if the normal systems list - ;device is not to be used. The user subroutine overrides the LSTDEV - ;selection below. - ; -0592 ULOSTA:: -0592 00 NOP ;User list output status subroutine. -0593 00 NOP ;Normally NOP, or JMP to your own -0594 C9 RET ;subroutine. Must return 0 in AL if - ;list device is busy, 0FFH if idle. - -0595 ULSTO:: -0595 00 NOP ;User list output subroutine. -0596 00 NOP ;Normally NOP, or JMP to your own -0597 C9 RET ;subroutine. Subroutine receives the - ;character in AL. - - ; - ;User list input subroutines are used if either XON/XOFF or ETX/ACK - ;protocols are used to indicate when the printer is busy. - ; -0598 ULISTA:: -0598 00 NOP ;User list input status subroutine. -0599 00 NOP ;Normally NOP, or JMP to your own -059A C9 RET ;subroutine if LXOFF or LETX is TRUE. - ;Must return 0 in AL if no char pending. - -059B ULSTI:: -059B 00 NOP ;User list input subroutine. -059C 00 NOP ;Normally NOP, or JMP to your own -059D C9 RET ;subroutine if LXOFF or LETX is TRUE. - ;Returns character in AL. - - ; - ;Printer Output Selection - ; - ;When WordStar prints, it sends its output to one of the devices specified - ;with LSTDEV. - ; - ; 00H = TTY device - ; 01H = CRT device - ; 02H = LPT device - ; 03H = UL1 device - ; FFH = Default LST device - ; -059E LSTDEV:: -059E FF DB 0FFH ;Use LST device - - ; - ;Before printing, WordStar will call ULPORT below to allow for custom - ;print output redirection. A pointer to the name of the printer (null - ;terminated, all capital letters) will be passed to the subroutine in HL. - ;It is up to this subroutine to then route the printer output to the - ;appropriate output port by whatever means is available to it. - ; - -059F ULPORT:: -059F 00 NOP ;Normally NOP if no redirection to be done. -05A0 00 NOP ;Change to JMP to your own subroutine. -05A1 C9 RET - - ; - ;The user list device uninitialize routine is called after printing is - ;completed, and can be used to restore the printer state for non-WordStar - ;applications. - ; - -05A2 ULUNPT:: -05A2 00 NOP -05A3 00 NOP -05A4 C9 RET - - ; - ;The ULINI string is sent to the list device after ULPORT is executed - ;and before the document is printed. - ; -05A5 ULINI:: ;User list device initialize string -05A5 00 DB 0 -05A6 00 00 00 00 DB 0,0,0,0,0,0,0,0,0 -05AA 00 00 00 00 -05AE 00 - ; - ;The ULUNI string is sent to the list device after the document is - ;printed and before the ULUNPT routine is executed. - ; -05AF ULUNI:: ;User list device uninitialize routine -05AF 00 DB 0 -05B0 00 00 00 00 DB 0,0,0,0,0,0,0,0,0 -05B4 00 00 00 00 -05B8 00 - - ; - ;When WordStar begins printing, space is allocated for the three header and - ;three footer lines. HFMAX determines how much space to allocate. - ; -05B9 HFMAX:: -05B9 0064 DW 100 ;Up to 100 characters per header or footer - - ; - ;DATSEP is used while merge printing to separate one data item from - ;another in the data file. - ; -05BB DATSEP:: ;Comma -05BB 2C DB ',' - - ; - ;DLIST is the list output delay. Every time a character is output to - ;the printer, this delay is used. - ; -05BC DLIST:: -05BC 00 DB 0 ;No delay - - ; - ;Custom Printer Control Strings: These strings are sent to the printer - ;when the custom print control characters, ^Q, ^W, ^E, or ^R are - ;encountered in text being printed. They can be used to invoke special - ;printer functions not controlled by the standard driver, such as expanded - ;or compressed modes of printing. - ; - ;Note that some drivers may interfere or override the custom print controls - ;you have defined. In this case, use a generic driver such as DRAFT or - ;CUSTOM. - ; - ;A fixed length of 25 bytes is reserved for each string, where the - ;first byte is the count of characters to be sent to the printer, and - ;the following bytes (up to 5) are the characters to be sent. If - ;longer strings are required, the first byte can be -1, followed by a - ;two byte address pointing into a patch area, where the actual count - ;and string can be found. - ; -05BD UPRCTL:: ;Custom Print Controls - -05BD 00 UPRQ:: DB 0 ;^Q, length -05BE 00 00 00 00 DB 0,0,0,0,0,0 ; string of up to 24 characters -05C2 00 00 -05C4 00 00 00 00 DB 0,0,0,0,0,0 -05C8 00 00 -05CA 00 00 00 00 DB 0,0,0,0,0,0 -05CE 00 00 -05D0 00 00 00 00 DB 0,0,0,0,0,0 -05D4 00 00 - ; -05D6 00 UPRW:: DB 0 ;^W -05D7 00 00 00 00 DB 0,0,0,0,0,0 -05DB 00 00 -05DD 00 00 00 00 DB 0,0,0,0,0,0 -05E1 00 00 -05E3 00 00 00 00 DB 0,0,0,0,0,0 -05E7 00 00 -05E9 00 00 00 00 DB 0,0,0,0,0,0 -05ED 00 00 - ; -05EF 00 UPRE:: DB 0 ;^E -05F0 00 00 00 00 DB 0,0,0,0,0,0 -05F4 00 00 -05F6 00 00 00 00 DB 0,0,0,0,0,0 -05FA 00 00 -05FC 00 00 00 00 DB 0,0,0,0,0,0 -0600 00 00 -0602 00 00 00 00 DB 0,0,0,0,0,0 -0606 00 00 - ; -0608 00 UPRR:: DB 0 ;^R -0609 00 00 00 00 DB 0,0,0,0,0,0 -060D 00 00 -060F 00 00 00 00 DB 0,0,0,0,0,0 -0613 00 00 -0615 00 00 00 00 DB 0,0,0,0,0,0 -0619 00 00 -061B 00 00 00 00 DB 0,0,0,0,0,0 -061F 00 00 - - ; - ;Strike-out character - ; -0621 STKCHR:: -0621 2D DB '-' ;Strike out character - ; - ;If PFFEED above is TRUE, or you specifically tell WordStar to use form feeds - ;during printing, the following string is sent to the printer to eject the - ;paper to the next page. All printer drivers use this string. - ; -0622 01 FORMF:: DB 1 ;^L -0623 0C DB FFEED -0624 00 00 00 00 DB 0,0,0,0,0 -0628 00 -0629 00 00 00 00 DB 0,0,0,0,0,0 -062D 00 00 -062F 00 00 00 00 DB 0,0,0,0,0,0 -0633 00 00 -0635 00 00 00 00 DB 0,0,0,0,0,0 -0639 00 00 - ; - ;This is 128 bytes set aside for printer subroutines. - ;This area is also used for print control strings for the CUSTOM - ;printer driver. - ; -063B PRNPAT:: -063B 0000 0000 DW 00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00 -063F 0000 0000 -0643 0000 0000 -0647 0000 0000 -064B 0000 0000 -064F 0000 0000 -0653 0000 0000 -0657 0000 0000 -065B 0000 0000 DW 00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00 -065F 0000 0000 -0663 0000 0000 -0667 0000 0000 -066B 0000 0000 -066F 0000 0000 -0673 0000 0000 -0677 0000 0000 -067B 0000 0000 DW 00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00 -067F 0000 0000 -0683 0000 0000 -0687 0000 0000 -068B 0000 0000 -068F 0000 0000 -0693 0000 0000 -0697 0000 0000 -069B 0000 0000 DW 00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00 -069F 0000 0000 -06A3 0000 0000 -06A7 0000 0000 -06AB 0000 0000 -06AF 0000 0000 -06B3 0000 0000 -06B7 0000 0000 - - ; - ;If non-standard initialization parameters are used, the - ;following identification string can be displayed at - ;sign-on. Up to 40 bytes are available for the string, - ;including the null terminator. - ; -06BB INITID:: -06BB 00 DB 0 ;No ID if standard -06BC 20 20 20 20 DB ' ' -06C0 20 20 20 20 -06C4 20 20 20 20 -06C8 20 20 20 20 -06CC 20 20 20 -06CF 20 20 20 20 DB ' ' -06D3 20 20 20 20 -06D7 20 20 20 20 -06DB 20 20 20 20 -06DF 20 20 20 20 - - ; - ;Legal Drives - ; - ;Note that the first drive is assumed to be the default drive where any - ;special files are located such as the WSMSGS.OVR file. The drives listed - ;should be reduced to the ones that are actually in use on the system - ;upon which WordStar is running. - ; - ;If the most significant bit of the drive letter is set to 1, WordStar - ;will assume that the drive is non-removable. A disk reset will not - ;be done when non-removable drives are logged. - ; -06E3 LGLDRV:: -06E3 41 42 43 44 DB 'ABCDEFGHIJKLMNOP',0 ;Every legal drive -06E7 45 46 47 48 -06EB 49 4A 4B 4C -06EF 4D 4E 4F 50 -06F3 00 - - ; - ;Legal User Numbers - ; - ;Some CP/M operating systems can support user numbers from 0 to 15, - ;others support 0 to 31. Also, a user can be prevented from accessing - ;other user numbers if zero. - ; -06F4 LGLUSR:: -06F4 10 DB 16 ;Sixteen user numbers from 0 to 15 - - ; - ;WordStar uses several files. Their names are specified here. WordStar - ;uses the following search pattern to try to find the file: - ; - ; 1. Look on the current drive and user. - ; 2. Default user (DEFUSR) on the current drive. - ; 3. Current user on the default drive. - ; 4. Default user on the default drive. - ; - ;If the drive byte of the filename is non-zero, it should be set to a - ;number 1 through 16 representing drives A through P respectively. In - ;this case, WordStar will look only on the specified drive and the - ;DEFUSR user number for the file. - ; -06F5 MSFILE:: ;Message file -06F5 00 57 53 4D DB 0,'WSMSGS OVR' -06F9 53 47 53 20 -06FD 20 4F 56 52 - -0701 HPFILE:: ;Help messages file -0701 00 57 53 48 DB 0,'WSHELP OVR' -0705 45 4C 50 20 -0709 20 4F 56 52 - -070D FF DB 0FFH ;Zero if never to search for help - -070E IXFILE:: ;Indexer exclusion word list filename -070E 00 57 53 49 DB 0,'WSINDEX XCL' -0712 4E 44 45 58 -0716 20 58 43 4C - -071A LDFILE:: ;Load file for overlays -071A 00 57 53 20 DB 0,'WS OVR' -071E 20 20 20 20 -0722 20 4F 56 52 - -0726 OVFILE:: ;Print driver overlays -0726 00 57 53 50 DB 0,'WSPRINT OVR' -072A 52 49 4E 54 -072E 20 4F 56 52 - -0732 WSFILE:: ;File containing WordStar (after running pgm) -0732 00 57 53 20 DB 0,'WS COM' -0736 20 20 20 20 -073A 20 43 4F 4D - -073E SHFILE:: ;Shorthand file -073E 00 57 53 53 DB 0,'WSSHORT OVR' -0742 48 4F 52 54 -0746 20 4F 56 52 - - ; - ;If WordStar does not find its own files (WS.COM, WS.OVR...) on the - ;logged user, it will look for them on the default user. - ; -074A DEFUSR:: -074A 00 DB 0 ;Default user number for system files - ;Set to 0-16 or 0-31 (depends on LGLUSR), - ; or -1 to defeat - - ; - ;When you use the S command at the Opening Menu, this is the spelling - ;check command that is used. If you want WordStar to prompt for the - ;document to be checked and then automatically append it to this command, - ;set SPFILE non-zero. - ; -074B 02 SPCMD:: DB 2 ;Five letters in command -074C 54 57 DB 'TW' ;Run The WORD Plus -074E 00 00 00 00 DB 0,0,0,0,0 ;Spare bytes for longer commands -0752 00 -0753 00 00 00 00 DB 0,0,0,0,0 -0757 00 - -0758 FF SPFILE::DB 0FFH ;Automatically ask - - ; - ;When you run a program at the Opening Menu, WordStar first tries to find - ;the COM file in the current drive and user, then in this drive and user. - ;The default is to look on drive A, user 0. - ; -0759 01 URUN:: DB 1 ;Drive code (0=disabled, 1=A, 2=B, ...) -075A 00 DB 0 ;User number - - ; - ;INILOG allows the user to specify a drive and user number for WordStar to - ;log onto at start up time. The first byte is a character count, the - ;following bytes (up to three) can contain a drive name (A-P) and user - ;number (0-31). - ; -075B INILOG:: -075B 00 DB 0 -075C 00 00 00 DB 0,0,0 - - ; - ;WordStar creates backup and temporary files. The following - ;are the file types to be used for them. - ; -075F BAKTYP:: ;Type for backup files -075F 42 41 4B DB 'BAK' - -0762 BFTYPE:: -0762 24 42 24 DB '$B$' ;File type of temporary file before memory - -0765 AFTYPE:: -0765 24 41 24 DB '$A$' ;File type of temporary file after memory - -0768 BLKTYP:: -0768 24 43 24 DB '$C$' ;Type for block move/copy buffer file - - ; - ;When the directory is displayed, file types from this table - ;are suppressed. Question marks may be used as wild cards to - ;match any character. - ; -076B NOTYPE:: ;File types to be ommitted from directories -076B 43 4F 4D DB 'COM' ;Command files -076E 4F 56 52 DB 'OVR' ;Overlays -0771 24 3F 24 DB '$?$' ;WordStar temporary files - -0774 00 00 00 DB 0,0,0 -0777 00 00 00 DB 0,0,0 -077A 00 00 00 DB 0,0,0 -077D 00 00 00 DB 0,0,0 -0780 00 00 00 DB 0,0,0 -0783 00 DB 0 ;End of table - - ; - ;DIRFIL is a file name "image" that is used in conjunction with NOTYPE (above) - ;to determine which files are to be displayed in WordStar's directories. - ;DIRFIL determines which files can possibly be included, and NOTYPE then - ;eliminates certain types of files. Use a question mark in DIRFIL at each - ;spot where any file name character can match. - ; -0784 DIRFIL:: -0784 3F 3F 3F 3F DB "???????????" ;All files match -0788 3F 3F 3F 3F -078C 3F 3F 3F - - ; - ;The name of the file to be edited can be specified at the operating system - ;prompt. ININON indicates whether the file should be edited as a document - ;or nondocument. - ; -078F ININON:: -078F 00 DB FALSE ;Not non-document from command line - - ; - ;WordStar normally makes BAK backup files every time you save your work. - ;INITBAK can be used to disable backups by setting it FALSE. - ; -0790 INIBAK:: -0790 FF DB TRUE ;Make backups - - ; - ;When a nondocument is edited, WordStar will decide how to expand tabs - ;(ASCII 09H), and whether or not to use auto-indenting by looking in this - ;table. - ; - ;There is a special case of the tab masks shown below. When the most - ;significant bit of the tab mask is set to 1, WordStar will assume that - ;you want to use variable tabbing. When the tab key is typed, instead - ;of inserting an ASCII 09H into the file, spaces will be entered up to - ;the next tab stop. The tab stops used are in the INIRLR table. An - ;ASCII 09H can still be entered in this mode, however, by typing ^PI. - ; -0791 EDCOND:: ;Edit conditions for specific file types -0791 50 41 53 01 DB 'PAS',00000001B,TRUE ;File extension, followed by a -0795 FF -0796 50 4C 49 03 DB 'PLI',00000011B,TRUE ;binary tab mask (e.g. a mask of -079A FF -079B 43 20 20 03 DB 'C ',00000011B,TRUE ;00000111B expands tab characters -079F FF -07A0 48 20 20 03 DB 'H ',00000011B,TRUE ;to every 8th column), followed by -07A4 FF - ;TRUE if auto-indent is turned on. - -07A5 00 00 00 07 DB 0,0,0,00000111B,FALSE ;End of table with defaults if file -07A9 00 - ;type doesn't match above - -07AA 00 00 00 00 DB 0,0,0,0,0 ;Room for four more -07AE 00 -07AF 00 00 00 00 DB 0,0,0,0,0 -07B3 00 -07B4 00 00 00 00 DB 0,0,0,0,0 -07B8 00 -07B9 00 00 00 00 DB 0,0,0,0,0 -07BD 00 - - ; - ;WordStar normally only considers alphabetic or numeric characters - ;as being within a "word". If other characters are legally part - ;or a word too, then the bit for the corresponding character code in - ;the following table must be set to a 1. - ; - ;There are 256 bits in the table to allow for 8-bit character sets. - ;The default table has the bits set for the numbers "0" through "9" - ;(ASCII codes of 30H through 39H), for the upper case letters - ;"A" through "Z" (41H through 5AH), and the lower case letters "a" - ;through "z" (61H through 7AH). Since the ASCII codes are only - ;seven bits, the corresponding codes with the eighth bit set are - ;also legal. - ; -07BE LGLCHR::; 01234567 89ABCDEF -07BE 00 00 DB 00000000B,00000000B ;Codes 00H to 0FH -07C0 00 00 DB 00000000B,00000000B ;Codes 10H to 1FH -07C2 00 00 DB 00000000B,00000000B ;Codes 20H to 2FH -07C4 00 00 DB 00000000B,00000000B ;Codes 30H to 3FH -07C6 7F FF DB 01111111B,11111111B ;Codes 40H to 4FH -07C8 FF E0 DB 11111111B,11100000B ;Codes 50H to 5FH -07CA 7F FF DB 01111111B,11111111B ;Codes 60H to 6FH -07CC FF E0 DB 11111111B,11100000B ;Codes 70H to 7FH -07CE 00 00 DB 00000000B,00000000B ;Codes 80H to 8FH -07D0 00 00 DB 00000000B,00000000B ;Codes 90H to 9FH -07D2 00 00 DB 00000000B,00000000B ;Codes A0H to AFH -07D4 00 00 DB 00000000B,00000000B ;Codes B0H to BFH -07D6 7F FF DB 01111111B,11111111B ;Codes C0H to CFH -07D8 FF E0 DB 11111111B,11100000B ;Codes D0H to DFH -07DA 7F FF DB 01111111B,11111111B ;Codes E0H to EFH -07DC FF E0 DB 11111111B,11100000B ;Codes F0H to FFH - - ; - ;When you use ^A or ^F to move a word at a time, WordStar uses the - ;following table to determine which characters to skip. It is organized - ;in the same manner as LGLCHR above. - ; -07DE MOVCHR::; 01234567 89ABCDEF -07DE FF 92 DB 11111111B,10010010B ;Codes 00H to 0FH -07E0 FB C3 DB 11111011B,11000011B ;Codes 10H to 1FH -07E2 3F F5 DB 00111111B,11110101B ;Codes 20H to 2FH -07E4 FF CE DB 11111111B,11001110B ;Codes 30H to 3FH -07E6 FF FF DB 11111111B,11111111B ;Codes 40H to 4FH -07E8 FF FF DB 11111111B,11111111B ;Codes 50H to 5FH -07EA FF FF DB 11111111B,11111111B ;Codes 60H to 6FH -07EC FF FE DB 11111111B,11111110B ;Codes 70H to 7FH -07EE FF 92 DB 11111111B,10010010B ;Codes 80H to 8FH -07F0 FB C3 DB 11111011B,11000011B ;Codes 90H to 9FH -07F2 3F F5 DB 00111111B,11110101B ;Codes A0H to AFH -07F4 FF CE DB 11111111B,11001110B ;Codes B0H to BFH -07F6 FF FF DB 11111111B,11111111B ;Codes C0H to CFH -07F8 FF FF DB 11111111B,11111111B ;Codes D0H to DFH -07FA FF FF DB 11111111B,11111111B ;Codes E0H to EFH -07FC FF FE DB 11111111B,11111110B ;Codes F0H to FFH - - ; - ;Certain special characters can be inserted into this table to cause - ;WordStar to automatically generate a backspace character (^H) preceding - ;the character as you type. This can be especially useful for accent - ;characters in some foreign languages. - ; -07FE AUTOBS:: ;Automatic backspace table -07FE 00 DB 0 ;Number of characters in table -07FF 00 00 00 00 DB 0,0,0,0 ;Up to 8 character codes -0803 00 00 00 00 DB 0,0,0,0 - - ; - ;When WordStar gets a file for editing, it will use the following - ;initial conditions. - ; -0807 INIDOC:: ;Document initializations - -0807 03 DB 3 ;Top of page margin. - -0808 08 DB 8 ;Bottom of page margin. - -0809 42 DB 66 ;Total lines per page. - -080A 0001 DW 1 ;Initial page number (note 2 bytes). - -080C FF DB TRUE ;Page number prints at bottom of page - ;if TRUE. No page number if FALSE. - -080D 1C DB 28 ;Column where page number prints. - -080E 02 DB 2 ;Heading margin. This is the number of lines - ;above the text where the heading is to print. - -080F 02 DB 2 ;Footing margin. This is the number of lines - ;below the text where the footing is to print. - -0810 07 DB 00000111B ;Default document tab mask (must be - ;binary, 00000000B through 01111111B). - -0811 08 DB 8 ;Left column where printing starts. - -0812 FF DB TRUE ;Bidirectional printing if TRUE. Just - ;unidirectional or printer controlled - ;if FALSE. (Many printers do not allow - ;software control of print direction). - -0813 FF DB TRUE ;Letter quality printing if TRUE. Draft - ;quality if FALSE. (Only supported on - ;some printers.) - -0814 02 DB 2 ;Microjustified printing. 0 turns it off, - ;1 turns it on, and 2 makes it discretionary - ;(depending on the printer driver in use). - -0815 00 DB FALSE ;Underline blanks between words if TRUE. - ;NOTE: Not implemented for all printers. - -0816 0C DB 12 ;Standard character width (in HMI units). - ;The printer is reset to this when done - ;printing. - -0817 08 DB 8 ;Standard line height (in VMI units). The - ;printer is reset to this after .LH dot - ;commands. It is also used to determine - ;the page size in VMI units by multiplying - ;by the lines per page above. - -0818 0C DB 12 ;Character width (in HMI units) - ;for normal pitch. If HMI is 120, ten pitch - ;is 12/120, twelve pitch is 10/120. - -0819 0A DB 10 ;Character width for alternate pitch (use - ;^PA to select alternate pitch while editing). - -081A 03 DB 3 ;Subscript and superscript roll (in VMI - ;units). This value determines how - ;far up or down the carriage moves when - ;subscripting or superscripting. - -081B 08 DB 8 ;Line height (in VMI units). This value - ;determines how far to roll the carriage - ;to get to the next line. - - ; - ;The default ruler line can be described by defining the following values. - ;Note that the tab stop tables must contain values in ascending order only. - ;The regular tab stops are put in the table first, immediately followed by - ;the decimal tabs. - ; -081C INIRLR:: ;Ruler data - -081C 01 DB 1 ;Left ruler margin - -081D 41 DB 65 ;Right ruler margin - -081E 00 DB 0 ;Paragraph margin - -081F 0B DB 11 ;Eleven tabs -0820 06 0B 10 15 DB 6,11,16,21 ;Tab stops -0824 1A 1F 24 29 DB 26,31,36,41 ;(Must be in -0828 2E 33 38 DB 46,51,56 ;ascending order) -082B 00 00 00 00 DB 0,0,0,0 ;Space for 4 more - -082F 00 DB 0 ;No decimal tabs -0830 00 00 00 00 DB 0,0,0,0,0,0 ;Space for 6 -0834 00 00 - -002F inisiz EQU $-INIDOC ;Size of document initialization - - ; - ;INIRLI determines whether the ruler line is re-initialized from INIRLR each - ;time any document is edited. If INIRLI is FALSE, you can change the initial - ;ruler line with ^OL, ^OR, ^OI, and ^ON commands, and have those changes - ;be used for every document edited until you exit WordStar. - ; -0836 INIRLI:: -0836 FF DB TRUE ;Initialize ruler for each document - - ; - ;As you move through a document, WordStar executes some of the dot commands, - ;like .RR ruler line commands, as they are encountered. As WordStar moves - ;forward through the text, the old ruler line is stored in memory so that it - ;can be restored when you move backwards over the .RR later. Other dot - ;commands work in a similar manner. - ; - ;DSTKSZ is used to allocate storage for the dot commands. While you are - ;editing, WordStar puts a Dot-Limit indicator in the status line if you - ;use too many dot commands. - ; - ; Dot Command Size - ; .RR 26 - ; .RM .LM .LH .PL 1 - ; .MT .MB 1 - ; .PN 2 - ; -0837 DSTKSZ:: -0837 01F4 DW 500 ;Room for 19 .RR commands or 500 .RM & .LM - - ; - ;INIDIR determines whether the directory is initially displayed or not. - ;DIRSRT tells WordStar whether or not to sort directories in alphabetical - ;order before displaying them. - ; - -0839 INIDIR:: -0839 FF DB TRUE ;Directory on - -083A DIRSRT:: -083A FF DB TRUE ;Sort directory in alphabetical order - - ; - ;INIHLP is the default help level. It can have a value from 0 to 3. - ; - -083B INIHLP:: -083B 03 DB 3 ;Maximum help level at start - - ; - ;When editing, the last erasure can be undone with ^U. UNONE determines - ;whether single character erasures with ^G and DEL can also be undone. - ; - ;UNSIZE is the maximum erasure that can later be undone. The unerase - ;buffer shares the same memory space as the text you are editing. Making - ;UNSIZE very large may cause WordStar to "spill over" to disk more - ;frequently, slowing down editing. - ; -083C UNONE:: ;Don't unerase single characters -083C 00 DB FALSE - -083D UNSIZE:: -083D 01F4 DW 500 ;Maximum unerase size - - ; - ;VMSIZE indicates the number of 128-byte records that can be read from - ;the disk for WordStar's messages and menus. - ; -083F VMSIZE:: -083F 04 DB 4 ;Four records (.5k byte) - - ; - ;EDSIZE indicates the minimum number of records of edit buffer required - ;to edit a document properly. WordStar must be able to keep a whole - ;page in memory to determine page breaks and line numbers correctly. - ;Less memory can sometimes be used with occasional strange results. - ;(Non-documents are automatically allocated a minimum of 6 records.) - ; -0840 EDSIZE:: -0840 1C DB 28 ;Enough memory for an average full page - - ; - ;BFSIZE is the number of 128-byte records that WordStar uses for its - ;general purpose buffer. There is a different buffer allocation for - ;editing, the Opening Menu, and for merge printing. - ; - ;This buffer is used for: - ; - ; - File directories (each file uses 11 bytes), - ; - Printer driver directory (each driver uses 11 bytes and 256 - ; bytes are used for buffering), - ; - File copies, - ; - Block reads and writes, - ; - Merge printing. - ; -0841 BFSIZE:: -0841 10 DB 16 ;Edit buffer size (16 records = 2k) - ;(Minimum is 1 record) - -0842 10 DB 16 ;Opening menu buffer size - ;(Minimum is 3 records) - -0843 10 DB 16 ;Merge print buffer size - ;(Minimum is 1 record) - - ; - ;If a document becomes too large to fit in memory at one time, WordStar - ;begins to "spill" the excess to the disk. TYSIZE determines how many - ;128-bytes records to use for each spillover. Picking a correct size - ;is important but can usually be done by trial and error. If TYSIZE is - ;too large, you may see long delays during scrolling or typing when memory - ;fills. - ; -0844 TYSIZE:: -0844 10 DB 16 ;Number records read or stored while typing - -0845 00 00 00 00 DB 0,0,0,0 ;Reserved - - ; - ;A "find" or "find and replace" uses the INIFIN options if you do not - ;explicitly enter any at the "Options?" prompt. The possible options - ;that can be used are: - ; - ; W whole words only - ; U ignore case - ; B backwards search - ; G whole file - ; R rest of file - ; N replace without asking - ; - ;Blank the unused options. - ; -0849 INIFIN:: -0849 20 20 20 20 DB ' ' ;No options -084D 20 20 - - ; - ;The status line is usually displayed at the top of the screen. - ;INISTA lets you always turn it off. STFILL specifies what character - ;to use to fill unused space in the status line. - ; -084F INISTA:: -084F FF DB TRUE ;Display status line - -0850 STFILL:: -0850 20 DB ' ' ;Fill with blanks - - ; - ;When paragraphs are aligned with ^B or ^QU and hyphen help is on, HYMAX - ;is used to determine when to ask the user to hyphenate a word. - ; -0851 HYMAX:: -0851 05 DB 5 ;Ask user when the word extends more than 5 - ;characters past the right margin - - ; - ;When WordStar asks a question that requires a Y for yes or N for no response, - ;YNCR indicates whether or not the user must push the RETURN key before - ;WordStar will accept it. - ; -0852 YNCR:: -0852 00 DB FALSE ;Don't wait for RETURN key - - ; - ;WordStar can index every word in a document as well as selected words and - ;phrases. IDXALL determines whether this is the default or not. - ; -0853 IDXALL:: -0853 00 DB FALSE ;Don't index every word - - ; - ;Using ^B or ^QU in a nondocument normally strips the eighth bit from - ;each character in a line. STRPFL can disable stripping. - ; -0854 STRPFL:: -0854 FF DB TRUE ;Stripping is enabled - ; - ;Editor Entry Conditions - ; -0855 INIEDT:: -0855 FF DB TRUE ;Right justification when typing -0856 FF DB TRUE ;Word wrap when typing at end of line -0857 FF DB TRUE ;Insert on -0858 FF DB TRUE ;Print controls displayed -0859 00 DB FALSE ;No hyphen help -085A FF DB TRUE ;Ruler displayed -085B 00 DB FALSE ;Block column mode off -085C 00 DB FALSE ;Block column replace mode off -085D 01 DB 1 ;Single spacing -085E 02 DB 2 ;Scrolling speed -085F 00 DB FALSE ;Proportional spacing off -0860 00 DB FALSE ;Soft space not displayed - -0861 00 00 00 DB 0,0,0 ;Reserved - ; -000F iniesz EQU $-INIEDT ;Size of editor conditions - - ; - ;The following are special characters that affect how numbers are - ;evaluated and dispayed. - ; -0864 COMCHR:: -0864 2C DB ',' ;Comma to separate 1,000's - -0865 DECCHR:: -0865 2E DB '.' ;Decimal point - - ; - ;The following flags are used to control the way WordStar processes - ;certain commands. CTLNFL and CTLHFL are provided primarily to allow - ;WordStar 3.3 users to use ^N and ^H in the same way as they are accustomed. - ; -0866 CTLNFL:: -0866 FF DB TRUE ;Set non-zero if ^N to break line and - ;RETURN moves down a line when insert off. - ;Set to zero so ^N converts paragraph lines - ;and turns auto indent on/off for - ;nondocuments, and RETURN always inserts CRLF. - -0867 CTLHFL:: -0867 00 DB 0 ;Set non-zero if ^H to be same as ^S instead - ;of DEL. - -0868 CASEFL:: -0868 00 DB 0 ;Set non-zero if ^^ is case toggle. When - ;zero and CLTNFL is non-zero, use as - ;paragraph line and auto-indent on/off. - -0869 DELFLG:: -0869 00 DB 0 ;Set non-zero if DEL erases to left, zero - ;to erase to right (like ^G). - -086A BLKFLG:: -086A FF DB 0FFH ;Set non-zero if the cursor should move - ;to column 1 if the cursor is next to a block - ;marker at the left edge of the screen - -086B LSPFLG:: -086B 00 DB 0 ;Set non-zero if lines with soft carriage - ;returns should not be added to paragraphs - ;for line spacing other than 1 - - ; - ;RLRVID allows the user to select video attributes used to highlight - ;the ruler line. See VIDATT for bit definitions. - ; -086C RLRVID:: -086C 00 DB 0 ;No ruler highlighting - - ; - ;AHEAD indicates whether type ahead is allowed for ^E, ^X, ^W, ^Z, - ;^G, DEL, ^T, ^Y, ^QY, and ^QDEL. If AHEAD is 0, WordStar's type - ;ahead buffer will be flushed whenever one of the functions is - ;encountered. If it is non-zero, no flushing will occur. This - ;flag should be used primarily for external keyboard enhancers where - ;the functions shown above are to be used. WordStar's function key - ;and shorthand processing automatically compensate. - ; -086D AHEAD:: -086D 00 DB 0 ;Flush - - ; - ;Maximum size for the shorthand definitions. Should be optimized to - ;match actual usage since it reduces the amount of memory available - ;for text while editing and printing. The size of each definition - ;is equal to 5 plus the number of characters defined. If this value - ;is smaller than the size of the shorthand file (see SVFILE above), - ;only some of the definitions will be used. Setting it to zero - ;disables shorthand and makes the ESC key clear the screen instead. - ; -086E HANMAX:: -086E 04 DB 4 ;Size of shorthand buffer in records - ;(4 times 128 = 512 bytes) - - ; - ;With shorthand you can insert the dollar-formatted results of the last - ;math you performed. WordStar uses the format below when you do this. - ;(Make sure that the character count includes the zero at the end.) - ; -086F DOLLAR:: -086F 11 DB 17 ;Character count -0870 2D 2D 2C 2D DB '--,---,---,---.99' -0874 2D 2D 2C 2D -0878 2D 2D 2C 2D -087C 2D 2D 2E 39 -0880 39 -0881 00 00 00 DB 0,0,0 ;Spare - -0884 00 00 00 00 DB 0,0,0,0,0,0,0,0 ;Reserved -0888 00 00 00 00 -088C 00 00 00 00 DB 0,0,0,0,0,0,0,0 -0890 00 00 00 00 - - ; - ;EXTRA is a large buffer area for general patching. Some versions of - ;the WINSTALL installation program use EXTRA. Whenever EXTRA is used, - ;RAM1ST must be changed to point to the first available byte within EXTRA - ;that is still available for WordStar's use. If all of EXTRA is used, - ;RAM1ST should point to endpat. - ; -0894 RAM1ST:: -0894 0896 DW EXTRA ;First location in EXTRA that WordStar can use - ; -0896 EXTRA:: DS 512 ;Patch area -0A96 endpat:: ;End of patch area - - -0A96 08 0C 57 UDATE: DB 08,12,87 ;User area version date - - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/PRINT.TST b/software/CPM/CPM30_WORDSTAR_v400/PRINT.TST deleted file mode 100644 index b8dc204..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/PRINT.TST +++ /dev/null @@ -1,143 +0,0 @@ -.hePRINT.TST Features of Your Printer -.f1 WordStar -.f2 Print test -.f3 Page # -.oj on - WordStaò anä Youò Printer - -WordStar‚  workó  witè á widå rangå oæ printeró anä offeró  yoõ  á -varietù oæ prinô enhancements® Whetheò youò printeò caî producå -thå  prinô enhancementó outlineä iî thió documenô dependó oî  itó -capabilities®   Pleaså notå thaô noô alì printeró arå capablå  oæ -showinç alì thå exampleó below. - -Speciaì Printinç Capabilities - -WordStaò supportó thå followinç speciaì printinç capabilities: - - ª Boldface¬ Doublå strike - * Italics/Alternatå ribboî color - * Strikå out - * Overprinô (aó iî co^te) - * Noncontinuouó underline¬ anä -.ul on - * Continuouó underline -.ul off - - * SuperScript¬ SubScript - - * anä almosô anù combinatioî -­ WordStar - -Characteò Width - -Somå  printeró  wilì  supporô  WordStar‚  commandó  foò   variablå -characteò widths® - -.cw 24 -µ characteró peò inch® (.C× 24) -.cw 20 -¶ characteró peò inch® (.C× 20) -.cw 14 -8.¶ characteró peò inch® (.C× 14) -.cw 12 -1° characteró peò inch® (.C× 12) -.cw 10 -1² characteró peò inch® (.C× 10) -.cw 7 -17.± characteró peò inch® (.C× 7) -.cw 12 - -Youò printeò caî alsï bå seô tï "toggle¢ betweeî normaì pitcè anä -alternatå pitch: - -     Thió  sentencå ió printeä witè thå normaì 1°-pitcè  setting¬ -     theî toggleä tï 1² pitch¬ theî bacë tï normal. -.cw 7 - -Yoõ caî alsï changå thå normaì anä alternatå characteò widths: - -.cw 14 -.rm 55 -     Thå  "normal¢ characteò widtè ió 1´ (8.¶ cpi©  anä -     thå alternatå characteò widtè ió · (17.± cpi). -.pa Š.rm 65 -.cw 10 - -.cw 12 -Linå Height - -Yoõ caî alsï uså differenô linå heights. - -.lh 16 -Thió ió aî examplå oæ variablå linå height® (.LÈ 1¶ ­ ³ lpi) -.lh 12 -Thió ió aî examplå oæ variablå linå height® (.LÈ 1² ­ ´ lpi) -.lh 8 -Thió ió aî examplå oæ variablå linå height® (.LÈ ¸ ­ ¶ lpi) -.lh 6 -Thió ió aî examplå oæ variablå linå heighô® (.LÈ ¶ ­ ¸ lpi) -.lh 8 - -Proportionaì Printing - -.ps on -.uj on -WordStar‚  alsï supportó proportionaì printinç foò  mosô  printeró -thaô  havå  it®   Yoõ  selecô  proportionaì  fontó  bù   changinç -characteò widthó aó iî thå followinç examples: - -.cw 22 -Thió ió characteò widtè 22. -.cw 11 -Thió ió characteò widtè 11. -.cw 9 -Thió ió characteò widtè 9. -.cw 7 -Thió ió characteò widtè 7. -.uj dis -.ps off -.cw 12 - -Other - -Phantoí Spacå¬ Phantoí Rubout - -WordStaò maù allo÷ yoõ tï prinô speciaì characteró (foò  example¬ -á  paragrapè  sigî  oò centó sign© bù  usinç  thå  phantoí  spacå -commanä (^PF© oò thå phantoí rubouô commanä (^PG© iî á  document® -Foò  youò  printer¬ thå phantoí spacå characteò isº  ¬  anä  thå -phantoí rubouô characteò isº . - -Switchinç tï Drafô Mode - -.lq off -Doô matriø printeò driveró allo÷ switchinç froí NLÑ (neaò  letteò -quality© modå tï drafô modå foò fasteò printing. -.lq on - -Microspacå Justification - -.uj on -WordStar‚   allowó  microspacå  justification¬  iæ  youò   printeò -supportó  it¬ tï producå evenlù spaceä wordó iî  justifieä  text® -Microspacinç spreadó thå whitå spacå betweeî wordó (anä sometimeó -betweeî thå letteró oæ eacè word© aó evenlù aó possible® -.uj dis -.pa ŠLookinç Aô Thió Filå Onscreen - -Iæ  yoõ wanô tï seå thå embeddeä commandó thaô produceä thå  texô -yoõ arå no÷ reading¬ follo÷ theså steps: - -1 Aô thå Openinç Menu¬ presó D‚ tï ediô á document. - -² Aô thå prompô foò filename¬ typå print.tsô anä presó Enter. - -Noticå thaô thå texô onscreeî includeó somå characteró thaô don'ô -appeaò  iî  thå  printeä copy® Foò example¬ á  headinç  linå  ió -identifieä  bù  thå  doô  commanä .he®   Wordó  iî  boldfacå  arå -surroundeä bù ^ anä appeaò eitheò highlighteä oò iî á  differenô -coloò oî youò screen. - -Tï continuå viewinç thå contentó oæ thió file¬ ¬ presó ^C® Presó -^R‚ tï movå iî thå otheò direction. - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/READ.ME b/software/CPM/CPM30_WORDSTAR_v400/READ.ME deleted file mode 100644 index 3f1cf90..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/READ.ME +++ /dev/null @@ -1,2141 +0,0 @@ - --THE README FILE-- - ------------------------ - -README contains late-breaking news and tips about WordStar, -and information about printers. - - -THE DISKS THAT CAME IN YOUR PACKAGE ------------------------------------ - -The file HOMONYMS.TXT is included on the Speller disk -contrary to what is listed in Appendix D. - - -INSTALLATION ------------- - -WINSTALL and WSCHANGE - - WordStar has two installation programs: - - o WINSTALL contains the basic choices to install WordStar. - It is recommended for all users. - - Be sure and install your valid disk drives since WordStar - running under CP/M cannot recover from attempts to access non- - existent disk drives. - - o WSCHANGE contains every installation and customization - choice. It is designed for advanced users and users who - want to customize WordStar after they're familiar with it. - Use the menu listing below for a directory of the menus - in WSCHANGE. - -Directory of WSCHANGE Menus - - The chart below shows the organization of menus in WSCHANGE. - Print it out and refer to it as you customize WordStar. - - Main Installation Menu - - A Console - A Monitor - A Monitor selection - B Monitor name - C Screen sizing - B Function keys - C Monitor patches - A Special characters - B Cursor control - C Screen control - D Keyboard patches - A Function keys - B Save function keys - E Interface patches - A Console busy handshaking - B Special I/O subroutines - B Printer - A Printer choices - A Printer selection - B Printer name - C Default printer driver - B Printer driver library - A Select library file - B Create smaller library - C Add new printer driver - D Change printer driver data - C WS printer patches - A Custom print controls, printer initialization - - NOTE: Disregard the "CUSTOM & SIMPLE Controls Save CUSTOM/SIMPLE - Controls" option shown. This is not available from this menu. - - D Printing defaults - E Printer interface - A Printer port selection - B Printer busy handshaking - C Printer subroutines - C Computer - A Disk drives - A Valid disk drives - B Maximum valid user number - C Delay disk access if typing - B Operating system - A Single-user system - B Multi-user MP/M - C Multi-user Turbo DOS - D ZCPR3 - C Memory usage - D WordStar files - E Directory display - F Computer patches - D WordStar - A Page layout - A Page sizing & margins - B Headers & footers - C Tabs - B Editing settings - A Edit screen & help level - B Typing - C Paragraph alignment - D Blocks - E Erase & unerase - F Lines & characters - G Find & replace - H WordStar 3.3 compatibility - I Printing defaults - C Other features - A Spelling checks - B Nondocument mode - C Indexing - D Shorthand (key macros) - E Merge printing - F Miscellaneous - E Patching - A Auto patcher - B Save settings - C Reset all settings - -MEMORY USAGE ------------- - - WordStar requires a minimum TPA size of 50 kbytes to run - using the factory defaults. The TPA is the amount of memory - available in your computer for use by programs that have a - file type of COM. To see how big the TPA is in your computer, - press the question mark key (?) at the Opening Menu. - - The amount of memory required by WordStar can be reduced by - approximately 3 kbytes if necessary. Use the WSCHANGE program - to select the minimum memory configuration option. The menu - will show you what capabilities are being reduced. - - WordStar uses a general-purpose buffer for a variety of - tasks. WordStar allocates memory to this buffer for editing, - for merge printing, and at the Opening Menu (see BFSIZE in - PATCH.LST). The buffer used for editing is usually the most - sensitive to a reduced TPA size. (You may be able to use the - Opening Menu and print, but there may be insufficient memory - for editing.) - - The merge print buffer is used only to hold merge print - variable names and data. Increase it if you run out of memory - while merge printing. - - The Opening Menu buffer is used primarily to hold the file - directory, and for miscellaneous tasks. - - -LOW-MEMORY INDICATOR IN STATUS LINE ------------------------------------ - - If the Low-Memory indicator appears in the status line, it - means that WordStar was unable to complete some function. - The most common symptoms are: the line number in the - status line is wrong, or a paragraph alignment could not be - completed. You may correct the line counter by saving your - file, exiting WordStar, and re-loading your file. To correct - the paragraph alignment, move your cursor to the point where - paragraph alignment stopped, and then press ^B again. - - The reason this comes up is that WordStar was not able to fit - a big enough chunk of text into memory at one time. - - When you first begin editing, WordStar uses the value from - EDSIZE in the user area to determine the minimum amount - of memory required for a page of text. The default - is set for approximately a 55 line by 66 column page. If - your page size is routinely larger than this, you may want - to increase EDSIZE. Multiply the number of lines by the - number of columns, and divide by 128. - - If the Low-Memory indicator comes on while printing, it is due - to either the same reasons as for editing, or there is - insufficient memory to print the text proportionally spaced. - The amount of memory required depends on which printer - driver you are using. If you aren't using the .PS ON dot - command to turn proportional spacing on in your document, - low memory won't be a problem. Also, WordStar uses more - memory for merge printing than it does for regular printing - (around 2.5 kbytes more). - - The Low-Memory indicator will also appear when a full disk error - is encountered during editing. Treat the disk-full error as you - would normally. - - -RAM-RESIDENT PROGRAMS ---------------------- - - RAM-resident programs, such as SmartKey, reduce the amount of - working memory (TPA) that WordStar can use. The new features in - WordStar, such as shorthand, may reduce the need for these - RAM-resident programs, thus freeing memory for WordStar. - - -ZCPR3 SUPPORT -------------- - - In order to enable the ZCPR facilities within WordStar, the user - must use the Z3INS utility provided with ZCPR to install the - address of the ZCPR "environment" into WordStar. The environment - contains information that WordStar uses to support ZCPR-specific - functions. - - Generally, the user should log onto the drive containing the file - WS.COM, and issue the command: - - Z3INS SYS.ENV WS.COM - - The user should also run either WINSTALL or WSCHANGE to further - install WordStar for ZCPR. However, this is not mandatory because - the only thing that happens is that the WordStar sign-on says - "ZCPR3," and the LGLUSR location in the user area is changed for a - maximum user number of 31. (The normal default for LGLUSR is 15.) - - Once the user has installed WordStar for use with ZCPR, the user - will be able to use the following ZCPR features: - - - A named directory may be used when logging onto a new drive/user. - - - A named directory may be used instead of a drive/user as part - of any file name. - - - The drive/user always appears above file directories. (For CP/M - only the drive letter is shown if the user number is zero.) - - - The directory name also appears above the directory if one has - been defined for the currently logged drive/user. - - - If WordStar does not find its OVR files on the current drive and - user, it will search the drives and user numbers in the ZCPR - search path rather than using its standard search pattern. - - - WordStar installs itself as a ZCPR "shell" process which lets the - user enter any legal ZCPR command when running a program. (CP/M - can only run programs that are COM files.) - - -OSBORNE USERS -------------- - - The command to change a hard carriage return to a soft carriage - return (document mode) or to turn Auto-indent ON (nondocument - mode) does not function on the Osborne because of a limitation - in its BIOS. The following patch can be applied to change the - command from ^^ to ^- (Ctrl-Hyphen): - - Using DDT or SID in the file WSMSGS.OVR: - - At 02DA replace 1E with a 1D - At 02EF replace 1E with a 1D - At 0359 replace 1E with a 1D - At 06B2 replace 1E with a 1D - At 06C9 replace 1E with a 1D - - At the system prompt type SAVE 53 WSMSGS.OVR - - For more information on how to use SID or DDT, see your CP/M - reference guide. As always, be sure and apply the patch to a - COPY of the file. - - -INSTRUCTIONS FOR TWO FLOPPY DISK COMPUTERS ------------------------------------------- - - Do not remove the Program disk while you are using WordStar. - - The Printer Driver Library file (WSPRINT.OVR) on the WordStar - program disk is much smaller than the Printer Driver Library - file contained on the disk labeled PRINTER. Be sure to read the - section in "Starting" that discusses the printer library file. - - -RUN A PROGRAM -------------- - - Once you press R you can type the drive and user number for the - program you want to run. You may run only .COM files. CCP commands, - such as DIR cannot be used. - - -INDEXING --------- - -Using StarIndex - - StarIndex 1.01 works with files created with this release of - WordStar. - -"Can't Use That Printer" Message - - When WordStar creates an index or table of contents, it uses - the printer drivers $INDEX and $TOC. If you created a smaller - WSPRINT.OVR file, you may have left these drivers out. To - return them to the file, copy the original WSPRINT.OVR file - onto your disk. When you create a smaller file again, be sure - to save these drivers. See Appendix C in the WordStar manual - for a list of other drivers to save. - - -SPELL CHECKING --------------- - - Dual floppy disk users: - - Unless you have sufficient room on your working WordStar program - disk for the files TW.COM, SPELL.COM, MARKFIX.COM, REVIEW.COM and - MAINDICT.CMP you will not be able to run a spell check from the - Opening Menu. You will need to exit WordStar and replace the - working WordStar program disk with the dictionary disk you created - during installation. This disk should contain the files listed - above. Make sure the disk in drive B has the file you want to - spell-check. - - Follow the directions for running a spell check in The WORD Plus - manual. - - -UPGRADING FROM A PREVIOUS RELEASE ---------------------------------- - - This release of WordStar contains many new features and commands. - See the "What's New" booklet for a complete list. The following - changes came in too late to be included in the documentation. - -Printer Patches - - Previous versions of WordStar treat most dot matrix printers - and other non-daisy wheel printers as a DRAFT printer with a - few patchable items. Because of this, many users have used - these patches to be able to use certain features of their - printers. Sometimes the patches have been quite extensive, and - some users have many files that count on them. - - The printer drivers of WordStar Release 4, on the other hand, - are very powerful. Almost every driver recognizes all the print - controls and all the dot commands. In fact, if a document is - written to be printed on one kind of printer, it is likely that - it will also print fine on some other printer. - - However, if you want to use your existing files with WordStar - 4, and those files rely on the user area being patched in a - special way, you can probably do so by moving the patches into - WordStar 4, and using the CUSTOM or SIMPLE printer driver. - - On the INSTALL disk is a program called MOVEPRN.COM that - copies the printer driver portion of the previous release's - user area into files that can be installed into Release 4 with - the "auto patcher" feature. - - Copy the program MOVEPRN.COM onto the disk containing the - WS.COM file for the previous version. Type - - MOVEPRN WS.COM FILE1.PAT FILE2.PAT - - MOVEPRN extracts the proper portions of the user area and - writes them into two files that may then be used with the "auto - patcher" feature of WSCHANGE. - - FILE1.PAT is to be used with the general patching menu - (Choose E "Patching" on the WSCHANGE Main Menu, then A "Auto - Patcher"). FILE2.PAT should be used to install strings first - into the SIMPLE driver, and then into the CUSTOM driver (choose - B "Printer" on the WSCHANGE Main Menu, then B "Printer driver - library", D "Change printer driver data" and D "Driver auto - patcher"). - - Test print your document first with the SIMPLE driver, and then - with the CUSTOM driver to see which one produces the most - satisfactory results. - - Also read Appendix C for more information on using the Auto - Patcher. - - -Hanging Indents - - For WordStar Professional Release 4, MailMerge reformats indented - text created with ^OG to the current margins. If you want the text - to remain indented, use embedded ruler lines or the .RM, .LM, - and .PM commands. See the "Reference Guide" for more information. - - Pressing ^OG to wrap back to the first tab on the ruler line after - having reached the last tab works the same way it did in previous - versions of WordStar, contrary to what is stated in the manual. - - -TERMINALS ---------- - - WordStar comes installed for an "idealized" special terminal. - WINSTALL and WSCHANGE allow you to install many terminals by - name, thus allowing WordStar to take advantage of the special - features that the terminal might support, such as underlining - or the function keys. - - Use either WINSTALL or WSCHANGE to pick your specific terminal - or computer screen from the Monitor menu. If your terminal - isn't on the menu, it probably emulates one of those that is - there. Look in your terminal documentation to find out. - - After you install WordStar for the proper terminal, run - WordStar and open the file PRINT.TST to see which attributes - (such as bold and underline) work on your screen. - WordStar will highlight the following in some way... - - Bold (^PB) - Underline (^PS) - Strike-out (^PX) - Subscript (^PV) - Superscript (^PT) - Doublestrike (^PD) - Italics (^PY) - Blocks (^KB, ^KK) - Error messages - - Most of the time, normal text will be shown in dim intensity, - and highlighted text will be shown in bright intensity. You - may have to use a brightness and/or contrast knob to adjust - your screen the first time you use WordStar this way. - - If your dim intensity is too dim to see well, and you can't - adjust it, you can change the BRITE flag to ON using WSCHANGE. - This will invert bright and dim in your text, so that regular - text is displayed bright, and highlighted text will be - displayed as dim. However, text in the menus is not affected. - - -DISPLAY PROBLEMS WITH TERMINALS -------------------------------- - - Once you have installed WordStar for the proper terminal, you - may still experience display problems. - - If text from the previous screen remains after WordStar - displays a new screenful of text, the most likely cause is - cursor wrap. Basically, WordStar must know what happens to the - cursor when a character is displayed at the rightmost position - of the screen. It can either remain at the right edge, or it - can wrap to the beginning of the next line. The WRAP flag in - WordStar must be set either on or off to correspond to the - way the terminal works. (It is generally set for the - terminal's factory default, but the default can usually be - changed using the terminal's setup mode.) - - Another possible cause for display problems is your terminal's - incomplete emulation of some other terminal. The most - common differences are... - - Line insert (LININS), line delete (LINDEL), - Erase to end of screen (ERAEOS), - Erase to end of line (ERAEOL), - And, erase screen (ERASCR). - - Look in the manual for your terminal and use WSCHANGE to see - if the control sequences match. - - -PRINTERS --------- - -WHAT'S IN THIS SECTION - - This section contains the following information: - - Choosing a Printer - Setting Up Your Printer - Printer Drivers - Proportional Printing - Laser Printers - Information on Specific Printers - -CHOOSING A PRINTER - - WordStar is ready to work with over 100 printers. The printer you - choose during installation becomes your default printer. However, - when you print a document, you can choose any other printer. To - choose a default printer, follow these steps: - - 1. Look at the Printer Information brochure that came in your - package. The first chart shows the printers listed on the - Printer Selection Menus. If your printer is on the menu, - simply choose it during installation. - - 2. If your printer isn't listed on the menu, it may work like a - printer that is. Refer to the second chart in the Printer - Information brochure for a list of printers that work like - printers on the menu. When WordStar asks you to choose a - printer, choose the printer that works like yours. - - 3. If neither chart lists your printer, choose Typewriter Printer - (if your printer can backspace) or Draft Printer (if it can't). - These choices may not take advantage of all your printer's - features, but they will work with almost any printer. - - Note: If you choose Draft or Typewriter, you can modify custom - print controls and printer initialization. - - If you want to make more modifications to take advantage of your - printer's feature, choose the Custom or Simple drivers, then use - the WS Printer Patches section of WSCHANGE to tell WordStar the - codes for your printer. Refer to your printer manual for these - codes. Some printers work better with the Custom driver and some - with the Simple driver. Try using both and see which works better - with your printer. See the "Reference Guide" for more information. - -SETTING UP YOUR PRINTER - -Choosing a Printer Port - - Each printer is connected to a printer port at the back of - the computer. WordStar looks for printers on the LST: port. - If your printer is connected to a different port, use - WSCHANGE to tell WordStar the correct port. - -Testing Your Printer Connection - - At the operating system prompt, type "PIP LST:=READ.ME." This - file should be printed by your printer. If it is not, your printer - may be connected to a different port. See your computer reference - manual, and the section on the STAT command in your CP/M - reference manual for more information. - - -PRINTER DRIVERS - - The WSPRINT.OVR file on the Printers disk contains a printer - driver for each printer on the Printer Selection Menu. The printer - driver for a printer contains all the codes WordStar needs to work - with that printer. - - Each printer driver has a short name. If you choose a printer when - you print a document, you see the names of the printer drivers, not - the names of the printers. - -PROPORTIONAL PRINTING - - WordStar supports proportional printing on a number of printers. - To turn on proportional printing, either install WordStar to - default to proportional printing, or place a ".PS on" command - in your document. At print time, WordStar selects the - appropriate proportional font based on the character width - (.CW) currently in effect. - - The specific printer descriptions later in this section show - recommended character widths for proportional typefaces. - These widths are for a normal mix of upper- and lowercase - letters. If you have many words or phrases all in uppercase - or if you want your text less densely printed, choose a larger - character width. - - While WordStar mostly sets character widths based on the - proportional-width table in the driver, on the more advanced - daisy wheel printers, WordStar uses the printer's proportional- - spacing mode. WordStar determines how much white space is needed - to right-justify the line based on its own proportional width - tables. If the table values don't match the wheel installed, - WordStar won't be able to justify the line correctly. - - WordStar sends standard ASCII characters; if a proportional wheel - uses a different spoke mapping, set up the printer to handle this. - -LASER PRINTERS - - WordStar supports laser printer features such as font changes - and proportional spacing. - - WordStar supports several laser printers: the Canon LPB-8 A1 & A2; - the Hewlett-Packard LaserJet, LaserJet+, and LaserJet 500+; - and the Ricoh LP4080. Refer to the "Specific Printer - Information" section of this file for information on these - printers. General notes about using laser printers are given below. - -Paper Size and Margins - - Laser printers come with preset page margins. You need to - compensate for these margins by changing page length in your - WordStar documents. The chart below shows the recommended - settings for 8 1/2 X 11 inch paper for both portrait and landscape - orientations. These settings allow 55 lines of text for portrait - orientation and 40 lines of text for landscape orientation (at 6 - lines per inch). They also allow for a footer of up to 3 lines - and a one-line header. If you use multiple-line headers, adjust - the top margin accordingly. - - Dot Default Portrait Landscape - Setting Command Value Orientation Orientation - ------- ------- ------- ----------- ----------- - page length .PL 66 62 47 - top margin .MT 3 2 2 - bottom margin .MB 8 5 5 - header margin .HM 2 1 1 - footer margin .FM 2 2 2 - - If the laser printer is your primary printer, you can use WSCHANGE - to make these settings the defaults. - - Because laser printers leave small margins at the left and right - sides of the page, you may want to use a smaller page offset - setting (the default is .PO 8). - -Form Feeds - - When you print with a laser printer, answer Y for yes to the "Use - form feeds (Y/N)?" prompt at print time. (The default is NO.) If - the laser printer is your primary printer, you can use WSCHANGE to - change the default to yes. - -WordStar Commands for Font Selection - - The WordStar dot commands and print control commands listed below - determine the fonts used for printing a document. - - .PR .PR OR=L selects landscape orientation; .PR OR=P (or just - .PR OR) selects portrait orientation (the default). If - either of these commands appears after the first printing - line on a page, the orientation will not change until the - following page. - - .PS .PS ON selects proportionally spaced characters; .PS OFF - (the default) selects fixed-spaced characters. - - .CW The character-width setting (.CW followed by the width in - 120ths of an inch) determines the character pitch and font - selected for fixed-width printing. For proportional fonts, it - determines the point size and proportional-width table - selected. - - .LQ .LQ ON selects near letter quality print (if supported by - your printer). LQ OFF selects draft quality print. Default - is ON. - - ^PY The italic print control toggles between normal and italic - characters when the appropriate italic font is available. - - ^PB The boldface print control toggles between normal and bold - characters when the appropriate bold font is available. - - ^PD The double strike print control used with the laser printers - toggles overprinting with a horizontal offset of 1/120" - between the two character images. This allows a bold effect - where no bold font is available. - - ^PA ^PA turns alternate pitch on. Use .CW to assign different - character widths to normal pitch (see ^PN below) and alternate - pitch so that each pitch accesses a different font. You can - then change fonts by switching between the two pitches. This - is the only way to use two fonts on the same line. - (See "Character width" and "Pitch" in the "Reference Guide.") - - ^PN ^PN turns normal pitch on. You can use it with ^PA as - described above. - - ^P@ When working with columns, if you use alternate and normal - pitch for two fonts, or if you use proportional spacing, you - may need to use ^P@ to make sure the columns line up. - Remember that the column position set with ^P@ is determined - by the normal pitch character width. (See "Columns" and - "Proportional spacing" in the "Reference Guide." - -INFORMATION ON SPECIFIC PRINTERS - - This section describes the capabilities of each printer listed on - the Printer Selection Menu. The printers are listed in alphabetical - order (except for the generic printers such as "Draft," - "Typewriter," "Custom," "Simple," and the various print-to-disk - options, which are listed first). - - There is a chart for each printer explaining how features work and - listing any special notes about the printer. Each printer is - described in the following format: - -PRINTER NAME ----- Driver: (short name) - - ^PY Effect of italics/ribbon color print control - ^PT/V Subscript/superscript information - .CW Information on available character widths and fonts. The - chart shows the .CW, .LQ, and .PS settings required to use - different fonts. - - .LQ OFF .LQ ON .PS ON Font Name - ------- ------ ------ --------- - .cw val .cw val recommended value (range) font 1 - .cw val .cw val recommended value (range) font 2 - - .UL Continuous-underline information (if restrictions) - .UJ Microspace-justification information (if restrictions) - - N/A means a command has no effect on this printer. - - NOTES Switch settings, special features, anomalies. - -DRAFT PRINTER (nonbackspacing) ----- Driver: DRAFT - - ^PD Overprints the line twice - ^PB Overprints the line three times - ^PS Overprints the underscore character in a separate pass - ^PT/V Prints super/subscripts with a full line between - super/subscript and text - .LH Sets line height only in multiples of full lines - .CW N/A - .PS N/A - .LQ N/A - .UJ N/A - - NOTES This driver works with any printer that doesn't automatically - perform a line feed when it receives a carriage return command. All - overprinting is done by returning the carriage and passing over the - line again. - -TYPEWRITER PRINTER (backspacing) ----- Driver: TYPEWR - - ^PD Backspaces and overprints each character twice - ^PB Backspaces and overprints each character three times - ^PS Backspaces and overprints the underscore character - ^PT/V Prints super/subscripts with a full line between - super/subscript and text - .LH Sets line height only in multiples of full lines - .CW N/A - .PS N/A - .LQ N/A - .UJ N/A - - NOTES This driver works with any printer that doesn't automatically - perform a line feed when a it receives a carriage return command, - and responds to a backspace character. Overprinting is done by - backspacing. - -AUTO LINE FEED PRINTER (backspacing) ----- Driver: AUTOLF - - ^PD Backspaces and overprints each character twice - ^PB Backspaces and overprints each character three times - ^PS Backspaces and overprints the underscore character - ^PT/V Prints super/subscripts with a full line between - super/subscript and text - .LH Sets line height only in multiples of full lines - .CW N/A - .PS N/A - .LQ N/A - .UJ N/A - - NOTES This driver works with any printer that automatically - performs a line feed when it receives a carriage return character, - and responds to a backspace command. Overprinting is done by - backspacing. - -SIMPLE CUSTOMIZABLE PRINTERS ----- Driver: SIMPLE - - All print controls cause control strings (on and off) in - the user area to be sent to the printer. These strings - are used by both the SIMPLE and CUSTOM drivers. They can - be installed with the WSCHANGE program. - - .LQ Controlled by user area strings - .PS Controlled by user area strings - .CW N/A - .UJ N/A - .LH N/A - - NOTES This printer driver prints the line in one pass, sending - control strings from the user area to select print enhancements. - -CUSTOMIZABLE PRINTERS ----- Driver: CUSTOM - - All print controls cause control strings (on and off) in - the user area to be sent to the printer. These strings - are used by both the SIMPLE and CUSTOM drivers. They can - be installed with the WSCHANGE program. - - .LQ ON/OFF controlled by user area strings - .PS ON/OFF controlled by user area strings - .LH Sets line height only in multiples of full lines - .UJ N/A - .CW N/A - - NOTES This driver prints the line in multiple passes, sending - control strings from the user area to select print enhancements. - -PREVIEW TO DISK ----- Driver: PRVIEW - - This driver prints documents to the PREVIEW.WS file to allow - you to preview the format and appearance of a document before - printing. Headers, footers, and pagination are shown correctly - and print controls remain in the file to display onscreen - attributes. Dot commands are not printed. - -PRINT TO DISK WITHOUT PRINT CONTROLS ----- Driver: ASCII - - This driver prints to the ASCII.WS file, stripping headers and - footers, high bits, and print controls. - -PRINT TO DISK WITHOUT HEADERS AND FOOTERS ----- Driver: XTRACT - - This driver prints to the XTRACT.WS disk file, stripping headers - and footers, but preserving high bits and print controls. - -ANADEX 9500A, 9500B ----- Driver: 9500 - - ^PY N/A - ^PT/V Even superscript roll - - .CW .CW Font name - --- --------- - 9 13.3 cpi - 10 12 cpi - 12 10 cpi - 18 6.7 cpi - 20 6 cpi - 24 5 cpi - - .LH 1/24" resolution, use even values - .UJ This printer has no incremental horizontal positioning - .PS N/A - .LQ N/A - -ANADEX 9501B, INTEQ 5100B ----- Driver: 9501B - - ^PY N/A - ^PT/V Even superscript roll - - .CW .CW Font name - --- --------- - 7 16.7 cpi - 8 15 cpi - 10 12.5 cpi - 12 10 cpi - 14 8.3 cpi - 16 7.5 cpi - 20 6.2 cpi - 24 5 cpi - - .LH 1/24" resolution, use even values - .UJ This printer has no incremental horizontal positioning - .PS N/A - .LQ N/A - -C. ITOH STARWRITER 1550 AND 8510 ----- Driver: C1550 - - ^PY N/A - ^PT/V Prints full-size characters with roll - - .CW .CW Font Name - --- --------- - 7 compressed - 10 elite - 12 pica - 14 expanded compressed - 20 expanded elite - 24 expanded pica - - .LQ N/A - .PS N/A - .UL Continuous underlining suppresses microspace justification - -C. ITOH F10 STARWRITER ----- Driver: QUME - - See Diablo 630, 1610, 1620 Daisy Wheel. - - Note: Proportional printing was tested with a Theme 10 wheel. - -CANON LBP-8A1 AND LBP-8A2 LASER PRINTER ----- Driver: LBP8 - - ^PY Selects italics if appropriate font installed - ^PT/V Prints full-size characters with roll - .PS .PS - .CW OFF ON Font Name - --- -- --------- - 6 - 20 cpi - 8 - 15 cpi - 9 - 13.3 cpi - 10 - 12 cpi (elite) - 12 - 10 cpi - 20 - 6 cpi - 24 - 5 cpi - 16 - 7.5 cpi - - 7 (0-8) Garland 8 point - - 10 (9-11) Garland 12 point - - 14 (12-17) Expanded 8 point - - 20 (18-30) Expanded 12 point - - .LQ N/A - .PL For 11 inch paper, a value of 62 is recommended - .PR OR "=Landscape" or "=Portrait" to select orientation - - NOTES Answer yes to the "Use form feeds" prompt. This driver is - configured to select all the built-in fonts in the LBP8, as well - as fixed pitch cartridges and the Garland PS cartridge. Other - proportional cartridges require modifying the proportional spacing - tables with WSCHANGE. For more information on laser printers, see - the "Laser Printers" section above. - -CITIZEN MSP ----- Driver: CITMSP - - ^PY Selects italics - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - - .CW .CW Font Name - --- --------- - 7 compressed - 10 elite - 12 pica - 14 expanded compressed - 20 expanded elite - 24 expanded pica - - .LH Use even values. Driver operates at 2/48 resolution. - .PS N/A - .UJ Microjustification slows printing. Continuous underlining - suppresses microjustification. - - -DATAPRODUCTS PAPER TIGER SPG-8050 & SPG-8070 ----- Driver: SP8050 - - ^PY Selects italics - ^PT/V Prints half-size if .SR 0; otherwise, prints full-size - .LQ .LQ .PS - .CW ON OFF ON Font name - --- --- --- --------- - 7 7 5 (0-6) condensed - 10 10 8 (7-8) elite - 12 12 10 (9-13) pica - 14 14 - expanded condensed - 20 20 16 (14-17) expanded elite - 24 24 20 (18-30) expanded pica - -DIABLO 630, 1610, 1620 DAISY WHEEL ----- Driver: DIABLO - - ^PY Selects red/black ribbon color - ^PT/V Prints super/subscripts in separate pass with specified roll - .CW Supports any value from 0 to 30. Usual fixed pitch values - are 8 (15 cpi), 10 (12 cpi), and 12 (10 cpi). - .BP ON selects bidirectional printing; OFF selects left-to-right - printing - .LQ N/A - .UL Continuous underlining does not suppresses microspace - justification. Continuous underlining may be irregular. - .PS ON selects proportional spacing; OFF selects fixed pitch - spacing. If a proportional print wheel has a non-standard - spoke pattern, configure the printer to translate spoke - position into the appropriate character. This driver - explicitly positions each character when proportional spacing - is selected. - - NOTES The proportional spacing tables are set up for a Diablo - metal 96 character BOLD PS wheel. - -DIABLO 630 DAISY WHEEL WITH WP OPTIONS ----- Driver: 630WP - - ^PY Selects red/black ribbon color - ^PT/V Prints super/subscripts in separate pass with specified roll - .CW Supports any value from 0 to 30. Usual fixed pitch values - are 8 (15 cpi), 10 (12 cpi), and 12 (10 cpi). - .LQ N/A - .UL Continuous underlining does not affect microspace justifi- - cation - .PS ON selects proportional spacing; OFF selects fixed pitch - spacing. If a proportional print wheel has a non-standard - spoke pattern, configure the printer to translate spoke - position into the appropriate character. This driver sends - codes to the printer to turn proportional spacing on and off, - and the printer controls character to character spacing. - - NOTES The proportional spacing tables are set up for a Diablo - metal 96 character BOLD PS wheel. - -DIABLO 630 DAISY WHEEL, EXTENDED CHARACTER SET ----- Driver: 630ECS - - ^PY N/A - ^PT/V Prints super/subscripts in separate pass with specified roll - .CW Supports any value from 0 to 30. Usual fixed pitch values - are 8 (15 cpi), 10 (12 cpi), and 12 (10 cpi). - .LQ N/A - .UL Continuous underlining does not affect microspace justifi- - cation - .PS ON selects proportional spacing; OFF selects fixed pitch - spacing. If a proportional print wheel has a non-standard - spoke pattern, configure the printer to translate spoke - position into the appropriate character. This driver sends - codes to the printer to turn proportional spacing on and off, - and the printer controls character to character spacing. - - NOTES The proportional spacing tables have been set up for a Diablo - metal 96 character BOLD PS wheel. - -DIABLO C150 & C200 COLOR JET PRINTERS ----- Driver: C150 - - ^PY Selects red/black ink - .CW 10 characters per inch only - .LH 1/30" resolution - .PS N/A - .LQ N/A - -EPSON FX-80 AND FX-100 ----- Driver: FX80 - - ^PY Selects italics - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - - .CW .CW Font Name - --- --------- - 7 compressed - 10 elite - 12 pica - 14 expanded compressed - 20 expanded elite - 24 expanded pica - - .LH Use even values. Driver operates at 2/48" resolution. - .LQ N/A - .PS N/A - .UL Continuous underlining suppresses microspace justification - .UJ Microspace justification slows printing. Default is OFF. - -EPSON FX-85, FX-185 AND FX-286 ----- Driver: FX85 - - ^PY Selects draft quality italics - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - .LQ .LQ - .CW OFF ON .PS ON Font Name - --- --- ------ --------- - 6 - - compressed elite - 7 - - compressed - 10 - - elite - 12 12 11 (10-13) courier - 14 - - expanded compressed - 20 - - expanded elite - 24 24 22 (20-30) expanded courier - - .UL Continuous underlining suppresses microspace justification - .UJ Microspace justification slows printing. Default is OFF. - .UJ must be on for proportional text to be right-justified. - -EPSON LQ-800 AND LQ-1000 ----- Driver: LQ800 - - ^PY Selects italics - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - .LQ .LQ - .CW OFF ON .PS ON Font Name - --- --- ------ --------- - - - - compressed script - 6 6 - compressed elite - 7 7 6 (0-7) compressed - 8 - subscript 15 cpi - 10 10 - elite - 12 12 10 (8-16) pica - 14 14 - expanded compressed - 16 - expanded script - 20 20 - expanded elite - 24 24 - expanded courier - -EPSON LQ-1500, VERSION 2.0 ----- Driver: LQ1500 - - ^PY Selects italics - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - .LQ .LQ - .CW OFF ON .PS ON Font Name - --- --- ------ --------- - 7 - - compressed - 10 10 - elite - - - 8 (1-9) subscript 15 cpi - 12 12 11 (10-13) courier - 14 - - expanded compressed - - - 15 (14-18) expanded script - 20 20 - expanded elite - 24 24 20 (19-30) expanded courier - - .UL Continuous underlining suppresses microspace justification. - In proportional fonts, continuous underlining may appear - broken between words. - - NOTES If you have an older LQ-1500 (firmware version 1.8), your - printer will have horizontal position registration problems. For - best results, contact your printer dealer about a ROM upgrade. - -EPSON LX-80 - Driver: LX80 - - ^PY Selects draft mode italics - ^PT/V Prints half height if .SR 0, else full height with roll - - .LQ .LQ - .CW OFF ON Font Name - --- --- --------- - 7 - compressed - 10 - elite - 12 12 courier - 14 - expanded compressed - 20 - expanded elite - 24 24 expanded courier - - .LH Use even values. Driver operates at 2/48" resolution. - .PS N/A - .UL Continuous underlining suppresses microspace justification - .UJ Microspace justification slows printing. Default is OFF. - -EPSON MX-80 AND MX-100 WITH GRAFTRAX+ -EPSON MX-80 III AND MX-100 III ----- Driver: MX80 - - ^PY Selects italics - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - - .CW .CW Font Name - --- --------- - 7 compressed - 12 pica - 14 expanded compressed - 24 expanded pica - - .LH Use even values. Driver operates at 2/48" resolution. - .LQ N/A - .PS N/A - .UL Continuous underlining suppresses microspace justification - .UJ Microspace justification slows printing. Default is OFF. - - NOTES Older MX-80 and MX-100 printers don't have graphics mode (for - fine horizontal spacing), variable line height setting, printer - controlled underlining, or printer controlled super/subscripts. If - you have one of these printers, use the DRAFT driver, or adapt the - CUSTOM or SIMPLE driver to your needs. - -EPSON RX-80 AND RX-100 ----- Driver: RX80 - - ^PY Selects italics - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - - .CW .CW Font Name - --- --------- - 7 compressed - 10 elite - 12 pica - 14 expanded compressed - 20 expanded elite - 24 expanded pica - - .LH Use even values. Driver operates at 2/48" resolution. - .LQ N/A - .PS N/A - .UL Continuous underlining suppresses microspace justification - .UJ Microspace justification slows printing. Default is OFF. - -HEWLETT-PACKARD LASERJET PRINTERS - - The following information applies to the LaserJet, the LaserJet+, - and the LaserJet 500+. For general information on laser printers, - see the "Laser Printers" section above. - -The LaserJet Fonts - - The LaserJet has three different types of fonts: - - - The "internal" fonts that came with the printer - - Plug-in cartridges - - Soft fonts that must be downloaded through your computer. - (Only the LaserJet+ and LaserJet 500+ can use downloaded fonts.) - - The fonts available in your LaserJet depend on which cartridge - you have installed and which fonts you have downloaded. - -Font Installation - - Internal Fonts: - - The fonts that came with your printer are already in memory and - ready to use. Different LaserJet models come with different sets - of internal fonts. - - Cartridges: - - Cartridges containing a variety of character fonts can be - inserted into any LaserJet model. See your printer manual for - instructions. - - The font selection guidelines in the sections below contain - information about specific cartridges. The letter that identifies - your cartridge is on the front label, directly following the - number 92286. For example, the Y cartridge is labeled 92286Y. - - Soft fonts: - - Soft, or downloadable, fonts are supplied on disk. These fonts - are not explicitly supported by WordStar. - -LaserJet Font Selection - - Each LaserJet font has several characteristics associated with - it. When a printer driver specifies font characteristics to the - LaserJet, the LaserJet searches its available fonts for the best - match to the characteristics requested. The following table - describes these characteristics, in the order in which the - LaserJet evaluates them when selecting a font. - - Characteristic WordStar Control - -------------- ----------------- - * Orientation (portrait or landscape) .PR OR=P/L - * Symbol Set (Roman-8, USASCII, Printer driver - Line Draw, etc.) - * Proportional or fixed spacing .PS ON/OFF - * Print pitch (fixed-width fonts) .CW - * Character height (point size) .CW - * Character style (upright or italic) ^PY - * Stroke weight (light, medium, bold) ^PB - - Note that symbol set is high in the list of characteristics: - make sure that the driver you select is compatible with the symbol - set of your cartridge or downloaded fonts. The symbol sets used by - each driver are listed in the table in the next section. For example, - if your cartridge has the USASCII Symbol Set, you can't use the - HPLJ:U driver because it uses only the Roman-8 Symbol Set. - -LaserJet Printer Drivers - - WordStar provides two printer drivers for use with different - LaserJet font cartridges. Each of these drivers - lets you print with several of the available fonts. You can - use any of these drivers with the LaserJet, LaserJet+, or - LaserJet 500+, depending on the cartridge. - Refer to the table below to see which driver works - best for you. - - The table lists the following information for each driver: - - o The symbol sets used for fixed and proportional spacing - - These must correspond to the symbol sets on the installed - fonts you want to use. The "Default" symbol set refers to the - one the LaserJet defaults to. - - o The proportional-spacing tables used by the driver - - These tables are part of the LaserJet's method of proportional - spacing. The tables determine the width of each character in a - proportionally spaced font. The fonts corresponding to these - tables are used if available. If the corresponding font is not - installed, the table is still used, and the closest available - font is used. This may cause the spacing to appear too tight or - too loose. In this column, the number is the point size, R stands - for regular, B stands for bold, and I stands for italics (the - LaserJet has separate tables for each of these). - - o The font cartridges that work best with - the symbol sets and tables used by the driver - - The cartridges listed are the only ones directly - supported for use with WordStar. If your cartridge is not - listed, you may still be able to use it. Look at - the font information below and try the most compatible driver. - You may need to try different dot command settings or another - driver. The HPLJET is the most "general purpose" driver, so if - you're not sure which driver to use, try it first. - - Fixed-width Proportional Proportional Downloaded - Driver Symbol Set Symbol Set Tables Fonts/Cartridges - ------ ----------- ------------ ------------- ---------------- - - HPLJET Default Default TmsRmn 8R, F, P, most fixed - 10R,10B,10I - Helv 14B - - HPLJ:B Default USASCII TmsRmn 8R, B - 10R,10B,10I - Helv 14B - - HPLJ:U Roman-8, Roman-8 Helv 6R,8R, U, V - Line Draw 10R,12R,14R - - HPLJ:Y PCSET1 USASCII TmsRmn Y, AC - PCSET2 6,8,10,12,14 - (all in R,B,I) - 18B,24B,30B - - HPL:AD Roman-8, Roman-8 TmsRmn AD - Line Draw 6,8,10,12,14 - (all in R,B,I) - 18B,24B,30B - - The printer driver charts below show the actual fonts that print - with each printer driver and the recommended font cartridges. - The charts show the fonts used for both fixed - and proportional spacing and for different character width (.CW) - settings. - - The recommended .CW settings are shown first. The settings in - parentheses select the same font, but the spacing of characters - within a line may appear tighter or looser. - - After the name of each font, the charts note whether regular (R), - bold (B), and italic (I) fonts are available. If a bold font is - not available, you can use the ^PD (double strike) command to get - a boldface effect. - - The last column shows whether you can print in landscape (chosen - in WordStar with .PR OR=L) as well as portrait orientation. - - To use a particular font, choose the settings listed. For example, - to use the Times Roman 8 font with the HPLJET printer driver, insert - the F cartridge, turn .PS on and set character width to .CW 7. - -HP LASERJET, LASERJET+ (F cartridge and others) ----- Driver: HPLJET - - ^PY Selects italics if appropriate font installed - ^PT/V Prints full-size characters with roll - - Cartridge/ - Soft font .PS .CW Font/Point Size R B I Landscape - --------- --- -------- --------------- - - - --------- - F on 7 (0-7) Times Roman 8 x - 9 (8-11) Times Roman 10 x x x - 13 (12-30) Helvetica 14 x - off 7 (0-11) Line Printer 8.5 x - 12 (12-30) Courier 12 x x - P on 9 (0-30) Times Roman 10 x x x x - off 7 (0-11) Line Printer 8.5 x - 12 (12-30) Courier 12 x x (0-30) - - The following fixed pitch fonts may be available depending - on your cartridge. (Note that these are measure by pitch, - not by point size.): - - .CW Font Name - --- --------- - 7 16.7 pitch - 10 12 pitch - 12 10 pitch - 15 8.1 pitch - 18 6.5 pitch - 21 5.8 pitch - 27 4.5 pitch - - .LQ N/A - .PL For 11 inch paper, a value of 62 is recommended. - Too large a value will cause text to be lost at page bottom. - .PR OR "=Landscape" or "=Portrait" to select orientation. - - NOTES Answer yes to the "Use form feeds" prompt. This driver has - proportional spacing tables for all fonts in the F and P cartridges. - It should also work with many fixed width cartridges. -.p - -HP LASERJET, LASERJET+ (B cartridge) ----- Driver: HPLJ:B - - ^PY Selects italics if appropriate font installed - ^PT/V Prints full-size characters with roll - - Cartridge/ - Soft font .PS .CW Font/Point Size R B I Landscape - --------- --- -------- --------------- - - - --------- - B on 7 (0-7) Times Roman 8 x - 9 (8-11) Times Roman 10 x x x - 13 (12-30) Helvetica 14 x - off 7 (0-11) Line Printer 8.5* x x - 12 (12-30) Courier 12 x x - * Line printer 8.5 is not available in portrait mode - unless the LaserJet+ is used. - - .LQ N/A - .PL For 11 inch paper, a value of 62 is recommended. - Too large a value will cause text to be lost at page bottom. - .PR OR "=Landscape" or "=Portrait" to select orientation. - - NOTES Answer yes to the "Use form feeds" prompt. This driver has - proportional spacing tables for all fonts in the B cartridge. -.p - -HP LASERJET, LASERJET+ (U and V cartridges) ----- Driver: HPLJ:U - - ^PY Selects italics if appropriate font installed - ^PT/V Prints full-size characters with roll - - Cartridge/ - Soft font .PS .CW Font/Point Size R B I Landscape - --------- --- -------- --------------- - - - --------- - U on 5 (0-5) Helvetica 6 x - 7 (6-7) Helvetica 8 x - 9 (8-9) Helvetica 10 x - 11 (10-11) Helvetica 12 x - 13 (12-30) Helvetica 14 x - off 7 (0-11) Letter Gothic 9.5 x - 12 (12-30) Courier 12 x x (0-30) - - V on 5 (0-5) Helvetica 6 x landscape only* - 7 (6-7) Helvetica 8 x "* - 9 (8-9) Helvetica 10 x "* - 11 (10-11) Helvetica 12 x "* - 13 (12-30) Helvetica 14 x "* - off 7 (0-11) Letter Gothic 9.5 x ** - 12 (12-30) Courier 12 x - * No proportional font is available in portrait orientation. - ** With fixed spacing, in portrait orientation, .CW7 (0-11) - produces Line Printer 8.5 on the LaserJet+ and Courier 12 - on the LaserJet. - - .LQ N/A - .PL For 11 inch paper, a value of 62 is recommended. - Too large a value will cause text to be lost at page bottom. - .PR OR "=Landscape" or "=Portrait" to select orientation. - - NOTES Answer yes to the "Use form feeds" prompt. This driver has - proportional spacing tables for all fonts in the U and V cartridges. -.p - -HP LASERJET, LASERJET+ (Y cartridge, AC TmsRmn) ----- Driver: HPLJ:Y - - ^PY Selects italics if appropriate font installed - ^PT/V Prints full-size characters with roll - - Cartridge/ - Soft font .PS .CW Font/Point Size R B I Landscape - --------- --- -------- --------------- - - - --------- - Y on none available - off 7 (0-11) Line Printer 8.5 x x - 12 (12-30) PC Courier 12 x x x - - AC* on 5 (0-5) Times Roman 6 x x x x - 7 (6-7) Times Roman 8 x x x x - 9 (8-9) Times Roman 10 x x x x - 11 (10-11) Times Roman 12 x x x x - 13 (12-14) Times Roman 14 x x x x - 16 (15-18) Times Roman 18 x x - 20 (19-24) Times Roman 24 x x - 25 (25-30) Times Roman 30 x x - off 7 (0-11) Line Printer 8.5 x x (0-30) - 12 (12-30) Courier 12 x - * Other .CW settings may access additional fonts if a - cartridge is also installed. - - .LQ N/A - .PL For 11 inch paper, a value of 62 is recommended. - Too large a value will cause text to be lost at page bottom. - .PR OR "=Landscape" or "=Portrait" to select orientation. - - NOTES Answer yes to the "Use form feeds" prompt. This driver is for - use with the Y cartridge, which provides an IBM PC compatible symbol - set. In addition, this driver has complete proportional spacing - tables for the AC set of downloadable TmsRmn fonts. -.p - -HP LASERJET, LASERJET+ (AD TmsRmn) ----- Driver: HPL:AD - - ^PY Selects italics if appropriate font installed - ^PT/V Prints full-size characters with roll - - Cartridge/ - Soft font .PS .CW Font/Point Size R B I Landscape - --------- --- -------- --------------- - - - --------- - AD* on 5 (0-5) Times Roman 6 x x x x - 7 (6-7) Times Roman 8 x x x x - 9 (8-9) Times Roman 10 x x x x - 11 (10-11) Times Roman 12 x x x x - 13 (12-14) Times Roman 14 x x x x - 16 (15-18) Times Roman 18 x x - 20 (19-24) Times Roman 24 x x - 25 (25-30) Times Roman 30 x x - off 7 (0-11) Line Printer 8.5 x - 12 (12-30) Courier 12 x x (0-30) - - The following fixed pitch fonts may be available depending - on your cartridge. (Note that these are measure by pitch, - not by point size.): - - .CW Font Name - --- --------- - 7 16.7 pitch - 10 12 pitch - 12 10 pitch - 15 8.1 pitch - 18 6.5 pitch - 21 5.8 pitch - 27 4.5 pitch - - .LQ N/A - .PL For 11 inch paper, a value of 62 is recommended. - Too large a value will cause text to be lost at page bottom. - .PR OR "=Landscape" or "=Portrait" to select orientation. - - NOTES Answer yes to the "Use form feeds" prompt. This driver is for - use with the AD TmsRmn downloaded fonts, and for a ROMAN8 or - ROMAN8+LINEDRAW fixed width font cartridge. The driver includes - complete proportional spacing tables for the AD set of downloadable - TmsRmn fonts. - -HP THINKJET, IBM mode ----- Driver: HPTJI - - ^PY N/A - ^PT/V Prints full-size characters with roll - - .CW .CW Font Name - --- --------- - 7 compressed - 10 elite - 12 pica - 14 expanded compressed - 20 expanded elite - 24 expanded pica - - .LH Use even values. Driver operates at 2/48" resolution. - .LQ N/A - .PS N/A - .UL Continuous underlining suppresses microspace justification - .UJ Microspace justification slows printing. Default is ON. - - NOTES This printer does not have a true 10 pitch font, so character - widths are not exact, and ^P@ does not align exactly with text. - Because the printer has an automatic page offset, set the WordStar - page offset to zero. - -IBM COLOR PRINTER 5182 ----- Driver: IBMCLR - - ^PY Selects red/black ribbon color - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - .LQ .LQ .PS - .CW OFF ON ON Font Name - --- --- -------- --------- - 7 7 5 (0-6) compressed - 10 10 8 (7-8) elite - 12 12 10 (9-13) pica - 14 14 - expanded compressed - 20 20 15 (14-16) expanded elite - 24 24 20 (17-30) expanded pica - - .LH Use even values. Driver operates at 2/48" resolution. - .LQ Has same effect as ^PD - .UL Underlining may be irregular with microspace justification on - .UJ Microspace justification slows printing. Default is OFF. - -IBM GRAPHICS PRINTER 5152 ----- Driver: IBMGR - - ^PY N/A - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - - .CW .CW Font Name - --- --------- - 7 compressed - 12 pica - 14 expanded compressed - 24 expanded pica - - .LH Use even values. Driver operates at 2/48" resolution. - .LQ N/A - .PS N/A - .UL Continuous underlining suppresses microspace justification - .UJ Microspace justification slows printing. Default is OFF. - -IBM PROPRINTER 4201 ----- Driver: IBMPRO - - ^PY N/A - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - .LQ .LQ - .CW OFF ON Font Name - --- --- --------- - 7 7 compressed - 10 10 elite - 12 12 pica - 14 14 expanded compressed - 20 20 expanded elite - 24 24 expanded pica - - .LH Use even values. Driver operates at 2/48" resolution. - .PS N/A - .LQ Has same effect as ^PD - .UL Continuous underlining suppresses microspace justification - .UJ Microspace justification slows printing. Default is OFF. - - NOTES If you have a Proprinter XL, you can use WSCHANGE to patch - in the extra features. - -IBM QUIETWRITER 5201 ----- Driver: IBMQUI - - ^PY Toggles between A and * font cartridge. Set character - width to match cartridge in use. (A cartridge uses current - ^PN character width; * cartridge uses ^PA character width.) - ^PT/V Prints full-size characters with roll - .CW Selects character width. Character width must correspond - to the cartridge being used. - .LQ N/A - .PS ON selects proportional spacing, OFF selects fixed pitch - spacing - -IBM WHEELPRINTER 5216 ----- Driver: IBMWP - - ^PY N/A - ^PT/V Printer determined roll if .SR 0 - .CW Selects character spacing. Any value from 0 to 30 is - supported. Usual fixed pitch values are 8 (15 characters - per inch), 10 (12 cpi) and 12 (10 cpi). - .LQ N/A - .UL Continuous underlining does not affect microjustification - .PS ON selects proportional spacing, OFF selects fixed pitch. - This driver sends codes to the printer to turn proportional - spacing on and off, and the printer controls character to - character spacing. - - NOTES The proportional spacing tables are set up for an IBM - BOLD PS wheel. - -IBM WHEELPRINTER 5223 E ----- Driver: IBMWPE - - ^PY N/A - ^PT/V Printer determined roll if .SR 0 - .CW Selects character spacing. Any value from 0 to 30 is - supported. Usual fixed pitch values are 8 (15 characters - per inch), 10 (12 cpi) and 12 (10 cpi). - .LQ N/A - .UL Continuous underlining does not affect microjustification. - Continuous underlining will be somewhat irregular. - .PS ON selects proportional spacing, OFF selects fixed pitch. - This driver will send codes to the printer to turn propor- - tional spacing on and off, and the printer will control - character to character spacing. - - NOTES The proportional spacing tables are set up for an IBM - BOLD PS wheel. - -MANNESMANN TALLY MT-160L ----- Driver: MT160L - - ^PY N/A - ^PT/V Prints full-size characters with specified even roll - .LQ .LQ - .CW OFF ON Font Name - --- --- --------- - 6 - compressed elite - 7 - compressed - 10 10 elite - 12 12 pica - 14 - expanded compressed - 20 - expanded elite - 24 - expanded pica - - .LH Use even values. Driver operates at 2/48" resolution. - .UJ N/A - - NOTES This printer is not capable of incremental horizontal - positioning. As a result, microspace justification is not possible. - In addition, when changing character widths, characters may not - align to closer than one full character width. Also, page offsets - smaller than a character will not work. - -MPI PRINTMATE 99 & 350 ----- Driver: MPI99 - - ^PY N/A - ^PT/V Even superscript roll - .LQ .LQ - .CW OFF ON Font name - --- --- --------- - 7 - 17.1 cpi - 10 - 12 cpi - 12 12 10 cpi - 14 - 8.5 cpi - 20 - 6 cpi - 24 24 5 cpi - - .LH 1/24" resolution, use even values - .PS N/A - .UJ N/A - -NEC PINWRITER P2-3, P2-6, P3-3, P6-6 ----- Driver: NECP2I - - ^PY N/A - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - .LQ .LQ - .CW OFF ON Font Name - --- --- --------- - 7 - compressed - 10 10 elite - 12 12 pica - 14 - expanded compressed - 20 20 expanded elite - 24 24 expanded pica - - .PS N/A - .UL Continuous underline suppresses microspace justification - .UJ Microspace justification slows printing. Default is OFF. - - NOTES Page offsets smaller than the character width in effect are - not supported. Make sure switch 5 on the printer is off. - -NEC PINWRITER P5XL, P6, P7 ----- Driver: NECP5 - - ^PY Selects italics - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - .LQ .LQ - .CW OFF ON .PS ON Font Name - --- --- ------ --------- - 6 6 - compressed elite - 7 7 6 (0-8) compressed - 8 8 - subscript 15 cpi - 10 10 - elite - 12 12 10 (9-17) pica - 14 14 - expanded compressed - 16 16 - expanded script - 20 20 - expanded elite - 24 24 20 (18-26) expanded courier - 30 30 30 (27-30) triple elite - - -NEC SPINWRITER 2000R, 3500R -NEC SPINWRITER 2010, 3510, 7710 -NEC SPINWRITER 2030, 3530, 7730 ----- Driver: SPINWR - - See Diablo 630, 1610, 1620 Daisy Wheel. - - .BP N/A - - NOTES The proportional spacing tables are set up for a NEC BOLD PS - wheel. Proportional spacing is not supported on the 2010 and 2030. - -NEC SPINWRITER 2015, 3515, 7715 ----- Driver: DIABLO - - See Diablo 630, 1610, 1620 Daisy Wheel. - - .BP N/A - - NOTES The proportional spacing tables are set up for a NEC BOLD PS - wheel. This printer does not respond correctly to the phantom blank - and phantom rubout characters, and may lose horizontal alignment if - they are included in your document. Proportional spacing is not - supported on the 2015. - -NEC SPINWRITER 2050, 3550, 8850 ----- Driver: SPIN50 - - See Diablo 630, 1610, 1620 Daisy Wheel. - - .BP N/A - - NOTES The proportional spacing tables are set up for a NEC BOLD PS - wheel. Proportional spacing is not supported on the 2050. - -OKIDATA MICROLINE 84 STEP 2, STANDARD ----- Driver: ML84 - - ^PY N/A - ^PT/V Printer controlled if .SR 0; otherwise, full-size with roll - .LQ .LQ - .CW OFF ON Font Name - --- --- --------- - 7 7 compressed - 10 10 elite - 12 12 pica - 14 14 expanded compressed - 20 20 expanded elite - 24 24 expanded pica - - .PS N/A - .UJ In draft mode (.LQ OFF), this printer is not capable of - microspace justification. Different character widths may - not line up correctly. - - NOTES Page offsets smaller than the character width in effect are - not supported. - -OKIDATA MICROLINE 92 AND 93, STANDARD ----- Driver: ML92 - - ^PY N/A - ^PT/V Printer controlled if .SR 0; otherwise, full-size with roll - .LQ .LQ - .CW OFF ON Font Name - --- --- --------- - 7 compressed - 10 10 elite - 12 12 pica - 14 expanded compressed - 20 20 expanded elite - 24 24 expanded pica - - .PS N/A - .UJ In draft mode (.LQ OFF), this printer is not capable of - microspace justification. Different character widths may - not line up correctly. - - NOTES Page offsets smaller than the character width in effect are - not supported. - -OKIDATA MICROLINE 84, 92, 93, IBM PLUG & PLAY ----- Driver: ML92I - - ^PY N/A - ^PT/V Printer controlled if .SR 0; otherwise, full-size with roll - .LQ .LQ - .CW OFF ON Font Name - --- --- --------- - 7 compressed - 12 12 pica - 14 expanded compressed - 24 24 expanded pica - - .PS N/A - .UJ In draft mode (.LQ OFF), this printer is not capable of - microspace justification. Different character widths may - not line up correctly. - - NOTES Page offsets smaller than the character width in effect are - not supported. - -OKIDATA MICROLINE 182, STANDARD ----- Driver: ML182 -OKIDATA MICROLINE 182, IBM ML182I - - ^PY N/A - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - .LQ .LQ - .CW OFF ON Font Name - --- --- --------- - 7 - compressed - 10 10 elite - 12 12 pica - 14 - expanded compressed - 20 20 expanded elite - 24 24 expanded pica - - NOTES This printer is not capable of incremental horizontal - positioning, so microspace justification is not possible. In - addition, when changing character widths, characters may not align - to closer than one full character width. Also, page offsets smaller - than a character do not work. - -OKIDATA MICROLINE 192, STANDARD ----- Driver: ML192 -OKIDATA MICROLINE 192, IBM ML192I - - ^PY Selects draft mode italics. No half height italics - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - .LQ .LQ - .CW OFF ON .PS ON Font Name - --- --- ------ --------- - 7 - - compressed - 10 10 9 (9-10) elite - 12 12 11 (11-17) pica - 14 - - expanded compressed - 20 20 18 (18-20) expanded elite - 24 24 22 (21-30) expanded pica - - NOTES This printer does not have control strings to select - proportional and fixed pitch printing. This choice can only be - made through the printer's own menu functions. For reasonable - results, make sure that your document and printer are both fixed - pitch or both proportional. - -OKIDATA MICROLINE 292, STANDARD ----- Driver: ML292 -OKIDATA MICROLINE 292, IBM ML292I - - ^PY Selects italics. No half height italics - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - .LQ .LQ - .CW OFF ON .PS ON Font Name - --- --- ------ --------- - 7 7 7 (6-8) compressed - 10 10 9 (9-10) elite - 12 12 11 (11-12) pica - 14 14 13 (13-17) expanded compressed - 20 20 18 (18-20) expanded elite - 24 24 22 (21-30) expanded pica - - NOTES This printer does not have control strings to select - proportional and fixed pitch printing. This choice can only be - made through the printer's own menu functions. For reasonable - results, make sure that your document and printer are both fixed - pitch or both proportional. - -OKIDATA PACEMARK 2410, STANDARD ----- Driver: PM2410 - - ^PY N/A - ^PT/V Prints full-size characters with roll - .LQ .LQ - .CW OFF ON Font Name - --- --- --------- - 7 - compressed - 10 10 elite - 12 12 pica - 14 - expanded compressed - 20 20 expanded elite - 24 24 expanded pica - - .UJ Compressed and expanded compressed characters will not be - microspace justified. Also, they may not align perfectly - with other character widths. - - NOTES If you have the IBM-compatible printer, do not use this - installation. Instead, choose the IBM Graphics Printer. - -PANASONIC KX-P1090 ----- Driver: P1090 - - ^PY Selects italics - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - - .CW .CW Font Name - --- --------- - 7 compressed - 10 elite - 12 pica - 14 expanded compressed - 20 expanded elite - 24 expanded pica - - .LH Use even values. Driver operates at 2/48" resolution. - .LQ N/A - .PS N/A - .UL Continuous underlining suppresses microspace justification. - -QUME SPRINT SERIES ----- Driver: QUME - - See Diablo 630, 1610, 1620 Daisy Wheel. - - .PS N/A - - NOTES Make sure you use the appropriate switch settings for your - interface module. Set the switches on the module accordingly: - IBM Centronics module: 1, 2, 8, 9 ON. All others OFF. - RS-232-C module: 1, 2 ON. All others OFF. - -QUME SPRINT WITH WP OPTION ----- Driver: QUMEWP - - See Diablo 630, 1610, 1620 Daisy Wheel. - - .PS N/A - -RICOH LP4080R LASER PRINTER ----- Driver: LP4080 - - ^PY N/A - ^PT/V Prints full-size characters with roll - .PS .PS - .CW OFF ON Font Name - --- --- --------- - 8 - 15 cpi - 10 - 12 cpi elite - 12 - 10 cpi courier - - 11 (0-30) proportional - - .LQ N/A - .PL For 11 inch paper, a value of 62 is recommended - .PR OR "=Landscape" or "=Portrait" to select orientation - - NOTES Answer yes to the "Use form feeds" prompt. This driver is - configured to select all the built in fonts in the LP4080R, in both - portrait and landscape mode. For more information on laser printers, - see the "Laser Printers" section above. - -SILVER REED EXP-550/500 DAISY WHEEL ----- Driver: SR550 - - See Diablo 630, 1610, 1620 Daisy Wheel. - - NOTES Proportional spacing tables (Model 500 does not support - proportional printing) are set up for a Silver Reed PS wheel. - You need to change the switch settings for proportional - fonts. Set the SW-1 switches accordingly: - For proportional fonts: 1, 2 ON, 3-6 OFF - For nonproportional fonts: All OFF. - -STAR MICRONICS GEMINI 10X AND 15X ----- Driver: GEM10X - - ^PY Selects italics - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - - .CW .CW Font Name - --- --------- - 7 compressed - 10 elite - 12 pica - 14 expanded compressed - 20 expanded elite - 24 expanded pica - - .LH Use even values. Driver operates at 2/48" resolution. - .LQ N/A - .PS N/A - .UL Continuous underlining suppresses microspace justification - .UJ Microspace justification slows printing. Default is OFF. - -STAR MICRONICS NX-10 ----- Driver: NX10 - - ^PY Selects draft quality italics - ^PT/V Prints half-size if .SR 0; otherwise full-size with roll - .LQ .LQ .PS - .CW OFF ON ON Font Name - --- --- --- --------- - 6 - 4 (0-5) compressed elite - 7 - 7 (6-7) compressed - 10 - 9 (8-9) elite - 12 12 11 (10-12) pica - 14 - - expanded compressed - 20 - - expanded elite - 24 24 - expanded pica - - .UL Continuous underlining suppresses microjustification - .UJ Microjustification slows printing - -STAR MICRONICS SG10 ---- Driver: SG10 -STAR MICRONICS SG10I ---- Driver: SG10I - - ^PY Selects draft mode italics - ^PT/V Prints full size characters with roll - - .LQ .LQ - .CW OFF ON .PS ON Font Name - --- --- ------ --------- - 7 - - compressed - 10 - 10 (9-12) elite - 12 12 - pica - 14 - - expanded compressed - 20 - 20 (18-24) expanded elite - 24 24 - expanded pica - - .UL Continuous underlining suppresses microjustification - .UJ Microjustification slows printing - .PS Draft quality proportional - - NOTE: Because of printer firmware limitations, combinations of - print enhancements may cause poor printed output. - -TANDY DMP-130 MATRIX PRINTER ----- Driver: DMP13 - - ^PY Selects italics - ^PT/V Prints half-size characters (17 cpi, or 8.5 cpi for - expanded fonts) - .LQ .LQ - .CW OFF ON .PS ON Font Name - --- --- ------ --------- - 7 - - compressed - - 10 - elite - 12 12 11 (11-13) pica - 14 - - expanded compressed - - 20 - expanded elite - 24 24 22 (21-30) expanded pica - - NOTES Printer must be in Tandy mode. - -TANDY DMP-2100P MATRIX PRINTER ----- Driver: D2100P - - ^PY N/A - ^PT/V Prints full-size characters with roll - .LQ .LQ - .CW OFF ON .PS ON Font Name - --- --- ------ --------- - 7 - - compressed - - 10 9 (9-10) elite - 12 12 11 (11-13) pica - 14 - - expanded compressed - - 20 18 (18-20) expanded elite - 24 24 22 (21-30) expanded pica - - NOTES Printer must be in Tandy mode. - -TANDY DMP-2110 MATRIX PRINTER ----- Driver: D2110 - - ^PY Selects italics - ^PT/V Prints half-size if .SR 0; otherwise, full-size with roll - .LQ .LQ - .CW OFF ON .PS ON Font Name - --- --- ------ --------- - 7 - - compressed - - 10 9 (9-10) elite - 12 12 11 (11-13) pica - 14 - - expanded compressed - - 20 18 (18-20) expanded elite - 24 24 22 (21-30) expanded pica - - NOTES Printer must be in Tandy mode. - -TANDY DWP-230 DAISY WHEEL ----- Driver: DWP230 -TANDY DWP-520 DAISY WHEEL ----- Driver: DWP520 - - ^PY N/A - ^PT/V Prints super/subscripts in separate pass with specified roll - .CW Supports any value from 0 to 30. Usual fixed pitch values are - 10 (12 cpi) and 12 (10 cpi). - .BP N/A - .LQ N/A - .PS ON selects proportional spacing. Spacing tables are set up for - a DIABLO BOLD PS wheel, #303029-01. - .UL Continuous underlining does not suppress microjustification - for DWP230; does suppress it for DWP520. - -TEXAS INSTRUMENTS 855 AND 865 ----- Driver: TI855 - - ^PY N/A - ^PT/V Prints full-size characters with roll - .LQ .LQ - .CW OFF ON .PS ON Font Name - --- --- ------ --------- - 6 6 6 (0-8) compressed - 10 10 10 (9-11) elite - 12 12 12 (12-17) pica - 14 14 - expanded compressed - 20 20 20 (18-22) expanded elite - 24 24 24 (23-30) expanded pica - -TOSHIBA P351, P351C, P341, P321 ----- Driver: P351 - - ^PY Selects italics - ^PT/V Prints full-size characters with roll - .LQ .LQ - .CW OFF ON .PS ON Font Name - --- --- ------ --------- - 7 - - compressed - - 10 9 (0-9) elite - 12 12 11 (10-14) pica - 14 - - expanded compressed - - 20 18 (15-19) expanded elite - 24 24 22 (20-30) expanded pica - -TOSHIBA P1340 ----- Driver: P1340 - - ^PY No effect - ^PT/V Prints full-size characters with roll - .LQ .LQ - .CW OFF ON Font Name - --- --- --------- - 10 10 elite - 12 12 pica - 14 - expanded compressed - 20 - expanded elite - 24 24 expanded pica - -TOSHIBA P1351 ----- Driver: P1351 - - ^PY N/A - ^PT/V Prints full-size characters with roll - .LQ .LQ - .CW OFF ON .PS ON Font Name - --- --- ------ --------- - 7 - - compressed - - 10 9 (0-9) elite - 12 12 11 (10-14) pica - 14 - - expanded compressed - - 20 18 (15-19) expanded elite - 24 24 22 (20-30) expanded pica - -ZENITH Z-125AA ----- Driver: Z125 - - ^PY N/A - ^PT/V No incremental vertical positioning - - .CW .CW Font name - --- --------- - 7 16.7 cpi - 9 13.3 cpi - 10 12 cpi - 12 10 cpi - 14 8.3 cpi - 18 6.7 cpi - 20 6 cpi - 24 5 cpi - - .LH Full lines only - .UJ N/A - .PS N/A - .LQ N/A - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/README b/software/CPM/CPM30_WORDSTAR_v400/README deleted file mode 100644 index 39793da..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/README +++ /dev/null @@ -1,15 +0,0 @@ -This disk contains an updated printer driver file for your -WordStar, CP/M Edition, Release 4. This file corrects problems -you may have experienced with form feeds, page length, and right- -justified proportional spacing. - -Follow the instructions on page xxii of the WordStar Reference -Guide for creating a new WSPRINT.OVR file. Substitute a copy of -this WSPRINT disk (make sure it is a boot disk) for the copy of -your original PRINT disk in step 2. - - - - - - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/REVIEW.COM b/software/CPM/CPM30_WORDSTAR_v400/REVIEW.COM deleted file mode 100644 index ec90bc0..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/REVIEW.COM and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/RULER.DOC b/software/CPM/CPM30_WORDSTAR_v400/RULER.DOC deleted file mode 100644 index 172a6ef..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/RULER.DOC +++ /dev/null @@ -1,22 +0,0 @@ - Thå Ruleò Line - -Thió  documenô  ió seô uð tï teacè yoõ abouô ruleò  lines®   Thió -texô  waó writteî usinç thå defaulô lefô anä righô marginó  oæ  ± -anä  65®   Wå didn'ô changå anù tabó here® Next¬  wå  wanteä  tï -changå  botè  marginó  tï  indenô thå texô®  Wå  useä  doô -commands® Witè doô commands¬ thå ne÷ marginó arå saveä wheî  yoõ -exiô anä savå thå document. -.lm10 -.rm45 -         Ne÷  marginó  changå thå  ruleò  anä -         text®   Watcè thå ruleò linå aó  yoõ -         movå  thå cursoò througè thió  text® -         WordStaò wilì continuå tï holä theså -         marginó untiì yoõ enteò anotheò  doô -         ãommand. -.lm1 -.rm65 -Margiî  changeó brinç thå ruleò anä thå texô bacë tï thå  defaulô -settingó oncå again. - - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/SAMPLE1.DOC b/software/CPM/CPM30_WORDSTAR_v400/SAMPLE1.DOC deleted file mode 100644 index 0bb6b8f..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/SAMPLE1.DOC +++ /dev/null @@ -1,17 +0,0 @@ - Itinerary - -Depart Datå Time Arrive Date Time - -Florence 10¯3± 08:30 a Rome 10¯31 05:3µ p -Romå 11¯05 08:00 a Naples 11/05 12:2· p - -Noô includeä iî thå rateó are -.lm10 -.rm55 - -         Transfeò  services¬ sightseeing¬ mealó  excepô -         aó specified¬ tipó tï statioî porters¬  wines¬ -         spirits¬   mineraì waters¬  laundry¬   theateò -         tickets¬ anä otheò itemó oæ á similaò personaì -         nature® - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/SAMPLE2.DOC b/software/CPM/CPM30_WORDSTAR_v400/SAMPLE2.DOC deleted file mode 100644 index e19c63d..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/SAMPLE2.DOC +++ /dev/null @@ -1,15 +0,0 @@ - -Excursions - - -Daù ± -Florencå-Romeº Leavå aô 8:3° aí bù deluxå motorcoach® Arrivå aô -Romå iî thå afternoon® - -Daù ² -Romeº   Morninç  anä afternooî citù  sightseeinç  bù  motorcoach® -Englisè speakinç guidå optional. - -Farå iî firsô clasó hotelsº $100.00® Batè optionaìº $25.00® - - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/SAMPLE3.DOC b/software/CPM/CPM30_WORDSTAR_v400/SAMPLE3.DOC deleted file mode 100644 index 725a3da..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/SAMPLE3.DOC +++ /dev/null @@ -1,5 +0,0 @@ -Daù 8 -Romå-Naplesº   Deparô  aô 8:0° aí bù CIAÔ deluxå  motorcoacè  viá -Formia®   Arrivå  Napleó  aô  luncè  time®   Afternooî   optionaì -excursioî tï Phlegreaî Fieldó anä Sulphuò Mine® - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/SPELL.COM b/software/CPM/CPM30_WORDSTAR_v400/SPELL.COM deleted file mode 100644 index 55a617a..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/SPELL.COM and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/TABLE.DOC b/software/CPM/CPM30_WORDSTAR_v400/TABLE.DOC deleted file mode 100644 index 90748d1..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/TABLE.DOC +++ /dev/null @@ -1,17 +0,0 @@ - TABLÅ II - - CENTRIFUGAÌ FORCÅ CALIBRATIOÎ DATA - -__________________________________________________________________ - Elemenô No® | Maximuí ç ü Minimuí ç ü Averagå ç ü Spreaä iî ç | -______________|____________|___________|___________|_____________| - ± ü 2.2± ü 1.6µ ü 1.9³ | 0.5¶ | - ü 2.2° ü 1.6µ ü 1.9³ ü 0.5° | - ² ü 2.4¸ ü 2.2µ ü 2.3¶ ü 0.2³ | - ü 2.5° ü 2.2² ü 2.3¶ ü 0.2¸ | - ³ ü 3.0¸ ü 2.5¹ ü 2.8´ ü 0.4¹ | - ü 3.1² ü 2.5¸ ü 2.8µ ü 0.5´ | - ´ ü 3.0· ü 2.6° ü 2.8´ ü 0.4· | - ü 3.1° ü 2.6° ü 2.8µ ü 0.5° | - - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/TEXT.DOC b/software/CPM/CPM30_WORDSTAR_v400/TEXT.DOC deleted file mode 100644 index e0cfaab..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/TEXT.DOC +++ /dev/null @@ -1,94 +0,0 @@ - Gulliver'ó Travels - Parô I - - Á Voyagå tï Lilliput - - Chap® I - - -Mù fatheò haä á smalì estatå iî Nottinghamshire» É waó thå  thirä -oæ  fivå  sons®  Hå senô må tï Emanueì Collegå  iî  Cambridgå  aô -fourteeî  yearó  old¬ wherå É resideä threå  years¬  anä  applieä -myselæ  closå  tï mù studiesº buô thå chargå  oæ  maintaininç  må -(althougè  É haä á verù scantù allowance© beinç toï greaô  foò  á -narro÷  fortune¬  É waó bounä apprenticå tï Mr® Jameó  Bates¬  aî -eminenô surgeoî iî London¬ witè whoí É continueä fouò years»  anä -mù  fatheò  no÷ anä theî sendinç må smalì sumó oæ money¬  É  laiä -theí  ouô  iî  learninç  navigation¬  anä  otheò  partó  oæ   thå -mathematics¬  usefuì tï thoså whï intenä tï travel¬ aó  É  alwayó -believeä iô woulä bå somå timå oò otheò mù fortunå tï do® Wheî  É -lefô Mr® Bates¬ É wenô dowî tï mù father» wherå bù thå assistancå -oæ  hií anä mù unclå John¬ anä somå otheò relations¬ É goô  fortù -pounds¬  anä á promiså oæ thirtù poundó á yeaò tï maintaiî må  aô -Leydenº  therå  É  studieä physiã twï  yearó  anä  seveî  months¬ -knowinç iô woulä bå usefuì iî lonç voyages. - -Sooî  afteò mù returî froí Leyden¬ É waó recommended¬ bù mù  gooä -masteò Mr® Bates¬ tï bå surgeoî tï thå "Swallow,¢ Captaiî Abrahaí -Panneì  commander» witè whoí É continueä threå yearó anä á  half¬ -makinç  á  voyagå oò twï intï thå Levant¬ anä somå  otheò  parts® -Wheî  É  camå back¬ É resolveä tï settlå iî Londoî tï  whicè  Mr® -Bates¬ mù master¬ encourageä me¬ anä bù hií É waó recommendeä  tï -severaì  patients® É tooë parô oæ á smalì houså iî thå Olä  Jury» -anä  beinç  adviseä tï alteò maù condition¬ É marrieä  Mrs®  Marù -Burton¬ seconä daughteò tï Mr® Edmunä Burton¬ hosieò iî  Newgatå- -street¬ witè whoí É receiveä fouò hundreä poundó foò á portion. - -But¬ mù gooä masteò Bateó dyinç iî twï yearó after¬ anä É  havinç -fe÷  friends¬ mù businesó begaî tï fail» foò mù consciencå  woulä -noô  suffeò må tï imitatå thå baä practicå oæ toï manù  amonç  mù -brethren®   Havinç thereforå consulteä witè mù wife¬ anä somå  oæ -mù  acquaintance¬ É determineä tï gï agaiî tï sea® É waó  surgeoî -successivelù  iî  twï ships¬ anä madå severaì  voyages¬  foò  siø -years¬ tï thå Easô anä Wesô-Indies¬ bù whicè É goô somå  additioî -tï  mù fortune® Mù houró oæ leisurå É spenô iî readinç  thå  besô -authors¬  ancienô anä modern¬ beinç alwayó provideä witè  á  gooä -numbeò oæ books» anä wheî É waó ashore¬ iî observinç thå  manneró -anä  dispositionó  oæ  thå  people¬ aó  welì  aó  learninç  theiò -language¬  whereiî É haä á greaô facilitù bù thå strengtè  oæ  mù -memory. - -Thå  lasô  oæ theså voyageó noô provinç verù  fortunate¬  É  gre÷ -wearù  oæ thå sea¬ anä intendeä tï staù aô homå witè mù wifå  anä -family®   É  removeä froí thå Olä Jurù tï Fetteò-Lane¬  anä  froí -thencå tï Wapping¬ hopinç tï geô businesó amonç thå sailors»  buô -iô woulä noô turî tï account® Afteò threå yearó expectatioî  thaô Šthingó woulä mend¬ É accepteä aî advantageouó offeò froí  Captaiî -Williaí  Prichard¬  masteò oæ thå "Antelope,¢ whï  waó  makinç  á -voyagå  tï thå Soutè-Sea® Wå seô saiì froí Bristoì Maù  4¬  1699¬ -anä ouò voyagå waó verù prosperous. - -Iô  woulä noô bå proper¬ foò somå reasons¬ tï troublå thå  readeò -witè  thå  particularó oæ ouò adventureó iî thoså  seasº  leô  iô -sufficå  tï  inforí him¬ thaô iî ouò passagå froí thencå  tï  thå -Easô-Indies¬ wå werå driveî bù á violenô storí tï thå  nortè-wesô -oæ  Vaî Diemen'ó Land® Bù aî observation¬ wå founä  ourselveó  iî -thå  latitudå oæ 3° degreeó ² minuteó south® Twelvå oæ  ouò  cre÷ -werå  deaä bù immoderatå labouò anä ilì food¬ thå resô werå iî  á -verù  weaë  condition® Oî thå fiftè oæ November¬  whicè  waó  thå -beginninç oæ summeò iî thoså parts¬ thå weatheò beinç verù  hazy¬ -thå  seameî  spieä á rock¬ withiî halæ á cable'ó  lengtè  oæ  thå -ship»  buô thå winä waó sï strong¬ thaô wå werå  driveî  directlù -upoî  it¬ anä immediatelù split® Siø oæ thå crew¬ oæ whoí  É  waó -one¬  havinç leô dowî thå boaô intï thå sea¬ madå á shifô tï  geô -cleaò oæ thå ship¬ anä thå rock® Wå roweä bù mù computatioî abouô -threå leagues¬ tilì wå werå ablå tï worë nï longer¬ beinç alreadù -spenô  witè  labouò  whilå wå werå iî  thå  ship®   Wå  thereforå -trusteä ourselveó tï thå mercù oæ thå waves¬ anä iî abouô halæ aî -houò thå boaô waó overseô bù á suddeî flurrù froí thå north® Whaô -becamå mù companionó iî thå boat¬ aó welì aó oæ thoså whï escapeä -oî  thå  rock¬  oò werå lefô iî thå vessel¬ É  cannoô  tell»  buô -concludå  theù werå alì lost® Foò mù owî part¬ É swaí aó  fortunå -directeä  me¬ anä waó pusheä forwarä bù winä anä tide®   É  ofteî -leô mù legó droð anä coulä feeì nï bottomº buô wheî É waó  almosô -gone¬  anä ablå tï strugglå nï longer¬ É founä myselæ  withiî  mù -depth» anä bù thió timå thå storí waó mucè abated® Thå  declivitù -waó  sï  small¬  thaô É walkeä neaò á milå beforå É  goô  tï  thå -shore¬  whicè  É  conjectureä  waó abouô  eighô  o'clocë  iî  thå -evening® É theî advanceä forwarä neaò halæ á mile¬ buô coulä  noô -discoveò anù sigî oæ houseó oò inhabitants» aô leasô É waó iî  sï -weaë  á condition¬ thaô É diä noô observå them® É  waó  extremelù -tired¬ anä witè that¬ anä thå heaô oæ thå weather¬ anä abouô halæ -á pinô oæ brandù thaô É dranë aó É lefô thå ship¬ É founä  myselæ -mucè inclineä tï sleep. - - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/TW.COM b/software/CPM/CPM30_WORDSTAR_v400/TW.COM deleted file mode 100644 index 57747ef..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/TW.COM and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/WC.COM b/software/CPM/CPM30_WORDSTAR_v400/WC.COM deleted file mode 100644 index 857ca9b..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/WC.COM and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/WINSTALL.COM b/software/CPM/CPM30_WORDSTAR_v400/WINSTALL.COM deleted file mode 100644 index 4ed26d0..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/WINSTALL.COM and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/WORDFREQ.COM b/software/CPM/CPM30_WORDSTAR_v400/WORDFREQ.COM deleted file mode 100644 index 27e74c5..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/WORDFREQ.COM and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/WS.COM b/software/CPM/CPM30_WORDSTAR_v400/WS.COM deleted file mode 100644 index 86cfe91..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/WS.COM and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/WS.OVR b/software/CPM/CPM30_WORDSTAR_v400/WS.OVR deleted file mode 100644 index 0043419..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/WS.OVR and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/WSCHANGE.COM b/software/CPM/CPM30_WORDSTAR_v400/WSCHANGE.COM deleted file mode 100644 index 2bcc433..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/WSCHANGE.COM and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/WSCHANGE.OVR b/software/CPM/CPM30_WORDSTAR_v400/WSCHANGE.OVR deleted file mode 100644 index a212266..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/WSCHANGE.OVR and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/WSCHHELP.OVR b/software/CPM/CPM30_WORDSTAR_v400/WSCHHELP.OVR deleted file mode 100644 index bad58e6..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/WSCHHELP.OVR and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/WSHELP.OVR b/software/CPM/CPM30_WORDSTAR_v400/WSHELP.OVR deleted file mode 100644 index 0263467..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/WSHELP.OVR and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/WSINDEX.XCL b/software/CPM/CPM30_WORDSTAR_v400/WSINDEX.XCL deleted file mode 100644 index 4b0e5c5..0000000 --- a/software/CPM/CPM30_WORDSTAR_v400/WSINDEX.XCL +++ /dev/null @@ -1,232 +0,0 @@ -A -ABOUT -ABOVE -ACROSS -AFTER -AFTERWARDS -AGAIN -AGAINST -AGO -AHEAD -ALIKE -ALL -ALMOST -ALONE -ALONG -ALREADY -ALSO -ALTHOUGH -ALTOGETHER -ALWAYS -AMONG -AN -AND -ANOTHER -ANY -ANYMORE -ANYONE -ANYTHING -ANYWAY -ANYWHERE -ARE -AREN'T -AROUND -AS -ASIDE -AT -AVAILABLE -AWAY -B -BE -BECAUSE -BEEN -BEFORE -BEFOREHAND -BELOW -BENEATH -BESIDES -BETWEEN -BEYOND -BUT -BY -C -D -DID -DIDN'T -DO -DOES -DOESN'T -DONE -DON'T -DOWN -DOWNRIGHT -E -EACH -EITHER -ELSE -EVEN -EVER -EXCEPT -F -FINALLY -FOR -FROM -G -H -HAD -HADN'T -HAPPEN -HAS -HASN'T -HAVE -HAVEN'T -HE -HER -HERE -HERE'S -HERS -HIM -HIS -HOW -HOWEVER -I -IF -IN -INTO -IS -ISN'T -IT -ITS -ITSELF -IT'LL -IT'S -I'D -I'LL -I'M -I'VE -J -JUST -K -KNOW -KNOWING -KNOWS -L -LIKE -M -MAYBE -ME -MY -N -NO -NONE -NOR -NOT -NOW -O -OF -OFF -OFTEN -OH -ON -ONLY -ONTO -OR -OTHER -OTHERWISE -OUR -OURS -OUT -OVER -P -Q -R -S -SHE -SINCE -SO -SOME -SOON -SOONER -SUCH -T -THAN -THAT -THAT'S -THE -THEIR -THEM -THEMSELVES -THEN -THERE -THEREFORE -THERE'LL -THERE'S -THESE -THEY -THEY'D -THEY'LL -THEY'RE -THEY'VE -THIS -THOSE -THOUGH -THROUGH -THROUGHOUT -THUS -TIL -TO -TOGETHER -TOO -U -UN -UNDER -UNTIL -UP -US -V -VALUE -VALUED -VERY -W -WAS -WASN'T -WE -WE'D -WE'LL -WE'RE -WE'VE -WHAT -WHATEVER -WHATEVER'S -WHAT'S -WHEN -WHENEVER -WHERE -WHEREAS -WHEREVER -WHERE'S -WHETHER -WHICH -WHICHEVER -WHILE -WHO -WHOSE -WHY -WILL -WITH -WITHIN -WITHOUT -WON'T -X -YES -YET -YOU -YOUR -YOURS -YOURSELF -YOU'D -YOU'LL -YOU'RE -YOU'VE -Z - \ No newline at end of file diff --git a/software/CPM/CPM30_WORDSTAR_v400/WSMSGS.OVR b/software/CPM/CPM30_WORDSTAR_v400/WSMSGS.OVR deleted file mode 100644 index 7f16fda..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/WSMSGS.OVR and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/WSPRINT.OVR b/software/CPM/CPM30_WORDSTAR_v400/WSPRINT.OVR deleted file mode 100644 index 6f5aa69..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/WSPRINT.OVR and /dev/null differ diff --git a/software/CPM/CPM30_WORDSTAR_v400/WSSHORT.OVR b/software/CPM/CPM30_WORDSTAR_v400/WSSHORT.OVR deleted file mode 100644 index d240a40..0000000 Binary files a/software/CPM/CPM30_WORDSTAR_v400/WSSHORT.OVR and /dev/null differ diff --git a/software/CPM/CPM31_WORDSTAR_v330/CD.COM b/software/CPM/CPM31_WORDSTAR_v330/CD.COM deleted file mode 100644 index e3f938d..0000000 Binary files a/software/CPM/CPM31_WORDSTAR_v330/CD.COM and /dev/null differ diff --git a/software/CPM/CPM31_WORDSTAR_v330/DEMO.TXT b/software/CPM/CPM31_WORDSTAR_v330/DEMO.TXT deleted file mode 100644 index 8473dee..0000000 --- a/software/CPM/CPM31_WORDSTAR_v330/DEMO.TXT +++ /dev/null @@ -1,20 +0,0 @@ -Dear Mom: - -You'lì neveò believå whaô happeneä lasô week!  É finallù decideä -tï  takå  thå  oshaî  tï oshaî  (actuallù  Phillydelphyá  tï  Saî -Fransisco© railroaä trip®  Iî thå nationeì wilderneó areá outsidå -oæ Chicogo¬ thå traiî wenô ofæ thå trax® Nï onå waó hurt¬ buô onå -alderlù ladù complainä loudlù thaô thå traiî companù waó goinç tï -havå tï paù foò á heò ne÷ quafeur. - -Iô turnó ouô thaô wå stoppeä oî toð oæ aî olä semetry®  Yoõ kno÷ -ho÷  É  aí  abouô theí -- iô tooë á loô oæ  disiplinå  tï  remaiî -conshus®  Fortunatelù  É useä somå gooä jugemenô anä saô dowî  - -unfortunatelù  É  imbeddeä á sliveò iî mù leg®  Iî  additioî  tï -that¬  É  developeä newmoanyá froí sittinç ouô iî thå colä  nighô -air® I'lì writå morå wheî É feeì better. - -Love, - -Your son, -Ken \ No newline at end of file diff --git a/software/CPM/CPM31_WORDSTAR_v330/MAILMRGE.OVR b/software/CPM/CPM31_WORDSTAR_v330/MAILMRGE.OVR deleted file mode 100644 index 31303eb..0000000 Binary files a/software/CPM/CPM31_WORDSTAR_v330/MAILMRGE.OVR and /dev/null differ diff --git a/software/CPM/CPM31_WORDSTAR_v330/PRINT.TST b/software/CPM/CPM31_WORDSTAR_v330/PRINT.TST deleted file mode 100644 index 202e461..0000000 --- a/software/CPM/CPM31_WORDSTAR_v330/PRINT.TST +++ /dev/null @@ -1,121 +0,0 @@ -.cw12 -.hå (Thió texô ió á printouô oæ thå filå nameä PRINT.TST) -.fï WordStaò Overvie÷ Pagå # - - Welcome_to_WordStar* - -WordStar‚  ió  á powerfuì worä processinç systeí designeä tï  meeô -texô preparatioî requirementó foò alì leveló oæ usersº - - * professional writers - * programmers - * text editors - * office administrators - * clerical staff - * students - - SPECIAL PRINTING CAPABILITIES INCLUDE: - - * Boldface¬  Doublå  Strike¬  Underline“  - - * Strikeout¬ Overprint (co^te) - - * SUPERScript - - * SUBScript - - * and any combination -- WordStar - - -On-screen printer-image text formatting commands include - Automatic-Centering‚ -whicè  allowó texô tï bå automaticallù centereä oî á linå witè  á -two-strokå  command®  - - Margiî settingó caî bå changed¬ anä -                              thå   reformatteä   texô  wilì   bå -                              displayeä oî command® -                               -                              Selectivå    margination‚    permitó -                              "cutting¢ arounä aî illustration® - -Á  widå rangå oæ letteò qualitù anä drafô printeró arå  supporteä -(includinç Diablo¬  NEC¬  Qume¬  Epsoî anä  Olivetti)®  WordStar -fullù utilizeó bidirectionaì printinç capability® - -Somå  printeró  wilì  supporô  WordStar„  commandó  whicè  specifù -variablå linå heighô anä variablå anä alternatå characteò pitch. - -(The examples below will not be demonstrated by all printers.) - -.CW19 -This is an example of variable pitch. (.CW 19) -.CW15 -This is an example of variable pitch. (.CW 15) -.CW12 -This is an example of variable pitch. (.CW 12) -.CW11 -This is an example of variable pitch. (.CW 11) -.CW10 -This is an example of variable pitch. (.CW 10) - -.cw12 -* WordStar„  ió  á registereä trademarë oæ MicroPrï  Internationaì -  Corporation. Š.LH 20 - This is an example of variable line height. (.LH 20) -.LH 18 - This is an example of variable line height. (.LH 18) -.LH 16 - This is an example of variable line height. (.LH 16) -.LH 14 - This is an example of variable line height. (.LH 14) -.LH 12 - This is an example of variable line height. (.LH 12) -.LH 10 - This is an example of variable line height. (.LH 10) -.LH 8 - This is an example of variable line height. (.LH 8) -.LH 6 - This is an example of variable line height. (.LH 6) -.LH 8 - -Daisù  wheeì  printeró  caî alsï bå seô tï "toggle¢  betweeî  thå -standard 10-pitch and alternate 12-pitch printing: - - This sentence is printed with the normal 10-pitch setting, - then toggled to 12-pitch, then back to normal. - - -Tï  seå  thå embeddeä commandó whicè produceä thió  text¬  follo÷ -thió procedure: - - - Iî responså tï thå basiã prompô froí youò system¬ enter - -        wó  - - - Wheî  thå  Openinç Menõ appearó oî  youò  screen¬  typå  D‚ -       (ord©  tï  ediô á document®  Then¬  iî responså  tï  thå -       requesô foò filå name¬ type - - print.tst  - -Thå  firsô  thinç yoõ wilì noticå ió thaô thå texô oî thå  screeî -includeó somå characteró whicè dï noô appeaò oî thå printeä copy® -Foò example: - - ï thå headinç linå ió identifieä bù á doô command¬ .hå - - o words in boldface are marked by "^B" - -Tï  continuå  viewinç PRINT.TSÔ oî youò screen¬  trù eacè oæ  thå -followinç commandó tï scrolì througè thå file: - - CTRÌ Ã tï vie÷ thå NEXÔ fulì seô oæ lines - - CTRÌ Ò tï vie÷ thå PRECEDINÇ fulì seô oæ lines - - NOTEº Holä dowî thå CTRÌ keù whilå yoõ presó thå nexô key. - -Wå  thinë yoõ wilì finä WordStaò aî easy-to-use¬  essentiaì  tooì -foò alì youò texô processinç needs® - \ No newline at end of file diff --git a/software/CPM/CPM31_WORDSTAR_v330/Read.me b/software/CPM/CPM31_WORDSTAR_v330/Read.me deleted file mode 100644 index 452b770..0000000 --- a/software/CPM/CPM31_WORDSTAR_v330/Read.me +++ /dev/null @@ -1,2 +0,0 @@ -The files WSterminalname.COM are patched files for the indicated terminal. -You should rename the appropriate file to WS.COM. diff --git a/software/CPM/CPM31_WORDSTAR_v330/SAMPLE.TXT b/software/CPM/CPM31_WORDSTAR_v330/SAMPLE.TXT deleted file mode 100644 index 92c7be6..0000000 --- a/software/CPM/CPM31_WORDSTAR_v330/SAMPLE.TXT +++ /dev/null @@ -1,73 +0,0 @@ -.op - Apriì 1¬ 198± - - Calviî P® Hotstuff - Freewheelinç Enterprises - Biloxi¬ Mississippé - - -MicroPrï Internatoinal -129¹ Fourtè Street -Saî Rafael¬ Californiá 94901 - Attnº Customeò Service - -Deaò Sirs: - - É  wanô  tï starô bù tellinç yoõ thaô É thinë WordStaò ió  á -verù  finå worä processor®  Yoõ peoplå aô MicroPrï havå  outdonå -yourselveó designinç thió programm¡  É couldn'ô appreciatå  morå -whaô iô haó donå foò mù career®  Howeveò É feeì thaô É musô brinç -tï  youò  attentioî  á probleí É havå beeî havinç  witè  WordStaò -lately. - - É goô mù WordStaò threå monthó ago¬  anä waó amazeä aô  whaô -aî exciting¬  hard-wrknç programí iô is®  Iô didn'ô takå lonç tï -learî thå commandó anä sooî É waó usinç WordStaò foò everythinç É -did®  Letters¬ reports¬ memoó - alì werå perfectlù formatteä anä -printed® Anä editinç mù weeklù saleó survaù waó á breeze! - - WordStaò  anä  É  becamå inseparablå -- whaô á  greaô  team¡ -Wheî É ordereä MailMerge¬ thingó starteä goinç sï welì thaô É goô -promoteä tï Europeaî Saleó Manager®  Mù worë goô donå sï quicklù -anä  efficientlù thaô É starteä tï havå extrá timå oî  mù  hands® -Sï  É  signeä  uð foò discï rolleò skatinç classeó aô thå  Ù  anä -boughô myselæ á crusheä velveô jumpsuit® - - Prettù  sooî  É waó hittinç thå rolleò  discoó  nightlù  anä -havinç myselæ á ball®  É meô Maureeî aô Whiskey'ó Discï Citù anä -felì iî love® Wå werå dynamitå oî wheels! - - Righô abouô theî É starteä noticinç littlå thingó werå goinç -wronç  witè mù WordStar®  Exclamatioî pointó woulä poð uð iî thå -middlå oæ thå screeî anä typoó begaî tï sneaë intï mù corespond -ence®  Sometimeó  WordStaò  woulä  jusô dra÷  á  blank¡  Nexô  É -realizeä thaô thå helð screenó haä alì disappeared¬ anä control- -haä stoppeä working® Iô waó alì downhilì froí there. - - Thå daù Maureeî anä É announceä ouò engagemenô É  discovereä -cigarettå  stainó  oî thå keytopó anä WordStaò waó  hiccupinç  aô -pagå breaks® É waó distraught¡ É trieä tï prinô mù weeklù saleó -surveù  anä  alì  É  goô waó twï pageó oæ questioî  markó  anä  á -paragrapè froí Unclå Tom'ó Cabin® -.pa Š.pn - Well¬  I'í  aô mù wit'ó end®  É lovå WordStar®  É  owå  mù -promotioî anä eveî mù happù marriagå tï WordStar'ó brilliancå anä -itó onscreeî helð menus® Buô É havå tï puô mù fooô down® É jusô -can'ô allo÷ thió kinä oæ insubodrination®  Aó yoõ caî seå bù thå -numbeò oæ typoó iî thió letter¬ thingó haven'ô gotteî anù better¬ -despitå mù offeò tï takå WordStaò discï dancing® - - Whaô dï yoõ suggesô -- grouð therapy¿ AA¿ Maybå á vacatioî -iî Southerî California¿ I'í willinç tï dï whateveò iô takes¬ buô -É  musô  confesó I'vå neveò haä thió kinä oæ managemenô  probleí -before®  É hopå yoõ caî helð må ouô witè mù dilemmá -- É reallù -don'ô wanô tï loså WordStar. - - Verù trulù yours, - - - Calviî P® Hotstuff - Europeaî Saleó Manager - -CH/wó - \ No newline at end of file diff --git a/software/CPM/CPM31_WORDSTAR_v330/SPELSTAR.DCT b/software/CPM/CPM31_WORDSTAR_v330/SPELSTAR.DCT deleted file mode 100644 index 8d33258..0000000 Binary files a/software/CPM/CPM31_WORDSTAR_v330/SPELSTAR.DCT and /dev/null differ diff --git a/software/CPM/CPM31_WORDSTAR_v330/SPELSTAR.OVR b/software/CPM/CPM31_WORDSTAR_v330/SPELSTAR.OVR deleted file mode 100644 index 62870ca..0000000 Binary files a/software/CPM/CPM31_WORDSTAR_v330/SPELSTAR.OVR and /dev/null differ diff --git a/software/CPM/CPM31_WORDSTAR_v330/WINSTALL.COM b/software/CPM/CPM31_WORDSTAR_v330/WINSTALL.COM deleted file mode 100644 index 9423881..0000000 Binary files a/software/CPM/CPM31_WORDSTAR_v330/WINSTALL.COM and /dev/null differ diff --git a/software/CPM/CPM31_WORDSTAR_v330/WS.INS b/software/CPM/CPM31_WORDSTAR_v330/WS.INS deleted file mode 100644 index aabf075..0000000 Binary files a/software/CPM/CPM31_WORDSTAR_v330/WS.INS and /dev/null differ diff --git a/software/CPM/CPM31_WORDSTAR_v330/WS330 patch points.txt b/software/CPM/CPM31_WORDSTAR_v330/WS330 patch points.txt deleted file mode 100644 index 690a519..0000000 --- a/software/CPM/CPM31_WORDSTAR_v330/WS330 patch points.txt +++ /dev/null @@ -1,72 +0,0 @@ - WS.COM PATCH POINTS - (abbreviated and updated from WSBIBLE.DOC) - (system control and printer patch points not included) - (versions prior to 2.26 do no use labels, use address instead) - -00 = hex number -#00 = hex number that tells how many hex bytes follow -00-00 = a range of hex numbers -< > = comments -To modify the actual file, subtract 100h from the memory location (IE: 193=093) - - MEM - LOC -LABEL 330 LEN INSTALLED ID TEST RANGE DEFAULT ------- --- --- ------------------------------------- ----- -------- -IDTEX 18A 34 TERMINAL ID TEXT (varies) -PIDTEX 1AE 34 PRINTER ID TEXT (varies) -PROTTX 1D2 34 PRINTER PROTOCOL TEXT (varies) -PDRVTX 1F6 34 PORT DRIVER TEXT (varies) - 128 1 INSTALL FLAG(00=installed,FF=not inst) 00 FF 00 - -LABEL 330 LEN TERMINAL ESCAPE SEQUENCE CODES CTRL RANGE DEFAULT ------- --- --- ------------------------------------- ----- -------- -HITE 232 1 SCREEN HEIGHT(24 lines) 10-19 18 -WID 233 1 SCREEN WIDTH(80 columns) 40-50 50 -CLEAD1 234 9 CURSOR POS-LEAD-IN STR #00 00-00 -CLEAD2 23D 5 CURSOR POS-STR BETWEEN COL/LINE #00 00-00 -CTRAIL 242 5 CURSOR POS-TRAILING STR #00 00-00 -CB4LFG 247 1 CURSOR POS-FLAG(00=ln/col,FF=col/ln) 00 FF 00 -LINOFF 248 1 CURSOR POS-LINE OFFSET 00-20 20 -COLOFF 249 1 CURSOR POS-COLUMN OFFSET 00-20 20 -ASCUR 24A 1 CURSOR POS-DATA(00=binary,02=digit) 00 02 00 -ERAEOL 250 7 ERASE TO END OF LINE ^QY #00 00-00 -LINDEL 257 7 DELETE LINE ^Y #00 00-00 -LININS 25E 9 INSERT LINE ^N #00 00-00 -IVON 267 7 TURN ON HIGHLIGHTING #00 00-00 - (inverse video, half intensity, underlining) -IVOFF 26E 7 TURN OFF HIGHLIGHTING #00 00-00 - (inverse video, half intensity, underlining) -TRMINI 275 9 TERMINAL INITIALIZATION STRING #00 00-00 -TRMUNI 27E 9 TERMINAL UNINITIALIZATION STRING #00 00-00 -USELST 28D 1 CAN USE LAST LINE ON CRT FLAG(FF=on,00=off) 00 - -LABEL 330 LEN INITIAL DELAYS RANGE DEFAULT ------- --- --- ------------------------------------- ----- -------- -DELCUS 28E 1 CURSOR ADDRESSING DELAY(msec) 00-FF 0A -DELMIS 28F 1 OTHER MISC FUNCT DELAY(msec) 00-FF 05 -DEL1 2AF 1 CURSOR BLINK-ON SHORT DELAY(msec) 00-FF 03 -DEL2 2B0 1 CURSOR BLINK-OFF MED-SHORT DELAY(msec) 00-FF 09 -DEL3 2B1 1 SUBMENUS MED-LONG DELAY(msec) 00-FF 19 -DEL4 2B2 1 MESSAGES AND SIGN-ONS LONG DELAY(msec) 00-FF 40 -DEL5 2B3 1 SCREEN REDISPLAY/REFRESH DELAY(msec) 00-FF 09 - -LABEL 330 LEN INITIAL SETUP CTRL RANGE DEFAULT ------- --- --- ------------------------------------- ----- -------- -DEFDSK 2B9 1 FIND .OVR FILES ON DRIVE(01=A:,02=B:) 01-16 01 -ITHELP 34D 1 HELP LEVEL ^JH 00-03 03 -ITITOG 34F 1 INSERT MODE(FF=on,00=off) ^V 00 FF FF -ITDSDR 350 1 FILE DIR DISPLAY(FF=on,00=off) ^KF 00 FF FF -INITWF 36D 1 WORD WRAP(FF=on,00=off) ^OW 00 FF FF - +1 36E 1 JUSTIFY(FF=on,00=off) ^OJ 00 FF FF - +2 36F 1 VARIABLE TABS(FF=on,00=off) ^OV 00 FF FF - +3 370 1 SOFT HYPHEN(FF=on,00=off) ^OE 00 FF 00 - +4 371 1 HYPEN-HELP(FF=on,00=off) ^OH 00 FF FF - +5 372 1 CNTRL CHARS DISPLAY(FF=on,00=off) ^OD 00 FF FF - +6 373 1 RULER LINE DISPLAY(FF=on,00=off) ^OT 00 FF FF - +8 375 1 PAGE BREAK DISPLAY(FF=on,00=off) ^OP 00 FF FF - +9 376 1 LINE SPACING ^OS 01-09 01 - +A 377 1 MODE(FF=column,00=block) ^KN 00 FF 00 - - 81A END OF USER PATCHING ACCESSABLE AREA - \ No newline at end of file diff --git a/software/CPM/CPM31_WORDSTAR_v330/WSMSGS.OVR b/software/CPM/CPM31_WORDSTAR_v330/WSMSGS.OVR deleted file mode 100644 index b4fb5b5..0000000 Binary files a/software/CPM/CPM31_WORDSTAR_v330/WSMSGS.OVR and /dev/null differ diff --git a/software/CPM/CPM31_WORDSTAR_v330/WSOVLY1.OVR b/software/CPM/CPM31_WORDSTAR_v330/WSOVLY1.OVR deleted file mode 100644 index 962fb53..0000000 Binary files a/software/CPM/CPM31_WORDSTAR_v330/WSOVLY1.OVR and /dev/null differ diff --git a/software/CPM/CPM31_WORDSTAR_v330/WSU.COM b/software/CPM/CPM31_WORDSTAR_v330/WSU.COM deleted file mode 100644 index 5f15311..0000000 Binary files a/software/CPM/CPM31_WORDSTAR_v330/WSU.COM and /dev/null differ diff --git a/software/CPM/CPM31_WORDSTAR_v330/WSbondwell.COM b/software/CPM/CPM31_WORDSTAR_v330/WSbondwell.COM deleted file mode 100644 index 677f7da..0000000 Binary files a/software/CPM/CPM31_WORDSTAR_v330/WSbondwell.COM and /dev/null differ diff --git a/software/CPM/CPM31_WORDSTAR_v330/WSheath.COM b/software/CPM/CPM31_WORDSTAR_v330/WSheath.COM deleted file mode 100644 index 59e596e..0000000 Binary files a/software/CPM/CPM31_WORDSTAR_v330/WSheath.COM and /dev/null differ diff --git a/software/CPM/CPM31_WORDSTAR_v330/WSkayproii.COM b/software/CPM/CPM31_WORDSTAR_v330/WSkayproii.COM deleted file mode 100644 index e0d1757..0000000 Binary files a/software/CPM/CPM31_WORDSTAR_v330/WSkayproii.COM and /dev/null differ diff --git a/software/CPM/CPM31_WORDSTAR_v330/WSosborne1.COM b/software/CPM/CPM31_WORDSTAR_v330/WSosborne1.COM deleted file mode 100644 index a3956a9..0000000 Binary files a/software/CPM/CPM31_WORDSTAR_v330/WSosborne1.COM and /dev/null differ diff --git a/software/CPM/CPM31_WORDSTAR_v330/WStelevideo950.COM b/software/CPM/CPM31_WORDSTAR_v330/WStelevideo950.COM deleted file mode 100644 index 6ab5c9f..0000000 Binary files a/software/CPM/CPM31_WORDSTAR_v330/WStelevideo950.COM and /dev/null differ diff --git a/software/CPM/CPM31_WORDSTAR_v330/ws3.hex b/software/CPM/CPM31_WORDSTAR_v330/ws3.hex deleted file mode 100644 index 6eccd67..0000000 Binary files a/software/CPM/CPM31_WORDSTAR_v330/ws3.hex and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/!(C)1988 b/software/CPM/CPM32_ZCPR3/!(C)1988 deleted file mode 100755 index 1436706..0000000 Binary files a/software/CPM/CPM32_ZCPR3/!(C)1988 and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/!NZ-COM b/software/CPM/CPM32_ZCPR3/!NZ-COM deleted file mode 100755 index e69de29..0000000 diff --git a/software/CPM/CPM32_ZCPR3/!VERS--1.2H b/software/CPM/CPM32_ZCPR3/!VERS--1.2H deleted file mode 100755 index e69de29..0000000 diff --git a/software/CPM/CPM32_ZCPR3/ALIAS.CMD b/software/CPM/CPM32_ZCPR3/ALIAS.CMD deleted file mode 100755 index 936006c..0000000 Binary files a/software/CPM/CPM32_ZCPR3/ALIAS.CMD and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/ARUNZ.COM b/software/CPM/CPM32_ZCPR3/ARUNZ.COM deleted file mode 100755 index 041b87c..0000000 Binary files a/software/CPM/CPM32_ZCPR3/ARUNZ.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/BGZRDS19.LBR b/software/CPM/CPM32_ZCPR3/BGZRDS19.LBR deleted file mode 100755 index 5849efa..0000000 Binary files a/software/CPM/CPM32_ZCPR3/BGZRDS19.LBR and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/CLEDINST.COM b/software/CPM/CPM32_ZCPR3/CLEDINST.COM deleted file mode 100755 index c26a3cf..0000000 Binary files a/software/CPM/CPM32_ZCPR3/CLEDINST.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/CLEDSAVE.COM b/software/CPM/CPM32_ZCPR3/CLEDSAVE.COM deleted file mode 100755 index dde04bc..0000000 Binary files a/software/CPM/CPM32_ZCPR3/CLEDSAVE.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/CONFIG.LBR b/software/CPM/CPM32_ZCPR3/CONFIG.LBR deleted file mode 100755 index 40d87ae..0000000 Binary files a/software/CPM/CPM32_ZCPR3/CONFIG.LBR and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/COPY.COM b/software/CPM/CPM32_ZCPR3/COPY.COM deleted file mode 100755 index 734953d..0000000 Binary files a/software/CPM/CPM32_ZCPR3/COPY.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/CPSET.COM b/software/CPM/CPM32_ZCPR3/CPSET.COM deleted file mode 100755 index 54462ce..0000000 Binary files a/software/CPM/CPM32_ZCPR3/CPSET.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/CRUNCH.COM b/software/CPM/CPM32_ZCPR3/CRUNCH.COM deleted file mode 100755 index ac17854..0000000 Binary files a/software/CPM/CPM32_ZCPR3/CRUNCH.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/DOCFILES.LBR b/software/CPM/CPM32_ZCPR3/DOCFILES.LBR deleted file mode 100755 index c96cd42..0000000 Binary files a/software/CPM/CPM32_ZCPR3/DOCFILES.LBR and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/EDITNDR.COM b/software/CPM/CPM32_ZCPR3/EDITNDR.COM deleted file mode 100755 index 149cb98..0000000 Binary files a/software/CPM/CPM32_ZCPR3/EDITNDR.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/FCP.LBR b/software/CPM/CPM32_ZCPR3/FCP.LBR deleted file mode 100755 index 8eb74a4..0000000 Binary files a/software/CPM/CPM32_ZCPR3/FCP.LBR and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/FF.COM b/software/CPM/CPM32_ZCPR3/FF.COM deleted file mode 100755 index b68b2ad..0000000 Binary files a/software/CPM/CPM32_ZCPR3/FF.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/HELP.COM b/software/CPM/CPM32_ZCPR3/HELP.COM deleted file mode 100755 index 58b4d6f..0000000 Binary files a/software/CPM/CPM32_ZCPR3/HELP.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/HLPFILES.LBR b/software/CPM/CPM32_ZCPR3/HLPFILES.LBR deleted file mode 100755 index 32200cd..0000000 Binary files a/software/CPM/CPM32_ZCPR3/HLPFILES.LBR and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/IF.COM b/software/CPM/CPM32_ZCPR3/IF.COM deleted file mode 100755 index c51cd0b..0000000 Binary files a/software/CPM/CPM32_ZCPR3/IF.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/JETLDR.COM b/software/CPM/CPM32_ZCPR3/JETLDR.COM deleted file mode 100755 index c33c073..0000000 Binary files a/software/CPM/CPM32_ZCPR3/JETLDR.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/LBREXT.COM b/software/CPM/CPM32_ZCPR3/LBREXT.COM deleted file mode 100755 index 591922b..0000000 Binary files a/software/CPM/CPM32_ZCPR3/LBREXT.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/LBRHELP.COM b/software/CPM/CPM32_ZCPR3/LBRHELP.COM deleted file mode 100755 index eb1ef6e..0000000 Binary files a/software/CPM/CPM32_ZCPR3/LBRHELP.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/LDIR.COM b/software/CPM/CPM32_ZCPR3/LDIR.COM deleted file mode 100755 index d72eeef..0000000 Binary files a/software/CPM/CPM32_ZCPR3/LDIR.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/LPUT.COM b/software/CPM/CPM32_ZCPR3/LPUT.COM deleted file mode 100755 index 7271696..0000000 Binary files a/software/CPM/CPM32_ZCPR3/LPUT.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/LSH-HELP.COM b/software/CPM/CPM32_ZCPR3/LSH-HELP.COM deleted file mode 100755 index 0103795..0000000 Binary files a/software/CPM/CPM32_ZCPR3/LSH-HELP.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/LSH.COM b/software/CPM/CPM32_ZCPR3/LSH.COM deleted file mode 100755 index 6ec314f..0000000 Binary files a/software/CPM/CPM32_ZCPR3/LSH.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/LSH.WZ b/software/CPM/CPM32_ZCPR3/LSH.WZ deleted file mode 100755 index 690f991..0000000 Binary files a/software/CPM/CPM32_ZCPR3/LSH.WZ and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/LSHINST.COM b/software/CPM/CPM32_ZCPR3/LSHINST.COM deleted file mode 100755 index a9beb35..0000000 Binary files a/software/CPM/CPM32_ZCPR3/LSHINST.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/LX.COM b/software/CPM/CPM32_ZCPR3/LX.COM deleted file mode 100755 index d424f9f..0000000 Binary files a/software/CPM/CPM32_ZCPR3/LX.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/MKZCM.COM b/software/CPM/CPM32_ZCPR3/MKZCM.COM deleted file mode 100755 index ad0ce7b..0000000 Binary files a/software/CPM/CPM32_ZCPR3/MKZCM.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/NAME.COM b/software/CPM/CPM32_ZCPR3/NAME.COM deleted file mode 100755 index d3a8cdf..0000000 Binary files a/software/CPM/CPM32_ZCPR3/NAME.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/NZ-DBASE.INF b/software/CPM/CPM32_ZCPR3/NZ-DBASE.INF deleted file mode 100755 index 72f2169..0000000 Binary files a/software/CPM/CPM32_ZCPR3/NZ-DBASE.INF and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/NZBLITZ.COM b/software/CPM/CPM32_ZCPR3/NZBLITZ.COM deleted file mode 100755 index 0355279..0000000 Binary files a/software/CPM/CPM32_ZCPR3/NZBLITZ.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/NZBLTZ14.CFG b/software/CPM/CPM32_ZCPR3/NZBLTZ14.CFG deleted file mode 100755 index 5ffb875..0000000 Binary files a/software/CPM/CPM32_ZCPR3/NZBLTZ14.CFG and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/NZBLTZ14.HZP b/software/CPM/CPM32_ZCPR3/NZBLTZ14.HZP deleted file mode 100755 index 86d8590..0000000 Binary files a/software/CPM/CPM32_ZCPR3/NZBLTZ14.HZP and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/NZCOM.COM b/software/CPM/CPM32_ZCPR3/NZCOM.COM deleted file mode 100755 index b80c4d3..0000000 Binary files a/software/CPM/CPM32_ZCPR3/NZCOM.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/NZCOM.LBR b/software/CPM/CPM32_ZCPR3/NZCOM.LBR deleted file mode 100755 index bf432b4..0000000 Binary files a/software/CPM/CPM32_ZCPR3/NZCOM.LBR and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/NZCPR.LBR b/software/CPM/CPM32_ZCPR3/NZCPR.LBR deleted file mode 100755 index 1f51b0f..0000000 Binary files a/software/CPM/CPM32_ZCPR3/NZCPR.LBR and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/PATH.COM b/software/CPM/CPM32_ZCPR3/PATH.COM deleted file mode 100755 index 1245c1a..0000000 Binary files a/software/CPM/CPM32_ZCPR3/PATH.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/PUBLIC.COM b/software/CPM/CPM32_ZCPR3/PUBLIC.COM deleted file mode 100755 index e22e67d..0000000 Binary files a/software/CPM/CPM32_ZCPR3/PUBLIC.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/PWD.COM b/software/CPM/CPM32_ZCPR3/PWD.COM deleted file mode 100755 index dda7ce7..0000000 Binary files a/software/CPM/CPM32_ZCPR3/PWD.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/RCP.LBR b/software/CPM/CPM32_ZCPR3/RCP.LBR deleted file mode 100755 index fdc452f..0000000 Binary files a/software/CPM/CPM32_ZCPR3/RCP.LBR and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/RELEASE.NOT b/software/CPM/CPM32_ZCPR3/RELEASE.NOT deleted file mode 100755 index 6b00642..0000000 --- a/software/CPM/CPM32_ZCPR3/RELEASE.NOT +++ /dev/null @@ -1,266 +0,0 @@ - - RELEASE.NOT - UPDATE INFORMATION ON NZCOM - - -Please understand that unlike purely commercial enterprises, Z-System is -mainly the work of enthusiasts. As such, Z-System never truly reaches -completion; each new development is more of a plateau upon which further -innovation occurs. Though we have done our best, the printed documentation -inevitably lags behind the most recent enhancements. Try to consult as -much material as possible about a given command before proceeding; if there -is a help or document file pertaining to the command, it supercedes printed -instructions, especially with regard to such matters as syntax or technical -specifications. - - -Notes of September 12, 1991 -=========================== - - Release 1.2H involves a significant updating of the support utilities that -we distribute as a courtesy with NZCOM. We suggest that any Z-System user who -is not in regular contact with a Z-Node consider taking advantage of the Z- -System Software Update Service (ZSUS). Here are some of the important changes -with this release. - -ZCNFG.COM, CONFIG.LBR: - Al Hawley has introduced a powerful and convenient method for - configuring programs. ZCNFG works either with individual CFG files or - with CFG files stored in the CONFIG.LBR library. For example, try - running the command "ZCNFG ZLT". ZCNFG will automatically extract - ZLT15.CFG from CONFIG.LBR. - -NZBLITZ.COM, NZBLTZ14.HZP, NZBLTZ14.CFG: - These programs can be used to coldboot an NZCOM system very rapidly - with the complete system, including error handlers, shells, and TCAPs - already in place. Run "HELP NZBLTZ14" to learn more about it. Some - of its features can be tailored by running "ZCNFG NZBLITZ" with the - CFG file in the same directory. - -LBREXT.COM: - This replaces LGET for extracting member files from LBR library files. - -HELP.COM, LBRHELP.COM, HLPFILES.LBR: - HELP (actually HELPC14) is an improved version of the help utility. - It can work with normal help files (HLP) and crunched help files - (HZP). LBRHELP can work with normal or crunched help files that are - stored in a library (which is where we have put all the help files - distributed with NZCOM and Z3PLUS). - -DOCFILES.LBR: - Documentation and help files have been collected into an LBR file. - -ZLT.COM: - This is a full Z-System replacement for LT, and it handles the latest - LZH-compressed files. - -COPY.COM: - This is the version of COPY from the ZSDOS/ZDDOS release. Enter "COPY - //" for syntax information. It replaces a dangerously defective copy - program provided with earlier releases. - -LSH.COM, LSH.WZ, LSH-HELP.COM, LSHINST.COM, ZERR.COM: - These are the latest LSH command history shell and command-line editor - and the associated error handler (fixed-log versions). These - completely replace EASE. - -CLEDINST.COM, CLEDSAVE.COM: - A transient history shell like LSH can be slow on floppy systems with - sluggish disk drives, even if the files have been placed in optimal - locations. Some of the RCP modules supplied no include an RCP- - resident command-line editor called CLED. Its features can be - configured using CLEDINST.COM, and the history can be saved to a file - using CLEDSAVE.COM. - -TCAP.LBR, XTCAP.COM: - A number of programs now require a terminal capabilities descriptor - (TCAP) with extended functions. The standard TCAPs loaded with - TCSELECT do not have these functions. TCAP.LBR is a collection of - extended TCAPs for some terminals. XTCAP.COM is a program that can - add the most important extensions to a standard TCAP (it is a quick- - and-dirty fix until the full set of TCAPs is updated). - -VIEW.COM: - This is Bridger Mitchell's file viewing utility. It is very powerful - (but it requires an extended TCAP). - -NAME.COM: - This program can quickly add or remove a name for a single directory. - -TCJ.INF: - TCJ has a new publisher (one of our own Z-Node sysops), and this file - tells how to take out a subscription (which all Z-System users - absolutely should do!). - -ZFILEB38.LZT: - This is the BRIEF listing of all the support programs currently - available for use with Z-System. There is another file which includes - descriptions of all the programs, but it would fill up an entire - diskette! - - -Notes of November 5, 1989 -========================= - - 1. NEW FILES: NZCPR.LBR, FCP.LBR, RCP.LBR. - 2. TCSELECT PROBLEM. - 3. ERA.COM, REN.COM, SAVE.COM, ETC. - 4. LSH REPLACES EASE. - 5. NZBLITZ IS HERE! - 6. MINOR UPDATE NOTES. - 7. TO NEW Z-SYSTEM USERS. - 8. ALERT ABOUT NZCPM.COM AND NZCOM.CCP - 9. CHANGE IN MKZCM DEFAULT AND STANDARD RCP - 10. NZBIO+.ZRL - -1. NEW FILES: NZCPR.LBR, FCP.LBR, RCP.LBR. - -The main NZCOM.LBR now contains only the standard configurations of the -CPR, FCP, and RCP modules to minimize disk space requirements. Alternative -versions of these modules are now supplied in separate libraries. Modules -can be loaded directly from these libraries, or individual files can be -extracted and put into NZCOM.LBR to replace the default files. Each -library has a brief DOC file describing the modules (one of which is the -default version included in NZCOM.LBR). - - -2. TCSELECT PROBLEM. - -A problem has been discovered with the operation of TCSELECT as described -in the manual. TCSELECT is a Z-System program and does not function -reliably under CP/M (on some systems it causes a crash). Fortunately there -is a simple fix: reverse the order of the instructions in the manual. Boot -up NZ-COM before attempting to create MYTERM.Z3T, and run TCSELECT only -after NZ-COM is running. Remember that you need both TCSELECT.COM and -Z3TCAP.TCP to generate your .Z3T file. The entries in the Z3TCAP library -for the Xerox computers has been patched to correct a long-standing error. - - -3. ERA.COM, REN.COM, SAVE.COM, ETC. - -The standard configuration of Z-System does not include resident commands -for REN, DIR, or SAVE. These are provided instead as transient programs -(COM files), and you should copy any that you need to your working disk. -Several other functions that are often resident (but not always) are also -provided as COM files. Many of these are type-4 programs (see the manual). -We recommend using SDZ.COM as your standard directory display utility. It -is far more functional than the resident DIR commands in either Z-System or -CP/M, and it is designed to work properly under both. - - -4. LSH REPLACES EASE. - -EASE has been replaced by a newer, more versatile, and well-behaved program -named LSH (Log SHell). Like EASE, LSH allows you to edit command lines -using WordStar-like control. Consult LSH.WZ before use for general -information and/or run HELPLSH while running LSH for a display of LSH's -capabilities. LSHINST installs and customizes LSH to taste. Error -handling is now taken care of by ZERR.COM, a separate program. Our great -thanks to Rob Friefeld for writing these superb Z-System tools and for -allowing us to include them with NZ-COM. - - -5. NZBLITZ IS HERE! - -NZBLITZ is now included with NZ-COM. True to its name, NZBLITZ loads NZCOM -(and ZSDOS/ZDDOS, if present) in a flash, making it extremely helpful in -saving and reloading a given system configuration. Once you have configured -your system as wanted, log to drive A0: and type NZBLITZ NZLOAD. From now -on, your startup to Z-System is MUCH faster; just type "NZLOAD". Be -forewarned that NZBLITZ saves EVERYTHING as currently active, so be sure you -are at the directory (usually A0:) you wish the system to start in, and be -sure all active shells, flow states, terminal definitions, and so on are the -desired ones before proceeding. See NZBLITZ.NZT for more information. - - -6. MINOR UPDATE NOTES. - -- The RCP WHLQ command no longer used. "WHL" alone displays the current - wheel status. As before, "WHL password" turns the wheel byte on. "WHL - xxx" now turns the wheel byte OFF if xxx is something other than the - correct password. - -- ARUNZ is now a type-4 program which loads at the highest possible - memory location so as to save lower memory for immediate re-execution - with GO. See ARUNZ09R.DZC and TCJ31.MZG (as well as your NZ-COM or - Z3PLUS manual) for more on the amazing ARUNZ. - -- VLU is no longer included, as it was not reliable. Please use LDIR, - LGET, LPUT, and LT instead to manipulate library files. - -- At this writing, we are sorry to note that both Z-Node Central and the - Lillipute Z-Nodes mentioned in Chapter 7 of your manual are out of - service. Z-Nodes 2 and 3 are still going strong, however, as are the - many others listed in ZNODES.LST. Z-Node 2 is the new Z-Node Central. - We cannot recommend highly enough that you get a modem and investigate at - least one Z-Node as a source of inspiration and support. - -- Version 5.0 of the ZEX batch processor replaces earlier versions. ZEX - now runs under both NZ-COM and Z3PLUS and is a very powerful means of - customizing programs and commands. The ZEX.RSX file mentioned in the - manual is no longer required. See ZEX50.DZC for help. - - -7. TO NEW Z-SYSTEM USERS. - -- All files whose middle filetype character is "Z" (e.g., SAMPLE.DZC) are - "crunched" files which must be uncompressed with LT.COM or UNCRUNCH.COM - before use. - -- As outlined in section 4.3.2 of your manual, most Z-System programs - have built-in help; type the name of any program followed by "//" for a - short description if you are confused. - -- Finally, it is not at all necessary to master every nuance of the system - before it becomes useful. Please don't try to devour all of Z-System at - once. Instead, we suggest that you decide what aspects of the system you - will find most helpful and try to master one or two of those before - exploring further. We think you will find that if you choose wisely, - learning one aspect fully not only makes that aspect of your computing - world easier, it also equips you with the skills and confidence with - which to surmount other aspects of Z-System more confidently. - - -8. ALERT ABOUT NZCPM.COM AND NZCOM.CCP - -Some users have been tripped up by the way NZCOM handles the generation of -an NZCPM.COM file: it writes such a file only if one does not already exist. -This speeds up loading of the system. However, should you ever make any -change to your base CP/M system (such as installing ZSDOS/ZDDOS or a new -version of the BIOS), you should be sure to erase the NZCPM.COM file so that -NZCOM will create a new one the next time it is run. You should also be -sure to use NZCOM and not NZBLITZ to load the system the first time after -such a change. - -You should also be aware that warmboots of the NZ-COM Z-System are performed -by loading the NZCOM.CCP file containing the image of the current command -processor. This means that you must not change the diskette in the A: drive -unless you have copied the **CURRENT** NZCOM.CCP file (if you only use one -system configuration, the current version will not change) to the diskette -you are going to place in the A: drive. - - -9. CHANGE IN MKZCM DEFAULT AND STANDARD RCP - -Carson Wilson and Rob Friefeld have made some major changes in the RCP code -(see the DOC file in RCP.LBR). The standard RCP module is now 18 records -long instead of 16. MKZCM.COM has been patched to provide this value as a -default. - - -10. NZBIO+.ZRL - -The BIOS in some computers uses the Z80 index and alternate registers -without -saving them on the stack and restoring them. These computers include the -TeleVideo 80x machines, the Oneac On!, the Zorba, and a number of other -machines. Some programs (JETLDR and EDITNDR, for example) will not function -properly under these conditions. The file NZBIO+.ZRL in NZCOM.LBR is a -special version of the NZ-COM virtual BIOS that protects the Zilog registers -across all BIOS calls. To use this BIOS, you much use MKZCM to allocate 4 -records to the BIOS. If you observe strange behavior on your system with -NZ-COM, you might want to try using this special BIOS. - - - - - End of RELEASE.NOT - - \ No newline at end of file diff --git a/software/CPM/CPM32_ZCPR3/SAINST.COM b/software/CPM/CPM32_ZCPR3/SAINST.COM deleted file mode 100755 index 1e6db48..0000000 Binary files a/software/CPM/CPM32_ZCPR3/SAINST.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/SALIAS.COM b/software/CPM/CPM32_ZCPR3/SALIAS.COM deleted file mode 100755 index 9b85e04..0000000 Binary files a/software/CPM/CPM32_ZCPR3/SALIAS.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/SAVENDR.COM b/software/CPM/CPM32_ZCPR3/SAVENDR.COM deleted file mode 100755 index bf8d112..0000000 Binary files a/software/CPM/CPM32_ZCPR3/SAVENDR.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/SDZ.COM b/software/CPM/CPM32_ZCPR3/SDZ.COM deleted file mode 100755 index 46f81fd..0000000 Binary files a/software/CPM/CPM32_ZCPR3/SDZ.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/SHOW.COM b/software/CPM/CPM32_ZCPR3/SHOW.COM deleted file mode 100755 index b22ce69..0000000 Binary files a/software/CPM/CPM32_ZCPR3/SHOW.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/SUB.COM b/software/CPM/CPM32_ZCPR3/SUB.COM deleted file mode 100755 index f87c087..0000000 Binary files a/software/CPM/CPM32_ZCPR3/SUB.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TCAP.LBR b/software/CPM/CPM32_ZCPR3/TCAP.LBR deleted file mode 100755 index 9a3fd9c..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TCAP.LBR and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TCJ.INF b/software/CPM/CPM32_ZCPR3/TCJ.INF deleted file mode 100755 index 7d9322c..0000000 --- a/software/CPM/CPM32_ZCPR3/TCJ.INF +++ /dev/null @@ -1,31 +0,0 @@ - - Information About Subscriptions to - - The Computer Journal - - -The subscription rates for TCJ as of September 1, 1991, are as follows: - - 1 year 2 years - ------ ------- - U.S. $18 $32 - Foreign (surface mail) $24 $44 - Foreign (air mail) $38 $72 - -There are six issues per year. To place a subscription, contact the -new publisher (as of July 1992): - - The Computer Journal - P.O. Box 535 - Lincoln, CA 95658 - 916-645-1670 (answering machine and FAX) - -You may order a trial subscription. Just place an order. If you decide -that TCJ is not for you, then just mark the invoice "cancel" and send it -back. - -Payments for TCJ must normally be in the form of a money order or a check -drawn on a U.S. bank in U.S. funds or a postal money order in U.S. funds. -It is expected that MasterCard and VISA will again be acceptable in the -future. - \ No newline at end of file diff --git a/software/CPM/CPM32_ZCPR3/TCJ25.WZ b/software/CPM/CPM32_ZCPR3/TCJ25.WZ deleted file mode 100755 index ad1a14e..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TCJ25.WZ and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TCJ26.WZ b/software/CPM/CPM32_ZCPR3/TCJ26.WZ deleted file mode 100755 index 97410f7..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TCJ26.WZ and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TCJ27.WZ b/software/CPM/CPM32_ZCPR3/TCJ27.WZ deleted file mode 100755 index 35905c1..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TCJ27.WZ and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TCJ28.WZ b/software/CPM/CPM32_ZCPR3/TCJ28.WZ deleted file mode 100755 index ba0bdd5..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TCJ28.WZ and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TCJ29.WZ b/software/CPM/CPM32_ZCPR3/TCJ29.WZ deleted file mode 100755 index 116420d..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TCJ29.WZ and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TCJ30.WZ b/software/CPM/CPM32_ZCPR3/TCJ30.WZ deleted file mode 100755 index dca4d43..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TCJ30.WZ and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TCJ31UPD.WZ b/software/CPM/CPM32_ZCPR3/TCJ31UPD.WZ deleted file mode 100755 index f55b704..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TCJ31UPD.WZ and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TCJ32.WZ b/software/CPM/CPM32_ZCPR3/TCJ32.WZ deleted file mode 100755 index 87a3caa..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TCJ32.WZ and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TCJ33UPD.WZ b/software/CPM/CPM32_ZCPR3/TCJ33UPD.WZ deleted file mode 100755 index 782a9e3..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TCJ33UPD.WZ and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TCSELECT.COM b/software/CPM/CPM32_ZCPR3/TCSELECT.COM deleted file mode 100755 index 4b29b83..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TCSELECT.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TY3ERA.COM b/software/CPM/CPM32_ZCPR3/TY3ERA.COM deleted file mode 100755 index ac18c87..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TY3ERA.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TY3REN.COM b/software/CPM/CPM32_ZCPR3/TY3REN.COM deleted file mode 100755 index e5746c5..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TY3REN.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TY4ERA.COM b/software/CPM/CPM32_ZCPR3/TY4ERA.COM deleted file mode 100755 index 77dac7f..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TY4ERA.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TY4REN.COM b/software/CPM/CPM32_ZCPR3/TY4REN.COM deleted file mode 100755 index fdfa70b..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TY4REN.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TY4SAVE.COM b/software/CPM/CPM32_ZCPR3/TY4SAVE.COM deleted file mode 100755 index 59f9d77..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TY4SAVE.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/TY4SP.COM b/software/CPM/CPM32_ZCPR3/TY4SP.COM deleted file mode 100755 index 6c117b1..0000000 Binary files a/software/CPM/CPM32_ZCPR3/TY4SP.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/UNCRUNCH.COM b/software/CPM/CPM32_ZCPR3/UNCRUNCH.COM deleted file mode 100755 index 5ffb68e..0000000 Binary files a/software/CPM/CPM32_ZCPR3/UNCRUNCH.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/VIEW.COM b/software/CPM/CPM32_ZCPR3/VIEW.COM deleted file mode 100755 index c812f75..0000000 Binary files a/software/CPM/CPM32_ZCPR3/VIEW.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/XTCAP.COM b/software/CPM/CPM32_ZCPR3/XTCAP.COM deleted file mode 100755 index 06b26f0..0000000 Binary files a/software/CPM/CPM32_ZCPR3/XTCAP.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/Z3LOC.COM b/software/CPM/CPM32_ZCPR3/Z3LOC.COM deleted file mode 100755 index fab1359..0000000 Binary files a/software/CPM/CPM32_ZCPR3/Z3LOC.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/Z3TCAP.TCP b/software/CPM/CPM32_ZCPR3/Z3TCAP.TCP deleted file mode 100755 index 07adc28..0000000 Binary files a/software/CPM/CPM32_ZCPR3/Z3TCAP.TCP and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/ZCNFG.COM b/software/CPM/CPM32_ZCPR3/ZCNFG.COM deleted file mode 100755 index b88a2d0..0000000 Binary files a/software/CPM/CPM32_ZCPR3/ZCNFG.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/ZERR.COM b/software/CPM/CPM32_ZCPR3/ZERR.COM deleted file mode 100755 index 4565e7a..0000000 Binary files a/software/CPM/CPM32_ZCPR3/ZERR.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/ZEX.COM b/software/CPM/CPM32_ZCPR3/ZEX.COM deleted file mode 100755 index cd46405..0000000 Binary files a/software/CPM/CPM32_ZCPR3/ZEX.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/ZF-DIM.COM b/software/CPM/CPM32_ZCPR3/ZF-DIM.COM deleted file mode 100755 index 1b1332c..0000000 Binary files a/software/CPM/CPM32_ZCPR3/ZF-DIM.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/ZF-REV.COM b/software/CPM/CPM32_ZCPR3/ZF-REV.COM deleted file mode 100755 index b0cc279..0000000 Binary files a/software/CPM/CPM32_ZCPR3/ZF-REV.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/ZFILEB38.LZT b/software/CPM/CPM32_ZCPR3/ZFILEB38.LZT deleted file mode 100755 index 6c2c539..0000000 Binary files a/software/CPM/CPM32_ZCPR3/ZFILEB38.LZT and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/ZFILER.CMD b/software/CPM/CPM32_ZCPR3/ZFILER.CMD deleted file mode 100755 index 3fddad5..0000000 --- a/software/CPM/CPM32_ZCPR3/ZFILER.CMD +++ /dev/null @@ -1,28 +0,0 @@ - Z System Distribution ZFILER.CMD, 11 Oct 89 by Carson Wilson -0 ! $"Enter ZFILER macro script: " -E ! echo f%>ull file spec:%< $p;echo f%>ile directory:%< $d$u:;echo f%>ile name.....:%< $n;echo f%>ile type.....:%< $t -K ! $d$u:;$!crunch $f $"Destination directory: ";$h: -L ! $!if eq $t lbr;ldir $p;else;echo f%>ile %<$f%> is not a library;fi -T ! $!lt $p -U ! $d$u:;uncr $f;$h: -X ! if ~eq $t com;echo n%>ot a % file;else;$d$u:;:$n $" Command Tail: ";$h:;fi -Z ! $d$u:;$" Command to perform on file: " $f $" Tail: ";$h: -# - SAMPLE ZFILER COMMAND MACROS FOR USE WITH NZCOM AND Z3PLUS - -macros: 0. on-line macro - E. Echo data about file name - K. Krunch the file - L. display directory of Library - T. Type the file - U. Uncrunch the file - X. eXecute the file - Z. perform command on file - -ZFILER parameters for use with macro '0' - - $! ZEX 'GO' $P DU:FN.FT $D DRIVE - $".." PROMPT $F FN.FT $U USER - $'..' PROMPT $N FN $H HOME DU - $T FT - \ No newline at end of file diff --git a/software/CPM/CPM32_ZCPR3/ZFILER.COM b/software/CPM/CPM32_ZCPR3/ZFILER.COM deleted file mode 100755 index 1b1332c..0000000 Binary files a/software/CPM/CPM32_ZCPR3/ZFILER.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/ZHELPERS.LZT b/software/CPM/CPM32_ZCPR3/ZHELPERS.LZT deleted file mode 100755 index 976755a..0000000 Binary files a/software/CPM/CPM32_ZCPR3/ZHELPERS.LZT and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/ZLT.COM b/software/CPM/CPM32_ZCPR3/ZLT.COM deleted file mode 100755 index 57d04c5..0000000 Binary files a/software/CPM/CPM32_ZCPR3/ZLT.COM and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/ZNODES66.LZT b/software/CPM/CPM32_ZCPR3/ZNODES66.LZT deleted file mode 100755 index 0f52992..0000000 Binary files a/software/CPM/CPM32_ZCPR3/ZNODES66.LZT and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/ZSYSTEM.IZF b/software/CPM/CPM32_ZCPR3/ZSYSTEM.IZF deleted file mode 100755 index 87fb58e..0000000 Binary files a/software/CPM/CPM32_ZCPR3/ZSYSTEM.IZF and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/nzcom.env b/software/CPM/CPM32_ZCPR3/nzcom.env deleted file mode 100644 index 28bbf69..0000000 Binary files a/software/CPM/CPM32_ZCPR3/nzcom.env and /dev/null differ diff --git a/software/CPM/CPM32_ZCPR3/nzcom.zcm b/software/CPM/CPM32_ZCPR3/nzcom.zcm deleted file mode 100644 index ddc85de..0000000 Binary files a/software/CPM/CPM32_ZCPR3/nzcom.zcm and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/ARUNZ.COM b/software/CPM/CPM33_ZCPR3_COMMON/ARUNZ.COM deleted file mode 100644 index 041b87c..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/ARUNZ.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/CLEDINST.COM b/software/CPM/CPM33_ZCPR3_COMMON/CLEDINST.COM deleted file mode 100644 index c26a3cf..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/CLEDINST.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/CLEDSAVE.COM b/software/CPM/CPM33_ZCPR3_COMMON/CLEDSAVE.COM deleted file mode 100644 index dde04bc..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/CLEDSAVE.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/COMMON.CRC b/software/CPM/CPM33_ZCPR3_COMMON/COMMON.CRC deleted file mode 100644 index 4fc626b..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/COMMON.CRC and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/CONFIG.LBR b/software/CPM/CPM33_ZCPR3_COMMON/CONFIG.LBR deleted file mode 100644 index 40d87ae..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/CONFIG.LBR and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/COPY.COM b/software/CPM/CPM33_ZCPR3_COMMON/COPY.COM deleted file mode 100644 index 734953d..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/COPY.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/CPSET.COM b/software/CPM/CPM33_ZCPR3_COMMON/CPSET.COM deleted file mode 100644 index 54462ce..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/CPSET.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/CRUNCH.COM b/software/CPM/CPM33_ZCPR3_COMMON/CRUNCH.COM deleted file mode 100644 index ac17854..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/CRUNCH.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/DOCFILES.LBR b/software/CPM/CPM33_ZCPR3_COMMON/DOCFILES.LBR deleted file mode 100644 index c96cd42..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/DOCFILES.LBR and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/EDITNDR.COM b/software/CPM/CPM33_ZCPR3_COMMON/EDITNDR.COM deleted file mode 100644 index 149cb98..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/EDITNDR.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/FCP.LBR b/software/CPM/CPM33_ZCPR3_COMMON/FCP.LBR deleted file mode 100644 index 8eb74a4..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/FCP.LBR and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/FF.COM b/software/CPM/CPM33_ZCPR3_COMMON/FF.COM deleted file mode 100644 index b68b2ad..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/FF.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/HLPFILES.LBR b/software/CPM/CPM33_ZCPR3_COMMON/HLPFILES.LBR deleted file mode 100644 index 32200cd..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/HLPFILES.LBR and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/IF.COM b/software/CPM/CPM33_ZCPR3_COMMON/IF.COM deleted file mode 100644 index c51cd0b..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/IF.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/JETLDR.COM b/software/CPM/CPM33_ZCPR3_COMMON/JETLDR.COM deleted file mode 100644 index c33c073..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/JETLDR.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/LBREXT.COM b/software/CPM/CPM33_ZCPR3_COMMON/LBREXT.COM deleted file mode 100644 index 591922b..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/LBREXT.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/LBRHELP.COM b/software/CPM/CPM33_ZCPR3_COMMON/LBRHELP.COM deleted file mode 100644 index eb1ef6e..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/LBRHELP.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/LDIR.COM b/software/CPM/CPM33_ZCPR3_COMMON/LDIR.COM deleted file mode 100644 index d72eeef..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/LDIR.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/LPUT.COM b/software/CPM/CPM33_ZCPR3_COMMON/LPUT.COM deleted file mode 100644 index 7271696..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/LPUT.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/LSH-HELP.COM b/software/CPM/CPM33_ZCPR3_COMMON/LSH-HELP.COM deleted file mode 100644 index 0103795..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/LSH-HELP.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/LSH.COM b/software/CPM/CPM33_ZCPR3_COMMON/LSH.COM deleted file mode 100644 index 6ec314f..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/LSH.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/LSH.WZ b/software/CPM/CPM33_ZCPR3_COMMON/LSH.WZ deleted file mode 100644 index 690f991..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/LSH.WZ and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/LSHINST.COM b/software/CPM/CPM33_ZCPR3_COMMON/LSHINST.COM deleted file mode 100644 index a9beb35..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/LSHINST.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/LX.COM b/software/CPM/CPM33_ZCPR3_COMMON/LX.COM deleted file mode 100644 index d424f9f..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/LX.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/NAME.COM b/software/CPM/CPM33_ZCPR3_COMMON/NAME.COM deleted file mode 100644 index d3a8cdf..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/NAME.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/PATH.COM b/software/CPM/CPM33_ZCPR3_COMMON/PATH.COM deleted file mode 100644 index 1245c1a..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/PATH.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/PWD.COM b/software/CPM/CPM33_ZCPR3_COMMON/PWD.COM deleted file mode 100644 index dda7ce7..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/PWD.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/RCP.LBR b/software/CPM/CPM33_ZCPR3_COMMON/RCP.LBR deleted file mode 100644 index fdc452f..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/RCP.LBR and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/SAINST.COM b/software/CPM/CPM33_ZCPR3_COMMON/SAINST.COM deleted file mode 100644 index 1e6db48..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/SAINST.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/SALIAS.COM b/software/CPM/CPM33_ZCPR3_COMMON/SALIAS.COM deleted file mode 100644 index 9b85e04..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/SALIAS.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/SAVENDR.COM b/software/CPM/CPM33_ZCPR3_COMMON/SAVENDR.COM deleted file mode 100644 index bf8d112..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/SAVENDR.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/SDZ.COM b/software/CPM/CPM33_ZCPR3_COMMON/SDZ.COM deleted file mode 100644 index 46f81fd..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/SDZ.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/TCAP.LBR b/software/CPM/CPM33_ZCPR3_COMMON/TCAP.LBR deleted file mode 100644 index 9a3fd9c..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/TCAP.LBR and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/TCJ.INF b/software/CPM/CPM33_ZCPR3_COMMON/TCJ.INF deleted file mode 100644 index 7d9322c..0000000 --- a/software/CPM/CPM33_ZCPR3_COMMON/TCJ.INF +++ /dev/null @@ -1,31 +0,0 @@ - - Information About Subscriptions to - - The Computer Journal - - -The subscription rates for TCJ as of September 1, 1991, are as follows: - - 1 year 2 years - ------ ------- - U.S. $18 $32 - Foreign (surface mail) $24 $44 - Foreign (air mail) $38 $72 - -There are six issues per year. To place a subscription, contact the -new publisher (as of July 1992): - - The Computer Journal - P.O. Box 535 - Lincoln, CA 95658 - 916-645-1670 (answering machine and FAX) - -You may order a trial subscription. Just place an order. If you decide -that TCJ is not for you, then just mark the invoice "cancel" and send it -back. - -Payments for TCJ must normally be in the form of a money order or a check -drawn on a U.S. bank in U.S. funds or a postal money order in U.S. funds. -It is expected that MasterCard and VISA will again be acceptable in the -future. - \ No newline at end of file diff --git a/software/CPM/CPM33_ZCPR3_COMMON/TCSELECT.COM b/software/CPM/CPM33_ZCPR3_COMMON/TCSELECT.COM deleted file mode 100644 index 4b29b83..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/TCSELECT.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/TY3ERA.COM b/software/CPM/CPM33_ZCPR3_COMMON/TY3ERA.COM deleted file mode 100644 index ac18c87..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/TY3ERA.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/TY3REN.COM b/software/CPM/CPM33_ZCPR3_COMMON/TY3REN.COM deleted file mode 100644 index e5746c5..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/TY3REN.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/TY4ERA.COM b/software/CPM/CPM33_ZCPR3_COMMON/TY4ERA.COM deleted file mode 100644 index 77dac7f..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/TY4ERA.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/TY4REN.COM b/software/CPM/CPM33_ZCPR3_COMMON/TY4REN.COM deleted file mode 100644 index fdfa70b..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/TY4REN.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/TY4SAVE.COM b/software/CPM/CPM33_ZCPR3_COMMON/TY4SAVE.COM deleted file mode 100644 index 59f9d77..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/TY4SAVE.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/TY4SP.COM b/software/CPM/CPM33_ZCPR3_COMMON/TY4SP.COM deleted file mode 100644 index 6c117b1..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/TY4SP.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/UNCRUNCH.COM b/software/CPM/CPM33_ZCPR3_COMMON/UNCRUNCH.COM deleted file mode 100644 index 5ffb68e..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/UNCRUNCH.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/VIEW.COM b/software/CPM/CPM33_ZCPR3_COMMON/VIEW.COM deleted file mode 100644 index c812f75..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/VIEW.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/XTCAP.COM b/software/CPM/CPM33_ZCPR3_COMMON/XTCAP.COM deleted file mode 100644 index 06b26f0..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/XTCAP.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/Z3TCAP.TCP b/software/CPM/CPM33_ZCPR3_COMMON/Z3TCAP.TCP deleted file mode 100644 index 07adc28..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/Z3TCAP.TCP and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/ZCNFG.COM b/software/CPM/CPM33_ZCPR3_COMMON/ZCNFG.COM deleted file mode 100644 index b88a2d0..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/ZCNFG.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/ZERR.COM b/software/CPM/CPM33_ZCPR3_COMMON/ZERR.COM deleted file mode 100644 index 4565e7a..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/ZERR.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/ZEX.COM b/software/CPM/CPM33_ZCPR3_COMMON/ZEX.COM deleted file mode 100644 index cd46405..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/ZEX.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/ZF-DIM.COM b/software/CPM/CPM33_ZCPR3_COMMON/ZF-DIM.COM deleted file mode 100644 index 1b1332c..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/ZF-DIM.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/ZF-REV.COM b/software/CPM/CPM33_ZCPR3_COMMON/ZF-REV.COM deleted file mode 100644 index b0cc279..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/ZF-REV.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/ZFILEB38.LZT b/software/CPM/CPM33_ZCPR3_COMMON/ZFILEB38.LZT deleted file mode 100644 index 6c2c539..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/ZFILEB38.LZT and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/ZFILER.CMD b/software/CPM/CPM33_ZCPR3_COMMON/ZFILER.CMD deleted file mode 100644 index 3fddad5..0000000 --- a/software/CPM/CPM33_ZCPR3_COMMON/ZFILER.CMD +++ /dev/null @@ -1,28 +0,0 @@ - Z System Distribution ZFILER.CMD, 11 Oct 89 by Carson Wilson -0 ! $"Enter ZFILER macro script: " -E ! echo f%>ull file spec:%< $p;echo f%>ile directory:%< $d$u:;echo f%>ile name.....:%< $n;echo f%>ile type.....:%< $t -K ! $d$u:;$!crunch $f $"Destination directory: ";$h: -L ! $!if eq $t lbr;ldir $p;else;echo f%>ile %<$f%> is not a library;fi -T ! $!lt $p -U ! $d$u:;uncr $f;$h: -X ! if ~eq $t com;echo n%>ot a % file;else;$d$u:;:$n $" Command Tail: ";$h:;fi -Z ! $d$u:;$" Command to perform on file: " $f $" Tail: ";$h: -# - SAMPLE ZFILER COMMAND MACROS FOR USE WITH NZCOM AND Z3PLUS - -macros: 0. on-line macro - E. Echo data about file name - K. Krunch the file - L. display directory of Library - T. Type the file - U. Uncrunch the file - X. eXecute the file - Z. perform command on file - -ZFILER parameters for use with macro '0' - - $! ZEX 'GO' $P DU:FN.FT $D DRIVE - $".." PROMPT $F FN.FT $U USER - $'..' PROMPT $N FN $H HOME DU - $T FT - \ No newline at end of file diff --git a/software/CPM/CPM33_ZCPR3_COMMON/ZHELPERS.LZT b/software/CPM/CPM33_ZCPR3_COMMON/ZHELPERS.LZT deleted file mode 100644 index 976755a..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/ZHELPERS.LZT and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/ZLT.COM b/software/CPM/CPM33_ZCPR3_COMMON/ZLT.COM deleted file mode 100644 index 57d04c5..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/ZLT.COM and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/ZNODES66.LZT b/software/CPM/CPM33_ZCPR3_COMMON/ZNODES66.LZT deleted file mode 100644 index 0f52992..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/ZNODES66.LZT and /dev/null differ diff --git a/software/CPM/CPM33_ZCPR3_COMMON/ZSYSTEM.IZF b/software/CPM/CPM33_ZCPR3_COMMON/ZSYSTEM.IZF deleted file mode 100644 index 87fb58e..0000000 Binary files a/software/CPM/CPM33_ZCPR3_COMMON/ZSYSTEM.IZF and /dev/null differ diff --git a/software/CPM/CPM_MC_5/ALGEBRA.ARI b/software/CPM/CPM_MC_5/ALGEBRA.ARI deleted file mode 100644 index 7c146c9..0000000 --- a/software/CPM/CPM_MC_5/ALGEBRA.ARI +++ /dev/null @@ -1,412 +0,0 @@ -% File ALGEBRA.ARI (c) 09/16/80 The Soft Warehouse % - - -PROPERTY PRTMATH, +, FUNCTION (LEX1, - % Local: % EX1), - PRTPAREN (LPAR), - PRTMATH (POP(LEX1), 0, GET ('LBP, LOP1)), - LOOP - PRTSPACE (), - BLOCK - WHEN NEGCOEF (EX1:POP(LEX1)), - PRINT ('-), - EX1: -EX1 EXIT, - PRINT (LOP1), - ENDBLOCK, - PRTSPACE (), - WHEN ATOM (LEX1) EXIT, - PRTMATH (EX1, GET ('RBP, LOP1), GET ('LBP, LOP1)), - ENDLOOP, - PRTMATH (EX1, GET ('RBP, LOP1), 0), - PRTPAREN (RPAR), -ENDFUN $ - -FUNCTION SQUARE (EX1, - % Local: % LEX1, LEX2, LEX3), - WHEN SUM (EX1), - LEX1: REVERSE (REST(EX1)), - LOOP - LEX2: MERGESUM ((EX1:POP(LEX1))^2, LEX2), - WHEN ATOM (LEX3:LEX1), MKSUM (LEX2) EXIT, - EX1: 2*EX1, - LOOP - LEX2: MERGESUM (EX1*POP(LEX3), LEX2), - WHEN ATOM (LEX3) EXIT, - ENDLOOP, - ENDLOOP EXIT, - EX1*EX1, -ENDFUN $ - - - -NUMNUM: 6 $ - -PUSH ('NUMNUM, FLAGS) $ - -FUNCTION NUMNUM (EX1), - WHEN INTEGER (EX1), MULTIPLE (NUMNUM, 2) EXIT, - WHEN SUM (EX1), MULTIPLE (NUMNUM, 5) EXIT, - MULTIPLE (NUMNUM, 3), -ENDFUN $ - -DENNUM: 6 $ - -PUSH ('DENNUM, FLAGS) $ - -FUNCTION DENNUM (EX1), - WHEN INTEGER (EX1), MULTIPLE (DENNUM, 2) EXIT, - WHEN SUM (EX1), MULTIPLE (DENNUM, 5) EXIT, - MULTIPLE (DENNUM, 3), -ENDFUN $ - -FUNCTION DISTRIB (EX1, LEX1, - % Local: % NUMNUM, DENNUM, LEX2), - LOOP - LEX2: MERGESUM (EX1*POP(LEX1), LEX2), - WHEN ATOM (LEX1), LEX2 EXIT, - ENDLOOP, -ENDFUN $ - -PROPERTY *, +, FUNCTION (EX1, LEX4, - % Local: % LEX1, LEX2, LEX3), - WHEN POSITIVE (NUMNUM) OR POSITIVE (DENNUM), - WHEN PRODUCT (EX1), - LEX1: REST (EX1), - LOOP - EX1: POP(LEX1), - BLOCK - WHEN DENOM (EX1), - WHEN POSITIVE (DENNUM) AND DENNUM (EX1^-1), - PUSH (EX1, LEX2) EXIT, - PUSH (EX1, LEX3) EXIT, - WHEN POSITIVE (NUMNUM) AND NUMNUM (EX1), - PUSH (EX1, LEX2) EXIT, - PUSH (EX1, LEX3), - ENDBLOCK, - WHEN ATOM (LEX1) EXIT, - ENDLOOP, - MERGEFACT (MKSUM (DISTRIB (MKPROD (REVERSE(LEX2)), LEX4, - NUMNUM, DENNUM)), REVERSE (LEX3)) EXIT, - WHEN DENOM (EX1), - WHEN POSITIVE (DENNUM) AND DENNUM (EX1^-1), - MKSUM (DISTRIB (EX1, LEX4, NUMNUM, DENNUM)) EXIT, - EXIT, - WHEN POSITIVE (NUMNUM) AND NUMNUM (EX1), - MKSUM (DISTRIB (EX1, LEX4, NUMNUM, DENNUM)) EXIT, - EXIT, -ENDFUN $ - - -DENDEN: 6 $ - -PUSH ('DENDEN, FLAGS) $ - -FUNCTION DENDEN (EX1), - WHEN INTEGER (EX1), MULTIPLE (DENDEN, 2) EXIT, - WHEN SUM (EX1), MULTIPLE (DENDEN, 5) EXIT, - MULTIPLE (DENDEN, 3), -ENDFUN $ - -NUMDEN: 0 $ - -PUSH ('NUMDEN, FLAGS) $ - -FUNCTION NUMDEN (EX1), - WHEN INTEGER (EX1), MULTIPLE (NUMDEN, 2) EXIT, - WHEN SUM (EX1), MULTIPLE (NUMDEN, 5) EXIT, - MULTIPLE (NUMDEN, 3), -ENDFUN $ - -PROPERTY *, ^, FUNCTION (EX1, EX2, EX3, - % Local: % LEX1, LEX2, LEX3), - WHEN NEGATIVE(BASEXP) AND BASEXP(EX2) AND BASE(EX1) = EX2, - EX2 ^ (EXPON(EX1) + EX3) EXIT, - WHEN NEGATIVE(EXPBAS) AND EXPBAS(EX3) AND EXPON(EX1) = EX3, - (BASE(EX1) * EX2) ^ EX3 EXIT, - WHEN EX3 EQ -1, - WHEN INTEGER (EX2), - WHEN INTEGER (EX1), - EX3: GCD (EX1, EX2), - WHEN EX3 EQ 1, FALSE EXIT, - EX1: QUOTIENT (EX1, EX3), - EX2: QUOTIENT (EX2, EX3), - WHEN EX2 EQ 1, EX1 EXIT, - EX2: LIST ('^, EX2, -1), - WHEN EX1 EQ 1, EX2 EXIT, - LIST ('*, EX1, EX2) EXIT, - WHEN RECIP (EX1), - LIST ('^, TIMES (EX2, SECOND(EX1)), -1) EXIT EXIT, - WHEN SUM (EX2), - WHEN POSITIVE (DENDEN) OR POSITIVE (NUMDEN), - EX2: REST (EX2), - WHEN PRODUCT (EX1), - LEX1: REST (EX1), - LOOP - EX1: POP(LEX1), - BLOCK - WHEN DENOM (EX1), - EX3: EX1^-1, - WHEN POSITIVE (DENDEN) AND DENDEN (EX3), - LEX2: ADJOIN (EX3, LEX2) EXIT, - LEX3: ADJOIN (EX1, LEX3) EXIT, - WHEN POSITIVE (NUMDEN) AND NUMDEN (EX1), - LEX2: ADJOIN (EX1^-1, LEX2) EXIT, - LEX3: ADJOIN (EX1, LEX3), - ENDBLOCK, - WHEN ATOM (LEX1) EXIT, - ENDLOOP, - MERGEFACT (LIST ('^, MKSUM ( - DISTRIB (MKPROD(REVERSE(LEX2)), EX2, DENDEN, NUMDEN)), - -1), REVERSE (LEX3)) EXIT, - WHEN DENOM (EX1), - EX3: EX1^-1, - WHEN POSITIVE (DENDEN) AND DENDEN (EX3), - LIST ('^, MKSUM (DISTRIB (EX3, EX2, DENDEN, NUMDEN)), -1) - EXIT, - EXIT, - WHEN POSITIVE (NUMDEN) AND NUMDEN (EX1), - LIST ('^, MKSUM ( - DISTRIB (EX1^-1, EX2, DENDEN, NUMDEN)), -1) EXIT, - EXIT, - EXIT, - EXIT, -ENDFUN $ - - -EXPBAS: 30 $ - -PUSH ('EXPBAS, FLAGS) $ - -FUNCTION EXPBAS (EX1), - WHEN NUMBER (EX1), MULTIPLE (EXPBAS, 2) EXIT, - WHEN SUM (EX1), MULTIPLE (EXPBAS, 5) EXIT, - MULTIPLE (EXPBAS, 3), -ENDFUN $ - -PROPERTY BASE, *, FUNCTION (EX1, EX2, EX3), - WHEN POSITIVE (EXPBAS) AND EXPBAS (EX1), - EX2^EX1 * EX3^EX1 EXIT, -ENDFUN $ - - -BASEXP: -30 $ - -PUSH ('BASEXP, FLAGS) $ - -FUNCTION BASEXP (EX1), - WHEN NUMBER (EX1), MULTIPLE (BASEXP, 2) EXIT, - WHEN PRODUCT (EX1), MULTIPLE (BASEXP, 5) EXIT, - MULTIPLE (BASEXP, 3), -ENDFUN $ - -PROPERTY EXPON, +, FUNCTION (EX1, EX2, EX3), - WHEN POSITIVE (BASEXP) AND BASEXP (EX1), - EX1^EX2 * EX1^EX3 EXIT, -ENDFUN $ - - -PWREXPD: 0 $ - -PUSH ('PWREXPD, FLAGS) $ - -PROPERTY BASE, +, FUNCTION (EX1, EX2, EX3, - % Local: % NUMNUM, DENNUM), - WHEN INTEGER (EX1), - BLOCK - WHEN SUM (EX3), - EX2: ADJOIN ('+, ADJOIN (EX2, REST(EX3))) EXIT, - EX2: LIST ('+, EX2, EX3), - ENDBLOCK, - WHEN EX1 EQ -1, - WHEN NEGATIVE (DENDEN) OR NEGATIVE (NUMDEN), - NUMNUM: DENDEN, - DENNUM: NUMDEN, - EX2: EVAL (EX2), - WHEN SUM (EX2), FALSE EXIT, - EX2^-1 EXIT EXIT, - WHEN POSITIVE (PWREXPD), - NUMNUM: 30, - DENNUM: 30, - WHEN POSITIVE (EX1), - WHEN MULTIPLE (PWREXPD, 2), EXPT (EX2, EX1) EXIT, - EXIT, - WHEN MULTIPLE (PWREXPD, 3), EXPT (EX2, -EX1) ^ -1 EXIT, - EXIT, - EXIT, -ENDFUN $ - - -FUNCTION EXPAND (EX1, - % Local: % PWREXPD, NUMNUM, DENDEN, DENNUM, NUMDEN, BASEXP, EXPBAS), - PWREXPD: 6, - NUMNUM: DENDEN: DENNUM: BASEXP: EXPBAS: 30, - NUMDEN: 0, - EVAL (EX1), -ENDFUN $ - - -%**** optional content factorization & common denominator pkg. ****% - - -FUNCTION CONTENT (LEX1, LEX2), - WHEN ATOM (LEX1), - WHEN ATOM (LEX2), FALSE EXIT, - WHEN DENOM (FIRST(LEX2)) AND - NEGATIVE (DENNUM) AND DENNUM (FIRST(LEX2)^-1), - ADJOIN (POP(LEX2), CONTENT (FALSE, LEX2)) EXIT, - CONTENT (FALSE, REST(LEX2)) EXIT, - CONTENT1 (BASE(FIRST(LEX1)), LEX1, LEX2), -ENDFUN $ - -FUNCTION CONTENT1 (EX1, LEX1, LEX2, - % Local: % EX2), - WHEN ATOM (LEX2), CONTENT (LEX2, LEX1) EXIT, - EX2: BASE (FIRST(LEX2)), - WHEN EX1 = EX2, - EX1: MIN (EXPON(POP(LEX1)), EXPON(POP(LEX2))), - WHEN FIRST(EX1) EQ 'MIN, CONTENT (LEX1, LEX2) EXIT, - EX2: EX2^EX1, - WHEN DENOM (EX2), - WHEN NEGATIVE (DENNUM) AND DENNUM (EX2^-1), - ADJOIN (EX2, CONTENT (LEX1, LEX2)) EXIT, - CONTENT (LEX1, LEX2) EXIT, - WHEN NEGATIVE (NUMNUM) AND NUMNUM (EX2), - ADJOIN (EX2, CONTENT (LEX1, LEX2)) EXIT, - CONTENT (LEX1, LEX2) EXIT, - WHEN ORDERED (EX1, EX2), - EX1: POP(LEX1), - WHEN DENOM (EX1) AND NEGATIVE (DENNUM) AND DENNUM (EX1^-1), - ADJOIN (EX1, CONTENT1 (EX2, LEX2, LEX1)) EXIT, - CONTENT1 (EX2, LEX2, LEX1) EXIT, - EX2: POP(LEX2), - WHEN DENOM (EX2) AND NEGATIVE (DENNUM) AND DENNUM (EX2^-1), - ADJOIN (EX2, CONTENT1 (EX1, LEX1, LEX2)) EXIT, - CONTENT1 (EX1, LEX1, LEX2), -ENDFUN $ - -FUNCTION CANCEL (LEX1, LEX2), - WHEN ATOM (LEX1), LEX2 EXIT, - CANCEL1 (BASE(FIRST(LEX1)), LEX1, LEX2), -ENDFUN $ - -FUNCTION CANCEL1 (EX1, LEX1, LEX2, - % Local: % EX2), - WHEN ATOM (LEX2), - ADJOIN (EX1^-EXPON(POP(LEX1)), CANCEL (LEX1, LEX2)) EXIT, - WHEN EX1 = (EX2:BASE(FIRST(LEX2))), - WHEN ZERO (EX1: EXPD(EXPON (POP(LEX2)) - EXPON (POP(LEX1)))), - CANCEL (LEX1, LEX2) EXIT, - ADJOIN (EX2^EX1, CANCEL (LEX1, LEX2)) EXIT, - WHEN ORDERED (EX1, EX2), - ADJOIN (EX1^-EXPON(POP(LEX1)), CANCEL (LEX1, LEX2)) EXIT, - ADJOIN (POP(LEX2), CANCEL1 (EX1, LEX1, LEX2)), -ENDFUN $ - -FUNCTION FACTOR (LEX1, LEX2, - % Local: % LEX3, LEX4, EX1), - EX1: 1, - LEX3: LEX1, - LEX4: LEX2, - BLOCK - WHEN INTEGER (FIRST(LEX1)), - WHEN INTEGER (FIRST(LEX2)), - BLOCK - WHEN NEGATIVE (NUMNUM) AND NUMNUM (FIRST(LEX1)), - EX1: GCD (FIRST(LEX1), FIRST(LEX2)), - WHEN NEGATIVE (FIRST (LEX1)) AND NEGATIVE (FIRST (LEX2)), - EX1: MINUS(EX1) EXIT EXIT, - ENDBLOCK, - LEX1: REST (LEX1), - LEX2: REST (LEX2) EXIT, - LEX1: REST (LEX1) EXIT, - WHEN INTEGER (FIRST(LEX2)), LEX2: REST (LEX2) EXIT, - ENDBLOCK, - BLOCK - WHEN RECIP (FIRST(LEX1)), - WHEN RECIP (FIRST(LEX2)), - BLOCK - WHEN NEGATIVE (DENNUM) AND DENNUM (SECOND(FIRST(LEX1))), - EX1: EX1 * - LCM (SECOND(FIRST(LEX1)), SECOND(FIRST(LEX2)))^-1 EXIT, - ENDBLOCK, - LEX1: REST (LEX1), - LEX2: REST (LEX2) EXIT, - BLOCK - WHEN NEGATIVE (DENNUM) AND DENNUM (SECOND(FIRST(LEX1))), - EX1: EX1 * FIRST(LEX1) EXIT, - ENDBLOCK, - LEX1: REST (LEX1) EXIT, - WHEN RECIP (FIRST(LEX2)), - BLOCK - WHEN NEGATIVE (DENNUM) AND DENNUM (SECOND(FIRST(LEX2))), - EX1: EX1 * FIRST(LEX2) EXIT, - ENDBLOCK, - LEX2: REST (LEX2) EXIT, - ENDBLOCK, - LEX1: CONTENT (LEX1, LEX2), - WHEN EX1 EQ 1 AND ATOM (LEX1), FALSE EXIT, - MKPROD (MERGEPROD (EX1, - MERGEPROD (PRODLEX (ADJOIN (EX1^-1, CANCEL(LEX1,LEX3))) + - PRODLEX (ADJOIN (EX1^-1, CANCEL(LEX1,LEX4))), LEX1))), -ENDFUN $ - -PROPERTY +, *, FUNCTION (EX1, LEX1), - WHEN NEGATIVE (NUMNUM) OR NEGATIVE (DENNUM), - WHEN EX1 EQ 1, FACTOR(LEX1) EXIT, - WHEN PRODUCT(EX1), FACTOR (LEX1, REST(EX1)) EXIT, - FACTOR (LEX1, LIST(EX1)) EXIT, -ENDFUN $ - -PROPERTY +, ^, FUNCTION (EX1, EX2, EX3), - WHEN NEGATIVE (NUMNUM) OR NEGATIVE (DENNUM), - EX2: LIST ('^, EX2, EX3), - WHEN EX1 EQ 1, FACTOR (LIST(EX2)) EXIT, - WHEN PRODUCT (EX1), FACTOR (LIST(EX2), REST(EX1)) EXIT, - FACTOR (LIST(EX2), LIST(EX1)) EXIT, -ENDFUN $ - - -FUNCTION EXPD (EX1, - % Local: % PWREXPD, NUMNUM, DENDEN, DENNUM, NUMDEN, BASEXP, EXPBAS), - PWREXPD: 6, - NUMNUM: DENDEN: EXPBAS: 30, - DENNUM: BASEXP: -30, - NUMDEN: 0, - EVAL (EX1), -ENDFUN $ - -FUNCTION FCTR (EX1, - % Local: % PWREXPD, NUMNUM, DENDEN, DENNUM, NUMDEN, BASEXP, EXPBAS), - NUMNUM: DENDEN: -6, - PWREXPD: NUMDEN: 0, - DENNUM: BASEXP: -30, - EXPBAS: 30, - EVAL (EX1), -ENDFUN $ - - -%****************** optional flags package ***************************% - -FUNCTION FLAGS ( - % Local: % LEX1, EX1), - EX1: LINELENGTH()-18, - LEX1: FLAGS, - NEWLINE (), - LOOP - WHEN ATOM (LEX1) EXIT, - BLOCK - WHEN GREATER (SPACES(), EX1), - NEWLINE () EXIT, - ENDBLOCK, - PRINT (FIRST(LEX1)), - PRINT (" = "), - PRINT (EVAL(POP(LEX1))), - SPACES (18 - MOD(SPACES(),18)), - ENDLOOP, - NEWLINE (), - "", -ENDFUN $ - -RDS () $ - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/ALL.SYS b/software/CPM/CPM_MC_5/ALL.SYS deleted file mode 100644 index 2c0505c..0000000 Binary files a/software/CPM/CPM_MC_5/ALL.SYS and /dev/null differ diff --git a/software/CPM/CPM_MC_5/ARITH%.MUS b/software/CPM/CPM_MC_5/ARITH%.MUS deleted file mode 100644 index b5fb5a0..0000000 --- a/software/CPM/CPM_MC_5/ARITH%.MUS +++ /dev/null @@ -1,149 +0,0 @@ - file ARITH%.MUS GAE - Feb. 1982 -Make a new version of file ARITH.MUS as follows: -(1) Start with the original file ARITH.MUS. -(2) Delete FUNCTION ^ . This begins approximately 500 lines - from the beginning of the file. Delete everything through - ENDFUN $ . It is about 50 lines. -(3) In the place where the deletion was made, insert the new - FUNCTION ^ from this file (ARITH%.MUS). It begins just - after the line ( ------ ) below, and is also about 50 - lines. It runs up to (but not including) the next line - ( ---------- ). -(4) Next delete everything between the two lines of stars - ( ******** ) This is the `optional fractional-power - package'. -(5) Replace it with the same package from this file (ARITH%. - MUS). This is everything between the two lines of stars - ( ******** ), about 80 lines. ---------------------------------------------------------------- - -FUNCTION ^ (EX1, EX2), - WHEN INTEGER (EX2), - WHEN INTEGER (EX1), - WHEN EX1 EQ 1, 1 EXIT, - WHEN ZERO(EX1) AND ZERO(EX2), ?(LIST('^, EX1, EX2)) EXIT, - WHEN NEGATIVE (EX2), - WHEN ZERO (EX1), ?(LIST('^, EX1, EX2)) EXIT, - EX1: EXPT (EX1, -EX2), - WHEN NEGATIVE (EX1), -((-EX1)^-1) EXIT, - WHEN EX1 EQ 1, EX1 EXIT, - LIST ('^, EX1, -1) EXIT, - EXPT (EX1, EX2) EXIT, - WHEN EX2 EQ 1, EX1 EXIT, - WHEN ZERO (EX2) AND ZEROEXPT, 1 EXIT, - WHEN EX1 EQ #I, - EX2: MOD (EX2, 4), - WHEN EX2 EQ 2, -1 EXIT, - WHEN EX2 EQ 3, -#I EXIT, - EX1^EX2 EXIT, - WHEN ATOM (EX1), LIST ('^, EX1, EX2) EXIT, - WHEN APPLY (GET('BASE,FIRST(EX1)), ADJOIN(EX2,ARGEX(EX1))) EXIT, - LIST ('^, EX1, EX2) EXIT, - WHEN ATOM (EX1), - WHEN EX1 EQ 1, 1 EXIT, - WHEN ZERO (EX1), - WHEN EX2 < 0, ? (LIST('^, EX1, EX2)) EXIT, - WHEN EX2 > 0 OR ZEROBASE, 0, EXIT, - LIST ('^, EX1, EX2) EXIT, - WHEN ATOM (EX2), - WHEN EX1 EQ #E AND EX2 EQ #I AND NEGMULT(TRGEXPD,7), - COS(1) + #I*SIN(1) EXIT, - WHEN POSMULT(LOGEXPD,7) AND NOT(EX1=LOGBAS OR EX1<0), - LOGBAS ^ (EX2*LOG(EX1,LOGBAS)) EXIT, - LIST ('^, EX1, EX2) EXIT, - WHEN APPLY (GET('EXPON,FIRST(EX2)), ADJOIN(EX1,ARGEX(EX2))) EXIT, - WHEN POSMULT(LOGEXPD,7) AND NOT(EX1=LOGBAS OR NUMBER(EX2) OR EX1<0), - LOGBAS ^ (EX2*LOG(EX1,LOGBAS)) EXIT, - LIST ('^, EX1, EX2) EXIT, - WHEN APPLY (GET('EXPON,FIRST(EX2)), ADJOIN(EX1,ARGEX(EX2))) EXIT, - WHEN APPLY (GET('BASE,FIRST(EX1)), ADJOIN(EX2,ARGEX(EX1))) EXIT, - WHEN POSMULT(LOGEXPD,7) AND NOT(EX1=LOGBAS OR NUMBER(EX2) OR EX1<0), - LOGBAS ^ (EX2*LOG(EX1,LOGBAS)) EXIT, - LIST ('^, EX1, EX2), -ENDFUN $ - ------------------------------------------------------------- - -%************* optional fractional-power package ******************% - - -PRIMES: '(2, 3, 5, 7, 11, 13, 17, 19) $ - -FUNCTION ROOT (EX1, EX2, EX3, LEX1, EX4, EX5, EX6, - % Local: % EX7), - LOOP - BLOCK - WHEN ZERO (REST (EX7: DIVIDE(EX6,FIRST(LEX1)))), - EX6: FIRST(EX7), - WHEN (EX5:EX5+1) EQ EX3, EX4: EX4*FIRST(LEX1), EX5: 0, EXIT EXIT, - EX5: 0, - WHEN NOT (POP(LEX1) < FIRST(EX7)), EX6: 1 EXIT, - WHEN ATOM(LEX1), - EX7: EX3 - 1, - LEX1: EX6, - LOOP - EX5: LEX1^EX7, - WHEN NOT ((EX5:QUOTIENT(EX6+EX7*LEX1*EX5,EX3*EX5)) < LEX1) EXIT, - LEX1: EX5 - ENDLOOP, - WHEN LEX1^EX3 EQ EX6, EX4: EX4*LEX1, EX6: 1 EXIT, - EX6: 1 EXIT, - ENDBLOCK, - WHEN EX6 EQ 1, - EX1: EX1/(EX4^EX3), EX4: EX4^EX2, - WHEN EX1 EQ 1, EX4 EXIT, - EX4 * LIST ('^, EX1, EX2/EX3) EXIT - ENDLOOP, -ENDFUN $ - -FUNCTION FREE (EX1, EX2), - WHEN EX1 = EX2, FALSE EXIT, - WHEN ATOM(EX1) EXIT, - LOOP - WHEN NOT FREE(POP(EX1),EX2), FALSE EXIT, - WHEN ATOM(EX1), EXIT - ENDLOOP, -ENDFUN $ - -PION2: #PI/2 $ - -PROPERTY EXPON, *, FUNCTION (EX1, EX2, EX3), - WHEN EX1 EQ #E, - WHEN INTEGER(EX2: EX2*EX3/PION2/#I), #I^EX2 EXIT, - WHEN NEGMULT(TRGEXPD,7), - WHEN FREE (EX2: EX2*PION2, #I), - COS(EX2) + #I*SIN(EX2) EXIT EXIT EXIT, - WHEN INTEGER(EX1), - WHEN PBRCH AND INTEGER(EX2), - WHEN INTEGER(EX3:1/EX3), - WHEN EX1 > 0, - ROOT(EX1, EX2, EX3, PRIMES, 1, 0, EX1) EXIT, - WHEN ZERO(MOD(EX3,2)), - #I^(2*EX2/EX3)*ROOT(-EX1,EX2,EX3,PRIMES,1,0,-EX1) EXIT, - (-1)^EX2 * ROOT(-EX1, EX2, EX3, PRIMES, 1, 0, -EX1) - EXIT EXIT EXIT, - WHEN EX1=#I OR EX1=-#I, - WHEN PBRCH AND INTEGER(EX2), - WHEN INTEGER(EX3:1/EX3), - WHEN EX1=#I, #E^(#I*#PI*EX2/EX3/2) EXIT, - #E^(3*#I*#PI*EX2/EX3/2) EXIT, - EXIT EXIT, -ENDFUN $ - -PROPERTY EXPON, ^, FUNCTION (EX1, EX2, EX3), - WHEN INTEGER(EX1), - WHEN INTEGER(EX2), - WHEN PBRCH AND EX3 EQ -1, - WHEN EX1 > 0, ROOT (EX1, 1, EX2, PRIMES, 1, 0, EX1) EXIT, - WHEN ZERO(MOD(EX2,2)), - #I^(2/EX2) * ROOT(-EX1, 1, EX2, PRIMES, 1, 0, -EX1) EXIT, - -ROOT(-EX1, 1, EX2, PRIMES, 1, 0, -EX1) EXIT EXIT EXIT, - WHEN EX1=#I OR EX1=-#I, - WHEN INTEGER(EX2), - WHEN PBRCH AND EX3 EQ -1, - WHEN EX1=#I, #E^(#PI*#I/EX2/2) EXIT, - #E^(3*#PI*#I/EX2/2) EXIT - EXIT EXIT, -ENDFUN $ -%****************** optional factorial package********************% - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/ARITH.MUS b/software/CPM/CPM_MC_5/ARITH.MUS deleted file mode 100644 index 9ad3e15..0000000 --- a/software/CPM/CPM_MC_5/ARITH.MUS +++ /dev/null @@ -1,668 +0,0 @@ -% File ARITH.MUS (c) 8/24/80 The Soft Warehouse % - -LINELENGTH(52) $ - -FUNCTION MULTIPLE (EX1, EX2), - ZERO (MOD (EX1, EX2)), -ENDFUN $ - -FUNCTION POSMULT (EX1, EX2), - POSITIVE (EX1) AND ZERO (MOD (EX1, EX2)), -ENDFUN $ - -FUNCTION NEGMULT (EX1, EX2), - NEGATIVE (EX1) AND ZERO (MOD (EX1, EX2)), -ENDFUN $ - - -FUNCTION SUB (EX1, EX2, EX3), - WHEN EX1 = EX2, EX3 EXIT, - WHEN ATOM (EX1), EX1 EXIT, - ADJOIN (SUB (POP(EX1), EX2, EX3), SUB (EX1, EX2, EX3)), -ENDFUN $ - -FUNCTION EVSUB (EX1, EX2, EX3), - EVAL (SUB (EX1, EX2, EX3)), -ENDFUN $ - - -FUNCTION SUM (EX1), - FIRST(EX1) EQ '+, -ENDFUN $ - -FUNCTION PRODUCT (EX1), - FIRST(EX1) EQ '*, -ENDFUN $ - -FUNCTION POWER (EX1), - FIRST(EX1) EQ '^, -ENDFUN $ - - -FUNCTION RECIP (EX1), - WHEN POWER(EX1) AND INTEGER(SECOND(EX1)), THIRD(EX1) EQ -1 EXIT, -ENDFUN $ - -FUNCTION NUMBER (EX1), - WHEN INTEGER (EX1) OR RECIP (EX1) EXIT, - WHEN PRODUCT (EX1) AND ATOM (RRREST(EX1)), - RECIP (THIRD(EX1)) EXIT, -ENDFUN $ - - -FUNCTION NEGCOEF (EX1), - WHEN INTEGER (EX1), NEGATIVE (EX1) EXIT, - WHEN PRODUCT (EX1), NEGATIVE (SECOND(EX1)) EXIT, -ENDFUN $ - - -FUNCTION MKSUM (LEX1), - WHEN ATOM (LEX1), 0 EXIT, - WHEN ATOM (REST(LEX1)), FIRST (LEX1) EXIT, - ADJOIN ('+, LEX1), -ENDFUN $ - -FUNCTION MKPROD (LEX1), - WHEN ATOM (LEX1), 1 EXIT, - WHEN ATOM (REST(LEX1)), FIRST (LEX1) EXIT, - ADJOIN ('*, LEX1), -ENDFUN $ - - -FUNCTION NUM (EX1), - WHEN ATOM (EX1), EX1 EXIT, - WHEN POWER (EX1), - WHEN NEGCOEF (THIRD(EX1)), 1 EXIT, - EX1 EXIT, - WHEN PRODUCT (EX1), MKPROD (NUM1 (REST(EX1))) EXIT, - EX1, -ENDFUN $ - -FUNCTION NUM1 (LEX1), - WHEN ATOM (LEX1), LEX1 EXIT, - WHEN POWER(EX1:POP(LEX1)) AND NEGCOEF(THIRD(EX1)), NUM1(LEX1) EXIT, - ADJOIN (EX1, NUM1 (LEX1)), -ENDFUN $ - - -FUNCTION DEN (EX1), - WHEN ATOM (EX1), 1 EXIT, - WHEN POWER (EX1), - WHEN NEGCOEF(THIRD(EX1)), SECOND(EX1)^-THIRD(EX1) EXIT, - 1 EXIT, - WHEN PRODUCT (EX1), MKPROD (DEN1 (REST(EX1))) EXIT, - 1, -ENDFUN $ - -FUNCTION DEN1 (LEX1), - WHEN ATOM (LEX1), LEX1 EXIT, - WHEN POWER (EX1:POP(LEX1)) AND NEGCOEF (THIRD(EX1)), - ADJOIN (SECOND(EX1)^-THIRD(EX1), DEN1(LEX1)) EXIT, - DEN1 (LEX1), -ENDFUN $ - - -FUNCTION < (EX1, EX2), - WHEN INTEGER(EX1) AND INTEGER(EX2), LESSER (EX1, EX2) EXIT, - WHEN NUMBER (EX1) AND NUMBER (EX2), - LESSER (NUM(EX1)*DEN(EX2), NUM(EX2)*DEN(EX1)) EXIT, -ENDFUN $ - -FUNCTION > (EX1, EX2), - EX2 < EX1, -ENDFUN $ - - -FUNCTION MIN (EX1, EX2), - WHEN EX1 = EX2, EX1 EXIT, - WHEN NUMBER (EX1) AND NUMBER (EX2), - WHEN EX1 < EX2, EX1 EXIT, - EX2 EXIT, - LIST ('MIN, EX1, EX2), -ENDFUN $ - - -FUNCTION SIMPU (LOP1, EX1), - WHEN NAME (EX1), LIST (LOP1, EX1) EXIT, - WHEN APPLY (GET (LOP1, FIRST(EX1)), ARGEX (EX1)) EXIT, - LIST (LOP1, EX1), -ENDFUN $ - -FUNCTION ABS (EX1), - WHEN NUMBER (EX1), - WHEN 0 < EX1, EX1 EXIT, - -EX1 EXIT, - SIMPU ('ABS, EX1), -ENDFUN $ - - -FUNCTION GCD (EX1, EX2, - % Local: % EX3), - WHEN INTEGER (EX1) AND INTEGER (EX2), - LOOP - WHEN ZERO (EX2), - WHEN POSITIVE (EX1), EX1 EXIT, - MINUS (EX1) EXIT, - EX3: EX2, - EX2: MOD (EX1, EX2), - EX1: EX3, - ENDLOOP EXIT, - LIST ('GCD, EX1, EX2), -ENDFUN $ - -FUNCTION LCM (EX1, EX2), - ABS (EX2*(EX1/GCD(EX1,EX2))), -ENDFUN $ - - -FUNCTION CODIV (EX1), - WHEN INTEGER (EX1), 1 EXIT, - WHEN PRODUCT (EX1), - WHEN INTEGER (SECOND(EX1)), - WHEN RECIP (THIRD(EX1)), MKPROD (RRREST(EX1)) EXIT, - MKPROD (RREST(EX1)) EXIT, - WHEN RECIP (SECOND(EX1)), MKPROD (RREST(EX1)) EXIT, - EX1 EXIT, - WHEN RECIP (EX1), 1 EXIT, - EX1, -ENDFUN $ - -FUNCTION COEFF (EX1), - WHEN INTEGER (EX1), EX1 EXIT, - WHEN PRODUCT (EX1), - WHEN INTEGER (SECOND(EX1)), - WHEN RECIP (THIRD(EX1)), LIST ('*, SECOND(EX1), THIRD(EX1)) EXIT, - SECOND (EX1) EXIT, - WHEN RECIP (SECOND(EX1)), SECOND (EX1) EXIT, - 1 EXIT, - WHEN RECIP (EX1), EX1 EXIT, - 1, -ENDFUN $ - - -FUNCTION BASE (EX1), - WHEN POWER (EX1), - WHEN RECIP (EX1), EX1 EXIT, - SECOND (EX1) EXIT, - EX1, -ENDFUN $ - -FUNCTION EXPON (EX1), - WHEN POWER (EX1), - WHEN RECIP (EX1), 1 EXIT, - THIRD (EX1) EXIT, - 1, -ENDFUN $ - - -FUNCTION DENOM (EX1), - POWER (EX1) AND NEGCOEF (THIRD(EX1)), -ENDFUN $ - - - -FUNCTION ARGEX (EX1), - WHEN ATOM (RRREST (EX1)), REST (EX1) EXIT, - LIST (SECOND (EX1), ADJOIN (FIRST(EX1), RREST(EX1))), -ENDFUN $ - - -FUNCTION ARGLIST (EX1), - WHEN PRODUCT (EX1) OR SUM (EX1), LIST (REST(EX1)) EXIT, - REST (EX1), -ENDFUN $ - - -FUNCTION MKRAT (EX1, EX2), - WHEN EX1 EQ 1, LIST ('^, EX2, -1) EXIT, - LIST ('*, EX1, LIST ('^, EX2, -1)), -ENDFUN $ - -FUNCTION RATSUM (EX1, EX2, EX3), - WHEN EX3 EQ 1, MKRAT (EX1, EX2) EXIT, - EX1: QUOTIENT (EX1, EX3), - EX2: QUOTIENT (EX2, EX3), - EX3: GCD (EX1, EX3), - EX2: QUOTIENT (EX2, EX3), - WHEN EX2 EQ 1, QUOTIENT (EX1, EX3) EXIT, - MKRAT (QUOTIENT(EX1,EX3), EX2), -ENDFUN $ - -FUNCTION ADDTERMS (EX1, EX2), - WHEN ATOM (EX1), - WHEN INTEGER (EX1), - WHEN PLUS (EX1, EX2) EXIT, - WHEN ZERO (EX1), EX2 EXIT, - WHEN ATOM (EX2), FALSE EXIT, - WHEN NUMBER (EX2), - MKRAT (PLUS(NUM(EX2),TIMES(EX1,DEN(EX2))), DEN(EX2)) EXIT, - APPLY (GET('+,FIRST(EX2)), ADJOIN(EX1,ARGLIST(EX2))) EXIT, - WHEN ATOM (EX2), - WHEN ZERO (EX2), EX1 EXIT EXIT, - APPLY (GET('+,FIRST(EX2)), ADJOIN(EX1,ARGLIST(EX2))) EXIT, - WHEN ATOM (EX2), - WHEN INTEGER (EX2), - WHEN ZERO (EX2), EX1 EXIT, - WHEN NUMBER (EX1), - MKRAT (PLUS(NUM(EX1),TIMES(EX2,DEN(EX1))), DEN(EX1)) EXIT, - APPLY (GET('+,FIRST(EX1)), ADJOIN(EX2,ARGLIST(EX1))) EXIT, - APPLY (GET('+,FIRST(EX1)), ADJOIN(EX2,ARGLIST(EX1))) EXIT, - WHEN NUMBER (EX1) AND NUMBER (EX2), RATSUM ( - PLUS (TIMES(NUM(EX1),DEN(EX2)), TIMES(NUM(EX2),DEN(EX1))), - TIMES (EX1:DEN(EX1), EX2:DEN(EX2)), - GCD (EX1, EX2) ) EXIT, - WHEN APPLY (GET('+,FIRST(EX1)), ADJOIN(EX2,ARGLIST(EX1))) EXIT, - APPLY (GET('+,FIRST(EX2)), ADJOIN(EX1,ARGLIST(EX2))), -ENDFUN $ - -FUNCTION INJECTERM (LEX1), - % Fluid vars from MERGETERM: EX1, EX2=CODIV(EX1), EX3 % - WHEN ATOM (LEX1), LIST (EX1) EXIT, - EX3: CODIV (FIRST(LEX1)), - WHEN EX2 = EX3, - EX1: ADDTERMS (COEFF(EX1), COEFF(POP(LEX1))), - WHEN ZERO (EX1), LEX1 EXIT, - ADJOIN (EX1*EX2, LEX1) EXIT, - WHEN ORDERED (EX2, EX3), - ADJOIN (EX1, LEX1) EXIT, - ADJOIN (POP(LEX1), INJECTERM (LEX1)), -ENDFUN $ - -FUNCTION MERGETERM (EX1, LEX1, - % Local: % EX2, EX3, LEX2, LEX3), - LEX2: LEX1, - LOOP - WHEN ATOM (LEX2), - EX2: CODIV (EX1), - INJECTERM (LEX1) EXIT, - WHEN EX3: ADDTERMS (EX1, EX2:POP(LEX2)), - MERGESUM (EX3, REVERSE(LEX3,LEX2)) EXIT, - PUSH (EX2, LEX3), - ENDLOOP, -ENDFUN $ - -FUNCTION MERGESUM (EX1, LEX1, - % Local: % LEX2), - WHEN ATOM (LEX1), - WHEN SUM (EX1), REST (EX1) EXIT, - LIST (EX1) EXIT, - WHEN SUM (EX1), - LEX2: REST (EX1), - LOOP - LEX1: MERGETERM (POP(LEX2), LEX1), - WHEN ATOM (LEX2), LEX1 EXIT, - ENDLOOP EXIT, - MERGETERM (EX1, LEX1), -ENDFUN $ - -FUNCTION SUMLEX (LEX1, - % Local: % LEX2), - LOOP - LEX2: MERGESUM (POP(LEX1), LEX2), - WHEN ATOM (LEX1), % When the end of LEX1 is reached, % - MKSUM (LEX2) EXIT, % make a sum of LEX2 and return. % - ENDLOOP, -ENDFUN $ - -FUNCTION + LEX1, % Nary plus function % - SUMLEX (LEX1), -ENDFUN $ - - -FUNCTION - (EX1, % Optional: % EX2), - WHEN EMPTY (EX2), -1*EX1 EXIT, - EX1 + -EX2, -ENDFUN $ - - -FUNCTION MULTFACTS (EX1, EX2), - WHEN ATOM (EX1), - WHEN INTEGER (EX1), - WHEN TIMES (EX1, EX2) EXIT, - WHEN ZERO (EX1), 0 EXIT, - WHEN EX1 EQ 1, EX2 EXIT, - WHEN ATOM (EX2), FALSE EXIT, - APPLY (GET('*,FIRST(EX2)), ADJOIN(EX1,ARGLIST(EX2))) EXIT, - WHEN ATOM (EX2), - WHEN ZERO (EX2), 0 EXIT, - WHEN EX2 EQ 1, EX1 EXIT EXIT, - APPLY (GET('*,FIRST(EX2)), ADJOIN(EX1,ARGLIST(EX2))) EXIT, - WHEN ATOM (EX2), - WHEN INTEGER (EX2), - WHEN ZERO (EX2), 0 EXIT, - WHEN EX2 EQ 1, EX1 EXIT, - APPLY (GET('*,FIRST(EX1)), ADJOIN(EX2,ARGLIST(EX1))) EXIT, - APPLY (GET('*,FIRST(EX1)), ADJOIN(EX2,ARGLIST(EX1))) EXIT, - WHEN APPLY (GET('*,FIRST(EX1)), ADJOIN(EX2,ARGLIST(EX1))) EXIT, - APPLY (GET('*,FIRST(EX2)), ADJOIN(EX1,ARGLIST(EX2))), -ENDFUN $ - -FUNCTION MERGEFACT (EX1, LEX1, - % Local: % EX2, EX3, EX4, LEX2, LEX3), - LEX2: LEX1, - LOOP - WHEN ATOM (LEX2), % If no common BASE or combination % - WHEN INTEGER(EX1), ADJOIN(EX1,LEX1) EXIT, - WHEN RECIP (EX1), - WHEN INTEGER (EX3:FIRST(LEX1)), - ADJOIN (EX3, ADJOIN (EX1, REST(LEX1))) EXIT, - ADJOIN (EX1, LEX1) EXIT, - LEX3: FALSE, % of EX1 in LEX1 found, insert EX1 % - EX2: BASE (EX1), - LOOP % in LEX1 in the proper order. % - WHEN ATOM(LEX1), REVERSE (LEX3, LIST(EX1)) EXIT, - WHEN EX2 = (EX4: BASE(EX3:FIRST(LEX1))), - EX3: EXPON (EX3), - WHEN NUMBER (EX4:EXPON(EX1)) AND NUMBER (EX3), - EX1: EX2 ^ ADDTERMS (EX4, EX3), - MERGEPROD (EX1, REVERSE (LEX3, REST(LEX1))) EXIT, - WHEN ORDERED (EX4, EX3), - REVERSE (LEX3, ADJOIN(EX1, LEX1)) EXIT, - REVERSE (LEX3, ADJOIN (POP(LEX1), ADJOIN(EX1,LEX1))) EXIT, - WHEN ORDERED (EX2, EX4) AND NOT RECIP (EX3), - REVERSE (LEX3, ADJOIN (EX1, LEX1)) EXIT, - PUSH (EX3, LEX3), - LEX1: REST (LEX1), - ENDLOOP EXIT, - WHEN EX3: MULTFACTS (EX1, EX2:POP(LEX2)), - MERGEPROD (EX3, REVERSE(LEX3,LEX2)) EXIT, - PUSH (EX2, LEX3), - ENDLOOP, -ENDFUN $ - -FUNCTION MERGEPROD (EX1, LEX1, - % Local: % LEX2), - WHEN ATOM (LEX1), - WHEN PRODUCT (EX1), REST (EX1) EXIT, - LIST (EX1) EXIT, - WHEN PRODUCT (EX1), - LEX2: REST (EX1), - LOOP - LEX1: MERGEFACT (POP(LEX2), LEX1), - WHEN ATOM (LEX2), LEX1 EXIT, - ENDLOOP EXIT, - MERGEFACT (EX1, LEX1), -ENDFUN $ - -FUNCTION PRODLEX (LEX1, LEX2), - LOOP - LEX2: MERGEPROD (POP(LEX1), LEX2), - WHEN ATOM (LEX1), % When the end of LEX1 is reached, % - MKPROD (LEX2) EXIT, % make a product of LEX2 and return.% - ENDLOOP, -ENDFUN $ - -FUNCTION * LEX1, % Nary product function. % - PRODLEX (LEX1), -ENDFUN $ - - -FUNCTION ? (EX1), - PRINT (" *** WARNING: "), - PRTMATH (EX1, 0, 0, TRUE), - NEWLINE (), - LIST ('?, EX1), -ENDFUN $ - -FUNCTION / (EX1, EX2), - WHEN ZERO (EX2), ?(LIST('/, EX1, EX2)) EXIT, - EX1 * EX2^-1, -ENDFUN $ - - -FUNCTION SQUARE (EX1), - EX1*EX1, -ENDFUN $ - -FUNCTION EXPT (EX1, EX2, - % Local: % EX3), - EX3: 1, - LOOP - BLOCK - WHEN REST(EX2:DIVIDE(EX2,2)) EQ 1, EX3: EX1*EX3 EXIT, - ENDBLOCK, - WHEN ZERO (EX2:FIRST(EX2)), EX3 EXIT, - EX1: SQUARE(EX1), - ENDLOOP, -ENDFUN $ - - -ZEROBASE: FALSE $ - -ZEROEXPT: TRUE $ - -TRGEXPD: 0 $ - -LOGEXPD: 0 $ - -LOGBAS: #E $ - -FLAGS: '(TRGEXPD LOGEXPD LOGBAS ZEROBASE ZEROEXPT) $ - - -FUNCTION ^ (EX1, EX2), - WHEN INTEGER (EX2), - WHEN INTEGER (EX1), - WHEN EX1 EQ 1, 1 EXIT, - WHEN ZERO(EX1) AND ZERO(EX2), ?(LIST('^, EX1, EX2)) EXIT, - WHEN NEGATIVE (EX2), - WHEN ZERO (EX1), ?(LIST('^, EX1, EX2)) EXIT, - EX1: EXPT (EX1, -EX2), - WHEN NEGATIVE (EX1), -((-EX1)^-1) EXIT, - WHEN EX1 EQ 1, EX1 EXIT, - LIST ('^, EX1, -1) EXIT, - EXPT (EX1, EX2) EXIT, - WHEN EX2 EQ 1, EX1 EXIT, - WHEN ZERO (EX2) AND ZEROEXPT, 1 EXIT, - WHEN EX1 EQ #I, - EX2: MOD (EX2, 4), - WHEN EX2 EQ 2, -1 EXIT, - WHEN EX2 EQ 3, -#I EXIT, - EX1^EX2 EXIT, - WHEN ATOM (EX1), LIST ('^, EX1, EX2) EXIT, - WHEN APPLY (GET('BASE,FIRST(EX1)), ADJOIN(EX2,ARGEX(EX1))) EXIT, - LIST ('^, EX1, EX2) EXIT, - WHEN ATOM (EX1), - WHEN EX1 EQ 1, 1 EXIT, - WHEN ZERO (EX1), - WHEN EX2 < 0, ? (LIST('^, EX1, EX2)) EXIT, - WHEN EX2 > 0 OR ZEROBASE, 0, EXIT, - LIST ('^, EX1, EX2) EXIT, - WHEN ATOM (EX2), - WHEN EX1 EQ #E AND EX2 EQ #I AND NEGMULT(TRGEXPD,7), - COS(1) + #I*SIN(1) EXIT, - WHEN POSMULT(LOGEXPD,7) AND NOT(EX1=LOGBAS OR EX1<0), - LOGBAS ^ (EX2*LOG(EX1,LOGBAS)) EXIT, - LIST ('^, EX1, EX2) EXIT, - WHEN APPLY (GET('EXPON,FIRST(EX2)), ADJOIN(EX1,ARGEX(EX2))) EXIT, - WHEN POSMULT(LOGEXPD,7) AND NOT(EX1=LOGBAS OR NUMBER(EX2) OR EX1<0), - LOGBAS ^ (EX2*LOG(EX1,LOGBAS)) EXIT, - LIST ('^, EX1, EX2) EXIT, - WHEN APPLY (GET('BASE,FIRST(EX1)), ADJOIN(EX2,ARGEX(EX1))) EXIT, - WHEN POSMULT(LOGEXPD,7) AND NOT(EX1=LOGBAS OR NUMBER(EX2) OR EX1<0), - LOGBAS ^ (EX2*LOG(EX1,LOGBAS)) EXIT, - WHEN ATOM(EX2), LIST ('^, EX1, EX2) EXIT, - WHEN APPLY (GET('EXPON,FIRST(EX2)), ADJOIN(EX1,ARGEX(EX2))) EXIT, - LIST ('^, EX1, EX2), -ENDFUN $ - - -PROPERTY *, ^, FUNCTION (EX1, EX2, EX3), - WHEN EX3 EQ -1, - WHEN INTEGER (EX2), - WHEN INTEGER (EX1), - EX3: GCD (EX1, EX2), - WHEN EX3 EQ 1, FALSE EXIT, - EX1: QUOTIENT (EX1, EX3), - EX2: QUOTIENT (EX2, EX3), - WHEN EX2 EQ 1, EX1 EXIT, - EX2: LIST ('^, EX2, -1), - WHEN EX1 EQ 1, EX2 EXIT, - LIST ('*, EX1, EX2) EXIT, - WHEN RECIP(EX1), LIST ('^, TIMES(EX2,SECOND(EX1)), -1) EXIT, - EXIT EXIT, -ENDFUN $ - - -PBRCH: TRUE $ - -PUSH ('PBRCH, FLAGS) $ - - -PROPERTY BASE, ^, FUNCTION (EX1, EX2, EX3), - WHEN INTEGER (EX1) OR PBRCH, - EX2^(EX1*EX3) EXIT, -ENDFUN $ - - -PROPERTY BASE, *, FUNCTION (EX1, EX2, EX3), - EX2^EX1 * EX3^EX1, -ENDFUN $ - - -PROPERTY PRTMATH, *, FUNCTION (LEX1, - % Local: % EX1, LEX2, LEX3), - LOOP - BLOCK - WHEN DENOM (EX1:POP(LEX1)), - BLOCK - WHEN THIRD(EX1) EQ -1, EX1: SECOND(EX1) EXIT, - EX1: LIST ('^, SECOND(EX1), -THIRD(EX1)), - ENDBLOCK, - PUSH (EX1, LEX3) EXIT, - PUSH (EX1, LEX2), - ENDBLOCK, - WHEN ATOM (LEX1) EXIT, - ENDLOOP, - WHEN ATOM (LEX3), - EX1: FIRST (LEX2:REVERSE(LEX2)), - LEX1: REST (LEX2), - WHEN EX1 EQ -1, - PRTPAREN (LPAR), - PRINT ('-), - EX1: POP (LEX1), - PRTSPACE (), - WHEN ATOM (LEX1), - PRTMATH (EX1, 130, 0), - PRTPAREN (RPAR), - TRUE EXIT, - PRTMATH (EX1, 130, GET ('LBP, LOP1)), - LOOP - EX1: POP(LEX1), - PRTSPACE (), - PRINT (LOP1), - PRTSPACE (), - WHEN ATOM (LEX1) EXIT, - PRTMATH (EX1, GET ('RBP, LOP1), GET ('LBP, LOP1)), - ENDLOOP, - PRTMATH (EX1, GET ('RBP, LOP1), 0), - PRTPAREN (RPAR), - TRUE EXIT, - FALSE EXIT, - PRTMATH (LIST ('/, MKPROD(REVERSE(LEX2)), MKPROD(REVERSE(LEX3))), - RBP, LBP, PRTSPACE), - TRUE, -ENDFUN $ - - -PROPERTY PRTMATH, ^, FUNCTION (LEX1, - % Local: % EX1, EX2), - EX1: FIRST (LEX1), - WHEN NEGCOEF (EX2:SECOND(LEX1)), - WHEN EX2 EQ -1, - PRTMATH (LIST ('/, 1, EX1), RBP, LBP, PRTSPACE) EXIT, - PRTMATH (LIST ('/, 1, LIST('^,EX1,-EX2)), RBP, - LBP, PRTSPACE) EXIT, -ENDFUN $ - - -%************* optional fractional-power package ******************% - - -PRIMES: '(2, 3, 5) $ - -FUNCTION ROOT (EX1, EX2, EX3, LEX1, EX4, EX5, EX6, - % Local: % EX7), - LOOP - BLOCK - WHEN ZERO (REST (EX7: DIVIDE(EX6,FIRST(LEX1)))), - EX6: FIRST(EX7), - WHEN (EX5:EX5+1) EQ EX3, EX4: EX4*FIRST(LEX1), EX5: 0, EXIT EXIT, - EX5: 0, - WHEN NOT (POP(LEX1) < FIRST(EX7)), EX6: 1 EXIT, - WHEN ATOM(LEX1), - EX7: EX3 - 1, - LEX1: EX6, - LOOP - EX5: LEX1^EX7, - WHEN NOT ((EX5:QUOTIENT(EX6+EX7*LEX1*EX5,EX3*EX5)) < LEX1) EXIT, - LEX1: EX5 - ENDLOOP, - WHEN LEX1^EX3 EQ EX6, EX4: EX4*LEX1, EX6: 1 EXIT, - EX6: 1 EXIT, - ENDBLOCK, - WHEN EX6 EQ 1, - EX1: EX1/(EX4^EX3), EX4: EX4^EX2, - WHEN EX1 EQ 1, EX4 EXIT, - EX4 * LIST ('^, EX1, EX2/EX3) EXIT - ENDLOOP, -ENDFUN $ - -FUNCTION FREE (EX1, EX2), - WHEN EX1 = EX2, FALSE EXIT, - WHEN ATOM(EX1) EXIT, - LOOP - WHEN NOT FREE(POP(EX1),EX2), FALSE EXIT, - WHEN ATOM(EX1), EXIT - ENDLOOP, -ENDFUN $ - -PION2: #PI/2 $ - -PROPERTY EXPON, *, FUNCTION (EX1, EX2, EX3), - WHEN EX1 EQ #E, - WHEN INTEGER(EX2: EX2*EX3/PION2/#I), #I^EX2 EXIT, - WHEN NEGMULT(TRGEXPD,7), - WHEN FREE (EX2: EX2*PION2, #I), - COS(EX2) + #I*SIN(EX2) EXIT EXIT EXIT, - WHEN INTEGER(EX1), - WHEN PBRCH AND INTEGER(EX2), - WHEN INTEGER(EX3:1/EX3), - WHEN EX1 > 0, - ROOT(EX1, EX2, EX3, PRIMES, 1, 0, EX1) EXIT, - WHEN ZERO(MOD(EX3,2)), - #I^(2*EX2/EX3)*ROOT(-EX1,EX2,EX3,PRIMES,1,0,-EX1) EXIT, - (-1)^EX2 * ROOT(-EX1, EX2, EX3, PRIMES, 1, 0, -EX1) - EXIT EXIT EXIT, -ENDFUN $ - -PROPERTY EXPON, ^, FUNCTION (EX1, EX2, EX3), - WHEN INTEGER(EX1), - WHEN INTEGER(EX2), - WHEN PBRCH AND EX3 EQ -1, - WHEN EX1 > 0, ROOT (EX1, 1, EX2, PRIMES, 1, 0, EX1) EXIT, - WHEN ZERO(MOD(EX2,2)), - #I^(2/EX2) * ROOT(-EX1, 1, EX2, PRIMES, 1, 0, -EX1) EXIT, - -ROOT(-EX1, 1, EX2, PRIMES, 1, 0, -EX1) EXIT EXIT EXIT, -ENDFUN $ - -%****************** optional factorial package********************% - - -FUNCTION ! (EX1, - % Local: % EX2), - WHEN ZERO (EX1) OR POSITIVE (EX1), - EX2: 1, - LOOP - WHEN ZERO(EX1), EX2 EXIT, - EX2: TIMES (EX1, EX2), - EX1: DIFFERENCE (EX1, 1), - ENDLOOP EXIT, - SIMPU ('!, EX1), -ENDFUN $ - -PROPERTY LBP, !, 160 $ - - -RDS () $ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/ARRAY.ARI b/software/CPM/CPM_MC_5/ARRAY.ARI deleted file mode 100644 index 251e189..0000000 --- a/software/CPM/CPM_MC_5/ARRAY.ARI +++ /dev/null @@ -1,210 +0,0 @@ -% File: ARRAY.ARI (c) 04/27/81 The Soft Warehouse % - - -PROPERTY PREFIX, [, ADJOIN ('[, MATCH('])) $ - -PUSH ('], DELIMITER) $ - -PROPERTY PRTMATH, [, FUNCTION (LEX1), - PRINT ('[), - WHEN ATOM (LEX1), PRINT (']) EXIT, - LOOP - PRTMATH (POP(LEX1), 0, 0), - WHEN ATOM (LEX1), PRINT (']) EXIT, - PRINT (", "), - ENDLOOP, -ENDFUN $ - -FUNCTION ROW (EX1), - FIRST (EX1) EQ '[, -ENDFUN $ - -FUNCTION ARGLIST(EX1), - WHEN MEMBER (POP(EX1), '(+ * [ {)), - LIST (EX1) EXIT, - EX1, -ENDFUN $ - -FUNCTION MAPADD2 (LEX1, LEX2), - WHEN ATOM (LEX1), LEX2 EXIT, - WHEN ATOM (LEX2), LEX1 EXIT, - ADJOIN (POP(LEX1)+POP(LEX2), MAPADD2(LEX1,LEX2)), -ENDFUN $ - -PROPERTY +, [, FUNCTION (EX1, LEX1), - WHEN ROW (EX1), - ADJOIN('[, MAPADD2(REST(EX1),LEX1)) EXIT, -ENDFUN $ - -FUNCTION MAPMULT1 (LEX1), - % Fluid var from property "*[" or "*{": EX1 % - WHEN ATOM (LEX1), FALSE EXIT, - ADJOIN (EX1*POP(LEX1), MAPMULT1(LEX1)), -ENDFUN $ - -FUNCTION MAPMULT2 (LEX1, LEX2), - WHEN ATOM (LEX1), FALSE EXIT, - WHEN ATOM (LEX2), FALSE EXIT, - ADJOIN (POP(LEX1)*POP(LEX2), MAPMULT2(LEX1,LEX2)), -ENDFUN $ - -PROPERTY *, [, FUNCTION (EX1, LEX1), - WHEN ROW (EX1), - ADJOIN ('[, MAPMULT2(REST(EX1),LEX1)) EXIT, - ADJOIN ('[, MAPMULT1(LEX1)), -ENDFUN $ - -FUNCTION MAPEXPON (LEX1), - % Fluid var from property "BASE[" or "BASE{": EX1 % - WHEN ATOM (LEX1), FALSE EXIT, - ADJOIN (POP(LEX1)^EX1, MAPEXPON(LEX1)), -ENDFUN $ - -FUNCTION COL (EX1), - FIRST (EX1) EQ '{, -ENDFUN $ - -FUNCTION ARRAY (EX1), - ROW (EX1) OR COL (EX1), -ENDFUN $ - -FUNCTION ARGEX(EX1), - WHEN ARRAY (EX1), - LIST(REST(EX1)) EXIT, - WHEN ATOM (RRREST(EX1)), - REST(EX1) EXIT, - LIST(SECOND(EX1), ADJOIN(FIRST(EX1), RREST(EX1))), -ENDFUN $ - -PROPERTY BASE, [, FUNCTION (EX1, LEX1), - ADJOIN ('[, MAPEXPON(LEX1)), -ENDFUN $ - -FUNCTION MAPBASE (LEX1), - % Fluid var from property "EXPON[" or "EXPON{": EX1 % - WHEN ATOM (LEX1), FALSE EXIT, - ADJOIN (EX1^POP(LEX1), MAPBASE(LEX1)), -ENDFUN $ - -PROPERTY EXPON, [, FUNCTION (EX1, LEX1), - ADJOIN ('[, MAPBASE(LEX1)), -ENDFUN $ - -FUNCTION MAPFUN(LOP1, LEX1), - WHEN ATOM (LEX1), FALSE EXIT, - ADJOIN (LOP1(POP(LEX1)), MAPFUN(LOP1, LEX1)), -ENDFUN $ - -FUNCTION SIMPU (LOP1, EX1), - WHEN NAME (EX1), - LIST(LOP1,EX1) EXIT, - WHEN APPLY (GET(LOP1,FIRST(EX1)), ARGEX(EX1)) EXIT, - WHEN MEMBER (FIRST(EX1), '("==" [ {)), - ADJOIN (POP(EX1), MAPFUN(LOP1,EX1)) EXIT, - LIST (LOP1, EX1), -ENDFUN $ - - -%******************** Optional Column Package *****************% - - -PROPERTY PREFIX, {, ADJOIN ('{, MATCH('})) $ - -PUSH ('}, DELIMITER) $ - -PROPERTY +, {, FUNCTION (EX1, LEX1), - WHEN COL (EX1), - ADJOIN('{, MAPADD2(REST(EX1), LEX1)) EXIT, -ENDFUN $ - -PROPERTY *, {, FUNCTION (EX1, LEX1), - WHEN COL (EX1), - ADJOIN('{, MAPMULT2(REST(EX1), LEX1)) EXIT, - ADJOIN ('{, MAPMULT1(LEX1)), -ENDFUN $ - -PROPERTY BASE, {, FUNCTION (EX1, LEX1), - ADJOIN ('{, MAPEXPON(LEX1)), -ENDFUN $ - -PROPERTY EXPON, {, FUNCTION (EX1, LEX1), - ADJOIN ('{, MAPBASE(LEX1)), -ENDFUN $ - -PROPERTY PRTMATH, {, FUNCTION (LEX1, EX1), - PRINT('{), - WHEN ATOM (LEX1), PRINT ('}) EXIT, - EX1: SPACES (), - LOOP - PRTMATH (POP(LEX1), 0, 0, TRUE), - WHEN ATOM (LEX1) EXIT, - PRINTLINE (COMMA), - SPACES (EX1), - ENDLOOP, - PRINT ('}), -ENDFUN $ - - -%******************** Optional Subscript Package **************% - -PROPERTY INFIX, [, ADJOIN (SUBSCR, ADJOIN(EX1, MATCH(']))) $ - -PROPERTY LBP, [, 200 $ - -FUNCTION SUBSCR LEX1, - SUBSCR1 (POP(LEX1), LEX1), -ENDFUN $ - -FUNCTION SUBSCR1 (EX1, LEX1), - WHEN ATOM(LEX1), EX1 EXIT, - WHEN ARRAY(EX1) AND POSITIVE(FIRST(LEX1)), - SUBSCR2(REST(EX1), FIRST(LEX1)) EXIT, - ADJOIN (SUBSCR, ADJOIN(EX1,LEX1)), -ENDFUN $ - -FUNCTION SUBSCR2 (LEX2, EX1), - WHEN ATOM(LEX2), 0 EXIT, - WHEN EX1 EQ 1, - SUBSCR1 (FIRST(LEX2), REST(LEX1)) EXIT, - SUBSCR2 (REST(LEX2), EX1 - 1), -ENDFUN $ - -PROPERTY PRTMATH, SUBSCR, FUNCTION (LEX1), - PRTMATH (POP(LEX1), 0, 0), - PRTMATH (ADJOIN ('[, LEX1), 0, 0), -ENDFUN $ - - -%************* Optional Subscripted Assignment Package ************% - -PROPERTY INFIX, :, COND ( - WHEN NAME (EX1), - LIST (':, EX1, PARSE (SCAN,20)) EXIT, - WHEN FIRST(EX1) EQ 'SUBSCR, - LIST (UPDATE, SECOND(EX1), RREST(EX1), PARSE(SCAN,20)) EXIT, - WHEN SYNTAX () EXIT) $ - -SUBROUTINE UPDATE (EX1, LEX1, EX2), - ASSIGN (EX1, UPDATE1 (EVAL(EX1), LEX1)), -ENDSUB $ - -FUNCTION UPDATE1 (EX3, LEX1), - WHEN ATOM (LEX1), - EVAL (EX2) EXIT, - WHEN ARRAY (EX3) AND POSITIVE (FIRST(LEX1)), - ADJOIN (FIRST(EX3), UPDATE2(REST(EX3),FIRST(LEX1))) EXIT, - ? (LIST ('_, EX1, EX2)), -ENDFUN $ - -FUNCTION UPDATE2 (LEX2, EX4), - BLOCK - WHEN ATOM (LEX2), - LEX2: LIST(0) EXIT, - ENDBLOCK, - WHEN EX4 EQ 1, - ADJOIN (UPDATE1(FIRST(LEX2),REST(LEX1)), REST(LEX2)) EXIT, - ADJOIN (FIRST(LEX2), UPDATE2 (REST(LEX2), EX4-1)), -ENDFUN $ - -RDS () $ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/ATRG.TRG b/software/CPM/CPM_MC_5/ATRG.TRG deleted file mode 100644 index 5604cfb..0000000 --- a/software/CPM/CPM_MC_5/ATRG.TRG +++ /dev/null @@ -1,75 +0,0 @@ -% file ATRG.TRG GAE - March, 1982 - Inverse trig functions. - This file can be compiled as-is. - It requires TRGNEG.ALG. ---------------------------------------------------------------% - -PION3: #PI/3 $ -PION2: HALF*#PI $ -PION4: HALF*PION2 $ -PION6: HALF*PION3 $ - -ONRT2: HALF^HALF $ -ROOT3: 3^HALF $ -ONRT3: 1/ROOT3 $ -RT3ON2: ROOT3*HALF $ - -FUNCTION IDPBRCH(EX1), - WHEN PBRCH, EX1 EXIT, -ENDFUN $ - -FUNCTION COPBRCH(EX1), - WHEN PBRCH, PION2-EX1 EXIT, -ENDFUN $ - -FUNCTION ASIN(EX1), - WHEN NOT PBRCH, SIMPU('ASIN,EX1) EXIT, - EX1: TRGEXPD(EX1,-2), - WHEN NEGLT(EX1), -ASIN(-EX1) EXIT, - WHEN ZERO(EX1), 0 EXIT, - WHEN EX1=HALF, PION6 EXIT, - WHEN EX1=ONRT2, PION4 EXIT, - WHEN EX1=RT3ON2, POIN3 EXIT, - WHEN EX1=1, PION2 EXIT, - WHEN POSMULT(TRGEXPD,7), #I*LOG((1-EX1^2)^(1/2)-#I*EX1,#E) EXIT, - SIMPU('ASIN,EX1), -ENDFUN $ - -FUNCTION ATAN(EX1), - WHEN NOT PBRCH, SIMPU('ATAN,EX1) EXIT, - EX1: TRGEXPD(EX1,-2), - WHEN EX1=MINF, -PION2 EXIT, - WHEN NEGLT(EX1), -ATAN(-EX1) EXIT, - WHEN ZERO(EX1), 0 EXIT, - WHEN EX1=ONRT3, PION6 EXIT, - WHEN EX1=1, PION4 EXIT, - WHEN EX1=ROOT3, PION3 EXIT, - WHEN EX1=PINF, PION2 EXIT, - WHEN POSMULT(TRGEXPD,7), HALF*#I*LOG((#I+EX1)/(#I-EX1),#E) EXIT, - SIMPU('ATAN,EX1), -ENDFUN $ - -FUNCTION ACOS(EX1), - PION2-ASIN(EX1), -ENDFUN $ - -FUNCTION ACOT(EX1), - ATAN(1/EX1), -ENDFUN $ - -FUNCTION ASEC(EX1), - PION2 - ASIN(1/EX1), -ENDFUN $ - -FUNCTION ACSC(EX1), - ASIN(1/EX1), -ENDFUN $ - -PROPERTY ASIN, SIN, IDPBRCH $ -PROPERTY ATAN, TAN, IDPBRCH $ - -PROPERTY ASIN, COS, COPBRCH $ -PROPERTY ATAN, COT, COPBRCH $ - -RDS() $ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/CLES1.ARI b/software/CPM/CPM_MC_5/CLES1.ARI deleted file mode 100644 index e4b5d58..0000000 --- a/software/CPM/CPM_MC_5/CLES1.ARI +++ /dev/null @@ -1,203 +0,0 @@ -%File: CLES1.ARI (c) 08/10/80 - The Soft Warehouse % - - -LINELENGTH(39)$ NEWLINE: 1$ ECHO: TRUE$ - -% If this lesson is being displayed -too fast, it can be temporarily stopped -by typing a CTRL-S (i.e. typing the -letter "S" while depressing the CTRL -key). Then type it again when you are -ready to resume. - - It is advisable to read sections -4, 5, 6 and 8 of the muMATH Reference -Manual before beginning these lessons. -This lesson can be aborted at any time -by typing the ESCape key on your -console followed by a CTRL-C. - - In muMATH a "comment" is a percent -sign followed by any number of other -characters terminated by a matching -percent sign. Thus, the text of this -explanation is a comment which has not -yet been terminated. Comments do not -cause computation; they are merely used -to explain programs and examples to -human readers. Here is an example of -an actual computation% - -1/2 + 1/6 ; -% Note how muMATH uses exact -rational arithmetic, reducing fractions -to lowest terms. - - In muMATH, arithmetic expressions -can be formed in the usual manner, -using parentheses together with the -operators "+", "-", "*", "/", and "^" -respectively for addition, subtraction -or negation, multiplication, division, -and raising to a power. For example: % - -(3*4 - 5) ^ 2 ; -% The reason for using ^ and * is -that standard terminals do not provide -superscripts or centered dots or -special multiplication crosses distinct -from the letter X. - - To prevent certain ambiguities, -multiplication cannot be implied by -mere juxtaposition. One of the most -frequent mistakes of beginners is to -omit asterisks. - - Later, in order to give you an -opportunity to try some examples, we -will "assign" the value FALSE to the -variable named RDS. When you are ready -to resume the lesson, type the -"assignment" - - RDS: TRUE ; - -including the semicolon and carriage -return. This revises the value of the -variable named RDS to the value TRUE. -We will explain assignment in more -detail later. - - Don't forget that you can use -local editing to correct mistypings on -the current line. For example, the key -marked "<--" cancels the last character -typed on the line, and typing a CTRL-X -cancels the current line. There is no -way to modify a line after striking the -RETURN key, but an expression can -always be flushed by typing a final -line containing a "grammatical" or -"syntax" error such as "(;". - - Now we are going to turn control -over to you by setting RDS to FALSE. -Try some examples of your own similar -to the above. Also we suggest that you -make a few intentional errors in order -to become familiar with how they are -treated. For example, try - 5 7; 5+ /7; - 5/0; and 0/0; - Have fun!: % RDS: FALSE ; - -% The value resulting from the last -input expression is automatically saved -as the value of a variable named "@", -which can be used in the next -expression. For example: % - -3 ;@ ^ @ ;@ ^ @; -% As this example illustrates, -muMATH can treat very large numbers -exactly and quickly. In fact, muMATH -can accomodate numbers up to about 611 -digits. To partially appreciate how -large this is, compute the distance in -feet or in meters to the star Alpha -Centauri, which is 4 light years away, -then use "@" to compute the distance in -inches or in centimeters without -starting all over. (In case you -forgot, the speed of light is 186,000 -miles/second or 300,000,000 -meters/second.) % -RDS: FALSE ; -% Our answers are about -123,883,499,520,000,000 feet or -1,486,601,994,240,000,000 inches or -37,843,200,000,000,000 meters or -3,784,320,000,000,000,000 centimeters. -Another dramatic comparison with 10^611 -is that there are thought to be about -10^72 electrons in the entire universe. -(Whoever counted them must be -exhausted!) - - Often one performs an intermediate -computation or a trivial assignment for -which there is no need to display the -result. When this is the case, the -display of the result can be suppressed -by using a dollar sign rather than a -semicolon as a terminator. For -example, type - - RDS: TRUE $ - -and note the difference from when you -previously typed RDS:TRUE ; % - -RDS: FALSE $ -% It is often convenient to save -values longer than "@" saves them, for -use beyond the next input expression. -The colon ASSIGNMENT operator provides -a means of doing so. The name on the -left side of the assignment operator is -BOUND or SET to the value of the -expression on its right. This value is -saved as the value of the name until -the name is bound subsequently to some -other value. The name can be used as a -variable in subsequent expressions, as -we have used "@", in which case the -name contributes its value to the -expression. For example: % - -RATE: 55 $ TIME: 2 $ DISTANCE: RATE * TIME ; -% Alphabetic characters include the -letters A through Z, both upper and -lower case, and the character "#". -Note that the upper and lower case -version of a letter are entirely -distinct. Names can be any sequence of -alphabetic characters or digits, -provided the first character is -alphabetic. Thus X, #9, and ABC3 are -valid names. Make an assignment of -3600 to a variable named SECPERHOUR, -then use this variable to help compute -the number of seconds in 1 day and 1 -week: % -RDS: FALSE $ -% Congratulations on completing -CLES1.ARI. To execute the next lesson, -merely enter the muMATH command - - RDS (CLES2, ARI, drive); - -where drive is the name of the drive on -which that lesson is mounted. -Alternatively, it may be advisable to -repeat this lesson, perhaps another -day, if this lesson was not perfectly -clear. The use of any computer program -tends to become much clearer the second -time. - - In order to experience the -decisive learning reinforcement -afforded by meaningful personal -examples that are not arbitrarily -contrived, we urge you to bring to -subsequent lessons appropriate examples -from textbooks, tables, articles, or -elsewhere. Also, you are encouraged to -experiment further with the techniques -learned in this lesson: % - -ECHO: FALSE$ NEWLINE: 0$ RDS() $ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/CLES2.ARI b/software/CPM/CPM_MC_5/CLES2.ARI deleted file mode 100644 index d92f850..0000000 --- a/software/CPM/CPM_MC_5/CLES2.ARI +++ /dev/null @@ -1,178 +0,0 @@ -%File: CLES2.ARI (c) 08/10/80 - The Soft Warehouse % - - -LINELENGTH (39)$ NEWLINE: 1$ ECHO: TRUE$ - -% This file is the second of a -sequence of interactive lessons on how -to use the muMATH symbolic math system. -This lesson presumes that the muMATH -files through ARITH.MUS have been -loaded. - - For positive integer N, N -factorial is the product of the first N -integers. The "postfix" factorial -operator is "!", which returns the -factorial of its operand. For example, -3! yields 6, which is 1*2*3. Use this -operator to determine the product of -the first 100 integers: % -RDS: FALSE $ -% The number base used for input and -output is initially ten, but the RADIX -function can be used to change it to -any base from two through thirty-six. -For example, to see what thirty looks -like in base two: % - -THIRTY: 30 $ RADIX (2) ; THIRTY ; -% As you can see, the radix function -returns the previous base, which is, of -course, displayed in the new number -base. This information helps to get -back to a previous base. In base two, -eight is written as 1000, so to see -what thirty looks like in base eight: -% - -RADIX (1000) ; THIRTY ; -% In base eight, sixteen is written -as 20, so to see what thirty looks like -in base sixteen: % - -RADIX (20) ; THIRTY ; -% As you can see, the letters A, B, -... are used to represent the digits -ten, eleven, ... for bases exceeding -ten. Now can you guess why we limit -the base to thirty six? - - In input expressions, integers -beginning with a letter as the most -significant digit must begin with a -leading zero so as not to be -interpreted as a name. For example, in -base sixteen, ten is the letter-digit -A, so to return to base ten: % - -RADIX (0A) ; -% Why don't you now see what ninety- -nine raised to the ninety-nine power -looks like in base two and in base -thirty-six, then return to base ten: % -RDS: FALSE $ -% As you may have discovered, it is -easy to become confused and have a hard -time returning to base ten. Two is -represented as 2 in any base exceeding -1, so a foolproof way to get from any -base to any other is to first get to -base two, then express the desired new -base in base two. For example: % - -RADIX (2) ; RADIX (1010) ; -% Now we are guaranteeably in base -ten, no matter how badly you got lost. - - Now consider irrational -arithmetic: Did you know that - - (5 + 2*6^(1/2))^(1/2) - - 2^(1/2) - (3/2)^(1/2) - -can be simplified to 0, provided we -make certain reasonable choices of -branches for the square roots? In -general, simplification of arithmetic -expressions containing fractional -powers is quite difficult, but muMATH -makes a valiant attempt. For example: -% - -4 ^ (1/2) ; 12 ^ (1/2) ; 1000 ^ (1/2) ; -% Try simplifying the square roots -of increasingly large integers to gain -a feel for how the computation time -increases with the complexity of the -input and answer: % RDS: FALSE $ -% An input of the form (m/n)^(p/q) -is treated in the usual manner as -(m^(1/q))^p / (n^(1/q))^p . For -example: % - -(4/9) ^ (3/2) ; -% For geometrically similar people, -surface area increases as the 2/3 power -of the mass. Veronica wears a 1 -square-meter bikini, and she is 50,653 -grams, whereas her look-alike mother is -132,651 grams. Use muMATH to determine -the area of her mother's similar -bikini: % RDS: FALSE $ -% 4^(1/2) could simplify to either --2 or +2, but muMATH picks the positive -real branch if one exists. Otherwise, -muMATH picks the negative real branch -if one exists, as illustrated by the -example: % - -(-8) ^ (1/3) ; -% What if no real branch exits? -Then muMATH uses the unbound variable -named #I to represent the IMAGINARY -number (-1)^(1/2), and expresses the -answer in terms of #I, using the branch -having smallest positive argument. For -example: % - -(-4) ^ (1/2) ; -% Decent simplification of -expressions containing imaginary -numbers, as described in lesson -CLES4.ALG, requires that file -ALGEBRA.ARI be loaded. Meanwhile if -you believe in imaginary numbers and -you can't contain your curiosity, why -don't you experiment with them to see -what muMATH knows about them: % RDS: -FALSE $ -% As with manual computation, -picking a branch of a multiply-branched -function is hazardous, so answers -thereby obtained should be verified by -substitution into the original problem -or by physical reasoning. For this -reason, there is a CONTROL VARIABLE -named PBRCH, initially TRUE, which -suppresses Picking a BRanCH if FALSE. -For example: % - -PBRCH: FALSE $ 4 ^ (1/2); -% Users having a conservative -temperament might prefer to do most of -their computation with PBRCH FALSE. - - This brings us to the end of -CLES2.ARI. Though arithmetic, some of -the features illustrated in this lesson -may be foreign to you, because -sometimes they are taught during -algebra rather than before. Thus, if -you have any algebra background -whatsoever, we urge you to proceed to -lesson CLES3.ALG even if some of -CLES2.ARI was intimidating. Naturally, -as implied by its type, file CLES3.ALG -requires a muMATH system containing -files through ALGEBRA.ARI. - - If you decide not to proceed to -algebra, but want to learn how to -program using muSIMP, then proceed to -lesson PLES1.ARI. % - -ECHO: FALSE$ PBRCH: TRUE$ NEWLINE: 0$ -RDS ()$ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/CLES3.ALG b/software/CPM/CPM_MC_5/CLES3.ALG deleted file mode 100644 index af2efc1..0000000 --- a/software/CPM/CPM_MC_5/CLES3.ALG +++ /dev/null @@ -1,458 +0,0 @@ -%File: CLES3.ALG (c) 09/15/80 - The Soft Warehouse % - -LINELENGTH (39)$ NEWLINE: 1$ -NUMNUM: DENNUM: 6$ DENDEN: 2$ -NUMDEN: PWREXPD: 0$ PBRCH: TRUE$ -X: 'X$ ECHO: TRUE$ - -% This file is the third of a -sequence of interactive lessons on how -to use muMATH in the calculator mode. -This lesson presumes that the muMATH -files through ALGEBRA.ARI have been -loaded and that the user has studied -the arithmetic lessons CLES1.ARI and -CLES2.ARI. - - An UNBOUND VARIABLE is one to -which no value has been assigned. -Mathematicians call such variables -INDETERMINATES. You may have already -inadvertently discovered that if you -use an unbound variable in an -expression, muMATH treats the variable -as a legitimate algebraic unknown. -Moreover, muMATH attempts to simplify -expressions containing such unbound -variables by collecting similar terms -and similar factors, etc. For -example: % - -2*X - X^2/X ; -% See if muMATH automatically -simplifies the expressions - 0+Y, Y+0, 0*Y, Y*0, 1*Y, Y*1, - Y^1, 1^Y, and 2*(X+Y) - 2*X. % -RDS: FALSE $ -% Sometimes it is desirable to -change a bound variable back to -unbound status. This can be done by -using the single-quote prefix -operator, ', which looks like an -apostrophe on many terminals. For -example: % - -EG: X + 5; EG: 'EG; EG + 2; -% Try assigning the value M*C^2 -to E, then change E back to unbound -status: % RDS: FALSE $ -% You may have noticed that some of -the more drastic transformations, such -as expanding products or integer -powers of sums, are not automatic. -The reason is that such transfor- -mations are not always advantageous. -They may make an expression much -larger and less comprehensible. -However, they may be necessary in -order to permit cancellations which -make an expression smaller and more -comprehensible. - - Accordingly, there are a few -control variables whose values specify -whether or not such transformations -are performed. For example, the -variable controlling expansion of -integer powers of sums is called -PWREXPD. This variable is -conservatively initialized to zero, so -that integer powers of sums are not -expanded. For example: % - -EG: (X+1)^2 - (X^2-2*X-1) ; -% Clearly this is an instance where -expansion is desirable. When PWREXPD -is a positive integer multiple of 2, -then positive integer powers of sums -are expanded, so let's try it: % - -PWREXPD: 2 $ EG; -% Nothing happened! - - The reason is that muMATH does -not automatically reevaluate -previously evaluated expressions just -because we change a control value. -Not only would this be rather time -consuming, but the ability to form -expressions from other expressions -constructed under different control -settings provides a valuable -flexibility for constructing partially -expanded expressions. - - On the other hand, it is often -desirable to reevaluate expressions -under the influence of new control -settings, and the built-in EVAL -function enables this: % - -EVAL (EG) ; -% Now that PWREXPD is 2, see how -(X+Y)^2 - (X-Y)^2 simplifies: % -RDS: FALSE $ -% In muMATH, denominators are -represented internally as negative -powers, and negative integer powers of -sums are expanded if PWREXPD is a -positive integer multiple of 3. For -example: % - -PWREXPD: 3 $ 1 / (X+1)^2 ; -% What happens if - 1 / ((X+1)^2 - X)^2 -is evaluated under the influence of -PWREXPD being 3? For a little -surprise, try it.% RDS: FALSE $ -% Even though (X+1)^2 is WITHIN a -negative power, it is itself a -positive power, so how about trying -again with PWREXPD being 2*3: % -RDS: FALSE $ -% Now, we would like to suggest a -little experiment for you: The size -limitation on algebraic expressions -depends primarily upon the amount of -unemployed space available for storing -the data structure used to represent -algebraic expressions. We can always -determine the total amount of -unemployed space expressed in bytes by -the command: % - -RECLAIM (); -% Numbers and nodes which are no -longer a part of any value that we can -retrieve are automatically recycled -intermittently, but the RECLAIM -function forces this "garbage -collection" process. The collection -takes on the order of a second, -depending on memory size and processor -speed; and these slight pauses are -sometimes noticable in the middle of a -printout or a trivial computation. On -a computer with front panel lights, -the collections are also usually -recognizable by the change in light -patterns. - - Naturally, if we load an -extravagant number of muMATH files -into a single muMATH dialogue or if we -save a number of relatively large -expressions as the values of -variables, then there will be -relatively little unemployed space for -our next computation. Not only does -this limit the size of the next -expression, but computation time also -increases dramatically as space -becomes scarce, because relatively -more time becomes devoted to -increasingly frequent collections. -The moral of the story is: don't -unnecessarily load too many muMATH -files or retain numerous expressions -as the values of variables. - - Now, for the experiment: In -order to gain an appreciation for how -computation time depends on the size -of the input expression, answer, and -unemployed storage, try timing each -computation in the following sequence, -until it appears that your space or -patience is nearly exhausted: - - EG:(1+X)^2; RECLAIM(); - EG:EG^2; RECLAIM(); EG:EG^2; ... % - -RDS: FALSE $ -% These polynomials are called -"dense", because there are no missing -terms less than the maximum degree in -each unbound variable. In contrast -"sparse" polynomials are missing a -large percentage of the possible terms -less than the maximum degrees. If you -are still in an experimental mood, you -may wish to try the following -analogous sequence which produces -extremely sparse results: - RECLAIM(); (A+B)^2; RECLAIM(); - (A+B+C)^2; RECLAIM(); ... % - -RDS: FALSE $ -% Distribution of sums over sums is -another transformation which can -dramatically increase expression size -but is sometimes necessary to permit -cancellations. For example, this -transformation is clearly desirable in -the expression: % - -EG: X^2 - 1 - (X+1)*(X-1) ; -% When the control variable named -NUMNUM is a positive integer multiple -of 2, then integers in NUMerators are -distributed over sums in NUMerators. -Similarly when the variable is a -positive integer multiple of 3, then -monomials in numerators are -distributed over sums in numerators, -whereas when the variable is a -positive integer multiple of 5, then -sums in numerators are distributed -over sums in numerators. - - The reason for using the -successive primes 2, 3, and 5, is that -it provides a convenient way to -independently control the three types -of distribution using one easily -remembered control variable name. - - The initial value of NUMNUM is 6, -because numeric and monomial -distribution are recoverable (as we -shall see), because neither -distribution dramatically increases -expression size, and because a lack of -these distributions often prevents -annoyingly obvious cancellations. For -instance the expression 2*(X+1) - 2*X -will not simplify unless NUMNUM is a -positive multiple of 2. Similarly X+1 -- (X+1) will not simplify to 0, -since the expression is represented -internally as X+1 + -1*(X+1), which -requires the -1 to be distributed over -the sum. - - Thus, to return to our example, % - -EG; NUMNUM: 5 * NUMNUM; EVAL(EG) ; -% To witness the great variety of -possible expansions, we set % - -NUMNUM: 0 $ EG: 4 * X^3 * (1+X) * (1-X); -% Now, successively EVAL EG with -NUMNUM being 2, 3, 5, 6, 10, 15, and -30: % RDS: FALSE $ -% In interpreting these results, it -is important to recall that negations -are represented internally as a -product with the integer coefficient - -1, so NUMNUM must be a positive -multiple of 2 to distribute negations -over sums. - - If positive values of NUMNUM -cause expansion in numerators, how do -we request factoring in numerators? - - Negative values of NUMNUM cause -factoring of numerators. Moreover, the -specific negative values cause -factoring of the type which reverses -the corresponding expansion. For -example: % - -X: 'X $ Y: 'Y $ NUMNUM: -2 $ EG: 10*X^2*Y + 15*X^3; -NUMNUM: 3*NUMNUM; EVAL(EG); -% What about negative multiples of -5? Sorry folks, that's hard for -computers as well as humans. However, -we are working on it for future -releases. Meanwhile, try out our -semifactoring on the example - 3*X*Y^3/7 - 15*X*Y^2/14 + 9*X^4*Y^2/7 -% RDS: FALSE $ -% As you may have guessed, there is -a flag named DENDEN which controls -expansion and factoring among negative -powers in a manner entirely analogous -to NUMNUM. Use it together with -NUMNUM to expand the denominator then -semifactor the denominator of the -expression - X^2/((X-Y)*(X+Y) + Y^2 + X^2*Y) -% RDS: FALSE $ -% You may have wondered why we -chose the names NUMNUM and DENDEN. -The reason is that there is another -closely related control variable named -DENNUM, which controls the -distribution of various kinds of -denominator factors over the terms of -corresponding numerator factors: - - A positive multiple of 2 causes -integer denominator factors to be -distributed; a positive multiple of 3 -causes monomial factors to be -distributed; and a positive multiple -of 5 causes sum factors to be -distributed. For example: % - -Y: 'Y $ DENNUM: DENDEN: NUMNUM: 0 $ EG: (5+3*X^2) / (15*X*(4+X)); -DENNUM: 2 $ EVAL(EG); -DENNUM: 3*DENNUM; EVAL(EG); -DENNUM: 5*DENNUM; EVAL(EG); -% Positive setting of DENNUM and -NUMNUM are particularly useful for -work with truncated series or partial -fraction expansions. For example, see -if you can put the expression (6 + 6*X -+ 3*X^2 + X^3)/6 into a more -attractive form: % RDS: FALSE $ -% What about negative values of -DENNUM? - - A little reflection confirms that -forming a common denominator reverses -the effect of distributing a -denominator. Thus, expressions are -put over a common integer denominator -when DENNUM is a negative integer -multiple of 2, expressions are put -over a common monomial denominator -when DENNUM is a negative integer -multiple of 3, and expressions are put -over a common sum denominator when -DENNUM is a negative integer multiple -of 5. For example: % - -X: 'X $ DENNUM: DENDEN: 0 $ EG: 1 + X/3 + (1+X)/X + (1-X)/(1+X); -DENNUM: -2 $ EG: EVAL(EG); -DENNUM: 3*DENNUM; EG: EVAL(EG); -DENNUM: 5*DENNUM; EG: EVAL(EG); -% Try fully simplifying the -expression X^4/(X^3+X^2) + 1/(X+1) - -1 by expanding over a common -denominator, then factoring: % RDS: -FALSE $ -% As with NUMNUM and DENDEN, the -initial setting of DENNUM is 6, which -causes distribution of numeric and -monomial denominator factors over -numerator sums. This tends to give -attractive results for polynomials or -series with rational-number -coefficients, but the relatively -costly common-denominator operation -may be necessary for problems -involving ratios of polynomials. - - You have now been exposed to the -four most important algebraic control -variables in muMATH. Together with -EVAL, the various combinations of -settings of these variables give -rather fine control over the form of -algebraic expressions. muMATH cannot -read the user's mind, so it is -important for the user to thoroughly -master the use of these variables in -order to achieve the desired effects. - - Here are the most frequently -useful combinations of settings for -these three variables: - -PWREXPD: 0; NUMNUM: DENDEN: DENNUM: 6; - - These initial values are usually -good for general-purpose work, when -the user wants to view some results -before doing anything drastic or -potentially quite time consuming. - - PWREXPD: 6; NUMNUM: DENDEN: 30; - DENNUM: -30; - - These settings yield a fully -expanded numerator over a fully -expanded common denominator. This -form gives the maximum chance for -combination of similar terms. -Moreover, a rational function -equivalent to 0 is guaranteed to -simplify to 0. However, valuable -factoring information may be -irrecoverably lost. - - PWREXPD: 0; NUMNUM: DENDEN: -6; - DENNUM: -30; - - These settings yield a -semifactored numerator over a semi- -factored common denominator. This -form gives the maximum chance for -cancellation of factors between a -numerator and denominator. However, -the factoring is done incrementally, -term by term, so it may be necessary -to first expand over a common -denominator so that all cancellable -terms have an opportunity to cancel -before attempting factorization. - - PWREXPD: 2; NUMNUM: 30; - DENDEN: -6; DENNUM: -30; - - These settings are a good -compromise between the advantages of -expansion and factoring. Semi- -factoring is done in the denominator -where it is usually most important, -but there is a maximum opportunity for -combination of similar terms in the -numerator. - -PWREXPD:6; NUMNUM: DENDEN: DENNUM: 30; - - These settings are good for series -expansions or partial fractions, -because each term is fully expanded -over its own denominator. - - Again, we can't overemphasize the -importance of mastering the use of -these four control variables. They -are your primary tool for imposing -your will on the simplification -process, and any lack of understanding -of their proper use will ultimately -lead to frustration. Accordingly, why -don't you try the above and various -other combinations on examples of your -own choosing, until the usage becomes -second nature: % -RDS: FALSE $ -% Congratulations on completing -CLES3.ALG. If the mathematical level -was uncomfortably high, proceed to -lesson PLES1.ARI. Otherwise proceed -to CLES4.ALG. In either event, it is -advisable to initiate a fresh muMATH -environment, because our experiments -have altered control values and made -assignments which could interfere with -those lessons in nefarious ways. % - -ECHO: FALSE$ NEWLINE: 0$ RDS ()$ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/CLES4.ALG b/software/CPM/CPM_MC_5/CLES4.ALG deleted file mode 100644 index 5b16469..0000000 --- a/software/CPM/CPM_MC_5/CLES4.ALG +++ /dev/null @@ -1,275 +0,0 @@ -%File: CLES4.ALG (c) 10/30/79 - The Soft Warehouse % - - -LINELENGTH (39)$ NEWLINE: 1$ ECHO: TRUE$ - -% This is the fourth of a sequence of -muMATH calculator-mode lessons. - - There are some other algebraic -control variables besides PWREXPD, -NUMNUM, DENDEN, and DENNUM; and they -are occasionally crucial for achieving -a desired effect. One of these, named -NUMDEN, provides the logical completion -of the latter three, by controlling the -distribution of factors in numerators -over the terms of denominator sums. -NUMDEN is initially 0, but integer -numerators are distributed over -denominator sums when NUMDEN is a -positive integer multiple of 2, -monomial numerators are distributed -over denominator sums when NUMDEN is a -positive integer multiple of 3, and -numerator sums are distributed over -denominator sums when NUMDEN is a -positive integer multiple of 5. For -example: % - -NUMNUM: DENDEN: DENNUM: 0 $ NUMDEN: 30 $ -X / (X^3 + X + 1) / (Y + 1) ; EG: (X+Y) / (1+X+Y) / (Y+1) ; -% Isn't that intriguing? It yields a -sort of "continued-fraction" -representation. Now for the reverse -direction, which performs a denesting -of denominators which is less drastic -than a single common denominator: % - -NUMDEN: -6 $ Z + 1 / (1/X + 1/Y) / (1+Y) ; -% See if you can devise examples -exhibiting dramatic simplifications -arising from either direction for this -novel transformation. The fact that it -so naturally complements NUMNUM, -DENDEN, and DENNUM suggests that it -must be useful for something! % RDS: -FALSE $ -% Another control variable named -BASEXP controls distribution of a BASe -over terms in an EXPonent which is a -sum, or controls the reverse process -which is collection of similar factors. -As might be expected, integer bases are -distributed over exponent sums when -BASEXP is a positive integer multiple -of 2, monomial bases are distributed -over exponent sums when BASEXP is a -positive integer multiple of 3, and -base sums are distributed over exponent -sums when BASEXP is a positive integer -multiple of 5. Morever, the -corresponding negative values cause -collection of similar factors having -the corresponding types of bases. -BASEXP is initially -30. However, -distribution (followed perhaps by -collection) is sometimes necessary to -let some of the terms in an exponent -sum combine with the base. For -example: % - -EG: 2^(2+X) / 4 ; BASEXP: 2 ; EVAL (EG) ; -% See if you can devise an example -which requires evaluating an expression -first with sufficiently positive -BASEXP, then reevaluating with -sufficiently negative BASEXP, or vice- -versa: % RDS: FALSE $ -% Another control variable named -EXPBAS controls the distribution of -EXPonents over BASes which are -PRODUCTS. Integer exponents are -distributed over base products when -EXPBAS is a positive integer multiple -of 2, monomial exponents are -distributed over base products when -EXPBAS is a positive integer multiple -of 3, and exponent sums are distributed -over base products when EXPBAS is a -positive integer multiple of 5. -Naturally, the corresponding negative -multiples request collection of bases -which have similar exponents of the -indicated type. The initial value is -30, and here are some examples where -distribution permits net -simplification: % - -(X^(1/2) * Y) ^ 2 ; (X*Y)^2 - X^2*Y^2 ; (4*X^2*Y) ^ (1/2) ; -% However, the user should beware -that as with manual computation, -distribution of noninteger exponents is -not always valid. Consequently, -conservative users may prefer to -generally operate with EXPBAS being 2. -Moreover, distribution of exponents -tends to make expressions more bulky -when no cancellations occur. For -example % - -(X * Y * Z) ^ (1/2) ; -% In fact, there are instances where -negative settings of EXPBAS are -necessary to acheive a desired result. -For example: % - -EG: 2^X * 3^X + (1+X)^(1/2) * (1-X)^(1/2) - (1-X^2)^(1/2) ; -EXPBAS: -6 ; NUMNUM: 30 ; EVAL (EG) ; -% See if you can devise an example -which requires evaluating an expression -first with sufficiently positive -EXPBAS, then reevaluating with -sufficiently negative EXPBAS, or vice- -versa, in order to simplify acceptably: -% RDS: FALSE $ -% The variable named PBRCH, already -discussed in conjunction with -fractional powers of numbers, also -controls transformations of the form -u^v^w --> u^(v*w). PBRCH is initially -TRUE, but when PBRCH is FALSE, the -transformation occurs only for integer -w. Otherwise the transformation occurs -for any w. The user should be aware -that in some circumstances the selected -branch is an inappropriate one, so that -it may sometimes be necessary to set -PBRCH to FALSE. See if you can devise -such an instance: % RDS: FALSE $ -% Now, try the examples 0^X and X^0, -to see what happens: % -RDS: FALSE $ -% The reason that 0^X is not -automatically simplified to 0 is that -0^X is undefined for nonpositive values -of X, so the transformation could lead -to invalid results. Of course, -sometimes users know that the exponent -is positive, or they are willing to -assume it is positive and verify the -result afterwards. Consequently, there -is a control variable named ZEROBAS, -initially FALSE, which permits the -transformation when nonFALSE. - - Why then do we automatically -simplify X^0 to 1 even though X could -perhaps take on the value 0, giving the -undefined form 0^0? Well, we also have -a control variable for that, named -ZEROEXP of course, but we initialized -it to TRUE because: - - 1. If we are thinking of -polynomials in X rather than any one -specific value of X, then we are free -to regard the polynomial X^0 as being -formally equivalent to 1. - - 2. One cannot do effective -simplification of rational functions -without this widely accepted -transformation. - - 3. Since 1 is the limit of X^0 as -X approaches 0 from either side of the -real axis, 1 is a reasonable -interpretation even for 0^0. - - Nevertheless, there is room for -disagreement, and anyone who wishes is -free to run with ZEROEXP FALSE. Why -don't you try it, using some rational -expression examples, in order to see -how you feel about this issue? % RDS: -FALSE $ -% It is easy to forget the current -control-variable settings, and it is -even easy to forget the existence of -certain control-variables, so we have -provided a handy-dandy function named -FLAGS which returns the empty name "" -after printing a display of all the -flags and their values: % - -FLAGS (); -% If you ever get frustrated because -you can't get an answer close to the -desired form, try this command. It may -reveal some inappropriate settings or -remind you of some alternatives you -forgot, or reveal the existence of -potentially relevant flags of which you -were unaware. - - Often a dialogue proceeds best -under some control settings which are -suitable for the majority of the -computations, with an occasional need -for an evaluation under different -control settings. Each such exception -could involve new assignments to -several control variables, followed by -an evaluation then assignments to -restore the variables to their usual -values. This process can become -tedious, and baffling effects can -result from inadvertently forgetting to -restore a control variable to its usual -value. Consequently, as a convenience, -we have provided some functions which, -for the most commonly desired sets of -"drastic" control values, establishes -these values, reevaluates its argument, -then allows the control variables to -revert to their former values before -returning the reevaluated argument. - - One of these functions is called -EXPAND, because it requests full -expansion with fully distributed -denominators, bases, and exponents. -More specifically, it uses the -following settings: - - PWREXPD: 6; NUMDEN: 0; -NUMNUM:DENDEN:DENNUM:BASEXP:EXPBAS: 30; - - To see its effect, try EXPAND -(((1+X)/(1-X))^2); % RDS: FALSE $ -% Another one of these convenience -functions is called EXPD, and it fully -expands over a common denominator. -Thus the internal control settings are -the same as for EXPAND, except that -DENNUM: -30. Try - EXPD (1/(X+1) + (X+1)^2); % -RDS: FALSE $ -% Finally, there is a convenience -function named FCTR, and it semi- -factors over a common denominator. It -evaluates its argument under the -following control-variable settings: - - NUMNUM: DENDEN: -6; - DENNUM: BASEXP: EXPBAS: -30; - PWREXPD: NUMDEN: 0; - - Since semi-factoring is done -termwise, it may be necessary to use -EXPD before applying FCTR to an -expression, in order to get the desired -result. See if you can devise an -instance where this is true: % -RDS: FALSE $ -% This brings us to the end of lesson -CLES4.ALG. The next lesson is -CLES5.ALG, but as before, it is -advisable to start a fresh muMATH to -avoid conflicts with bindings -established in the current lesson. % - -ECHO: FALSE$ NEWLINE: 0$ RDS ()$ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/CLES5.ALG b/software/CPM/CPM_MC_5/CLES5.ALG deleted file mode 100644 index d939bd3..0000000 --- a/software/CPM/CPM_MC_5/CLES5.ALG +++ /dev/null @@ -1,349 +0,0 @@ -%File: CLES5.ALG (c) 10/30/79 - The Soft Warehouse % - - -LINELENGTH (39)$ NEWLINE: 1$ ECHO: TRUE$ - -% It is often desired to extract -parts of an expression. Particularly -frequent is a need to extract the -numerator or denominator of an -expression. Accordingly, there are -built-in SELECTOR functions named NUM -and DEN for this purpose: % - -DENNUM: 0 $ EG: (1+X) / X ; NUM (EG) ; DEN (EG) ; -NUM (1 + EG); DEN (1 + EG); -% As the last two examples -illustrate, NUM and DEN do not force a -common denominator or any other -transformation before selection, so the -denominator is always 1 when the -expression is a sum or when the -expression is a product having no -negative powers. Try out NUM and DEN -on a few examples of your own to gain -some experience: % RDS: FALSE $ -% The Programming-mode lessons will -explain how to completely dismantle an -expression to get at any desired part, -such as a specific term, coefficient, -base, or exponent. - - muMATH represents the imaginary -number (-1)^(1/2) as #I, and muMATH -does appropriate simplification of -integer powers of #I. For example: % - -#I ^ 7 ; EXPAND ((3 + #I) * (1 + 2*#I)) ; EXPAND ((X + #I*Y) ^ 3) ; -% Try it, you'll like it! % -RDS: FALSE $ -% The definition of the operator "^" -in file ALGEBRA.ARI also implements two -higher-level transformations which we -mention here only in passing: - - muMATH represents the base of the -natural logarithms as #E and the ratio -of the circumference to the diameter of -a circle as #PI. Using these, muMATH -performs the simplification - - #E ^ (n * #I * #PI / 2) --> #I^n, - -where n is any integer constant, after -which the power of #I is reduced -appropriately. Also, if a control -variable called TRGEXPD is a negative -multiple of 7, then complex -exponentials are converted to -trigonometric equivalents. (The -opposite transformation for sines and -cosines to complex exponentials for -TRGEXPD = 7, is implemented by file -TRGPOS.ALG.) If your mathematical -background includes these facts, you -might wish to experience them here. -Otherwise you can safely ignore this -digression: % RDS: FALSE $ -% You may have wondered whether or -not an assignment to a variable, say X, -automatically updates the value of a -bound variable, say EG, which was -previously assigned an expression -containing X. Let's see: % - -X: 5 $ Y: 'Y $ EG: X + Y ; X: 3 ; EG; EVAL (EG) ; -% Apparently the answer is "no", at -least if X is bound when the assignment -to EG is made. This should not be -surprising, because after contributing -its value to the expression X + Y, all -traces of the name X are absent from -this expression. However, suppose that -we do a similar calculation wherein X -is initially unbound: % - -X: 'X $ EG: X + Y; X: 3; EG; -% As when we change control -variables, previously evaluated -expressions are not automatically -reevaluated when we bind an unbound -varible therein. However, we can -always use EVAL to force such a -reevaluation: % - -EVAL (EG) ; -% Since we did not assign the result -to EG, reevaluation of EG after a -different assignment to X still has an -effect: % - -X: 7 $ EG: EVAL (EG); -% Since this time we did assign the -result to EG, further changes to X can -have no effect on EG regardless of -evaluation: % - -X: 9 $ EG: EVAL (EG) ; -% If these examples are not entirely -clear, you had better take the time to -experimentally learn the principles by -trying some examples of your own: % -RDS: FALSE $ -% It is often desired to reevaluate -an expression under the influence of a -temporary local assignment to one of -the variables therein without -disturbing either the existing value of -the variable or else its unbound -status. The built-in EVSUB function -provides a convenient method of -accomplishing this effect. EVSUB -returns a reevaluated copy of its first -argument, wherein every instance of its -second argument is replaced by its -third argument. For example: % - -NUMNUM: 6 $ M: 'M $ C: 'C $ V: 'V $ EG: M*C^2 + M*V^2/2 $ -EVSUB (EG, M, 5); EVSUB (EG, M, M1+M2); M; -% Play around with EVSUB for awhile -until you are absolutely sure that you -understand the difference between -substitution and assignment: % RDS: -FALSE $ -% You may have discovered that EVSUB -also permits substitution for arbitrary -subexpressions as its second argument. -For example: % - -M: 'M $ C: 'C $ E: 'E $ EVSUB (M*C^2 + 7, M*C^2, E); -% To keep the algebra package small, -we have not endowed EVSUB with any -sophistication about finding -algebraically IMPLICIT instances of its -second argument in its first. See if -you can find examples where EVSUB does -not do a substitution that you would -like it to do: % RDS: FALSE $ -% Here is an example where a desired -substitution doesn't fully occur:% - -NUMNUM: 6 $ C: 'C $ S: 'S $ EVSUB (1 - 2*S^2 + S^4, S^2, 1-C^2); -% The reason we did not get the -desired simplification to C^4 is that -if the second argument is a power, it -matches only the same power in the -first argument. We can usually -circumvent such problems by instead -using an equivalent substitution -wherein the second argument is a name -rather than a power. For example: % - -PWREXPD: 2 $ EVSUB (1 - 2*S^2 + S^4, S, (1-C^2)^(1/2)); -% Here is a somewhat different -example wherein a desired substitution -does not occur: % - -EVSUB (2*C*S, C*S, C2); -% The reason is that if the second -argument is a product, it matches only -the same COMPLETE product in the first -argument. Again, the remedy is to use -an equivalent substitution wherein the -second argument is a name. For -example: % - -EVSUB (2*C*S, C, C2/S); -% Here is a final example for which a -desired substitution does not occur: % - -EVSUB (C^2+S^2-1+C+S, C^2+S^2, 1); -% Similarly to products, if the -second argument is a sum, it matches -only the same COMPLETE sum in the first -argument. As before, we could -circumvent the difficulty by making an -equivalent substitution of - (1-C^2) ^ (1/2) for S, - or (1-S^2) ^ (1/2) for C, -but that would leave an ugly square -root in the answer. If our goal is to -delete the subexpression -C^2 + S^2 - 1, then we can use to our -advantage the fact that powers must -match exactly for a substitution to -take place: % - -EVSUB (C^2+S^2-1+C+S, C^2, 1-S^2) ; -% See now if you can use such -techniques to get your examples to -work: % RDS: FALSE $ -% This brings us to the end of the -calculator-mode lessons. There are, of -course, higher-level math packages in -muMATH, but the fact is that from a -usage standpoint, we have already -covered the hardest part, which is -understanding evaluation, substitution, -and the ramifications of the various -algebraic control variables. You will -find that if you know the relevant -math, use of the higher-level packages -is quite straightforward, easily -learned from studying the corresponding -DOC files. - - We suggest that before commencing -the Programming-mode lessons, you -explore calculator-mode usage of the -higher-level packages as far as your -math background permits. Math -curriculum sequences differ, but -probably most users will be most -comfortable trying the higher-level -packaes in the approximate order EQN, -SOLVE, ARRAY, MATRIX, LOG, TRGNEG, -TRGPOS, DIF, INT and INTMORE. Since -space becomes increasingly scarce as -higher-level packages are loaded, you -may have to reread file READ1ST.TXT to -learn how to CONDENSE and SAVE if you -haven't already. - - Now for some parting advice about -getting the most out of computer -symbolic math: - - First, storage and time -consumption tends to grow dramatically -with the number of variables in the -input expressions, even if the ultimate -result is fortuitously compact. For -example, the number of terms in the -expanded form of - - (X1 + X2 + ... + XM) ^ N - -grows outrageously with M and N. -Consequently, it is important to make -every effort to avoid needlessly -introducing extra variables for -generality's sake. Mathematical and -physical problems are often stated -using more variables than are strictly -necessary, so it is also important to -exploit every opportunity to reduce the -number of variables from the original -problem. Here are some general -techniques for doing this: - - 1. If members of a set of -variables can be made to occur only -together as instances of a certain -subexpression, consider replacing the -subexpression with a single variable. -For example: - - a) If K, X, and X0 can be made to - occur only as instances of the - subexpression K*(X-X0), then - consider replacing this - subexpression with a variable - named perhaps KDX. - - b) Similarly, perhaps a - combination such as M*C^2 could be - replaced with E, or RHO*V^2/L - could be replaced with RE. - - These are respectively instances - of absorbing an offset together - with a proportionality - coefficient, renaming a - physically-meaningful - subexpression, and grouping - quantities into dimensionless - quantities. Most engineering and - science libraries have books - describing a more systematic - technique called DIMENSIONAL - ANALYSIS, and an article in the - Journal of Computational Physics - (June 1977) explains how computer - algebra can automate the process. - - 2. Even when a variable cannot be -eliminated, the complexity of -expressions may be reduced if the -variable can be made to occur only as -instances of a subexpression. For -example: - - a) If only even powers of a - variable X occur, consider - replacing X^2 with a variable - named perhaps XSQ. - - b) If X only occurs as instances - of 2^X, 2^(2*X), 2^(3*X),..., - consider replacing 2^X with a - variable named perhaps TWOTOX, - yielding mere integer powers of - that variable. - - Some other advice is to avoid -fractional powers and denominators as -much as possible. They don't simplify -well, they consume a lot of space, and -they tend to be hard to decipher when -printed one- dimensionally. Often a -change in variable can eliminate a -fractional power or a denominator. - - Sometimes, even when a problem -cannot be solved in its full -generality, solving a few special cases -enables one to infer a general solution -which can perhaps then be verified by -substitution or by induction. -Alternatively, perhaps the original -problem can be simplified by neglecting -some lower-order contributions, in -order to get an analytic solution which -will at least convey some qualitative -information about the solution to the -original problem. - - Sometimes only part of a problem or -perhaps even none can be solved -symbolically, and the rest must be -solved numerically. If so, the attempt -at an analytic solution at least allows -one to proceed with an approximate -numerical solution having more -confidence that a concise analytical -solution has not been overlooked. % - -ECHO: FALSE$ NEWLINE: 0$ RDS ()$ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/CONTINUE.COM b/software/CPM/CPM_MC_5/CONTINUE.COM deleted file mode 100644 index b9aced4..0000000 Binary files a/software/CPM/CPM_MC_5/CONTINUE.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_5/CUBIC.MU b/software/CPM/CPM_MC_5/CUBIC.MU deleted file mode 100644 index 95bac9d..0000000 Binary files a/software/CPM/CPM_MC_5/CUBIC.MU and /dev/null differ diff --git a/software/CPM/CPM_MC_5/DEMO.ALL b/software/CPM/CPM_MC_5/DEMO.ALL deleted file mode 100644 index 92150a2..0000000 --- a/software/CPM/CPM_MC_5/DEMO.ALL +++ /dev/null @@ -1,190 +0,0 @@ -% File: DEMO.INT (c) 10/07/81 The Soft Warehouse % - -ECHO: FALSE $ -NEWLINE: 1 $ -DENNUM: -30$ -A: 'A$ -B: 'B$ -POINT: FALSE$ -NUMNUM: LOGEXPD: 30$ -DENDEN: 2$ -PWREXPD: 6$ -TRGEXPD: -15$ -MOVD ('NEWLINE, 'CRLF)$ -FUNCTION NEWLINE (EX1, EX2), - CRLF (EX1), - BLOCK - WHEN INTEGER (PAUSE) EXIT, - PAUSE: 10 - ENDBLOCK, - EX2: PAUSE, - LOOP - WHEN NOT POSITIVE (EX2) EXIT, - 1000*1000, - EX2: EX2-1 - ENDLOOP -ENDFUN$ - -ECHO: TRUE$ -% -Use CTRL-S to start and stop the -scrolling of this demostration file. - -The length of the momentary pause -between problems is controlled by the -size of the variable PAUSE. The -default value of PAUSE is 10. - -This demo requires the following -muMATH files be loaded: - EQN.ALG LOG.ALG - TRGNEG.ALG DIF.ALG - INT.DIF -% - -%*** INTEGER ARITHMETIC EXAMPLES ***% - -% INTEGER ADDITION & SUBTRACTION % - -32 + 15 - 24;% MULTIPLICATION & UNARY MINUS % - -5 * -12;% USE OF PARENTHESIS % - -436 * (123 - 57);% RAISING TO A POWER % - -100^3;% ASSIGNMENTS TO A VARIABLE % - -FOO: (3*8 - 16)^2;% USE OF ASSIGNED VARIABLE % - -3*FOO^5;% SAVE INTERMEDIATE RESULTS % - -SEC#PER#YR: 365*24*3600;IN#PER#MI: 5280*12;% USE OF INTERMEDIATE RESULTS % -% TO FIND INCHES TO ALHPA CENTAURI % - -4 * 186000 * SEC#PER#YR * IN#PER#MI;% EXACT, INFINITE PRECISION % - -99^99; -%*** RATIONAL ARITHMETIC EXAMPLES ***% - -% REDUCE FRACTIONS TO LOWEST TERMS % - -56/77;% FIND COMMON DENOMINATOR % - -5/6 - 3/4;% RATIONAL SIMPLIFICATION % - -3 * (1/2 + 1/6);% FLOATING POINT NOTATION % - -POINT: 10$1/3; -%*** VARIABLE RADIX BASE ***% - -% SET FOR HEXADECIMAL ARITHMETIC % - -RADIX (16);% USE AS A HEX CALCULATOR % - -7C80 - 2*12EF + 0A3C;% ASSIGNMENT TO A VARIABLE % - -EG: 10000;% RETURN TO BASE TEN ARITHMETIC % - -RADIX (0A);% FIND EG IN BASE TEN % - -EG;% BASE TWO ARITHMETIC % - -RADIX (2);% BINARY ARITHMETIC CALCULATOR % - -101101110 * EG;% RETURN TO BASE TEN ARITHMETIC % - -RADIX (1010); -%*** EXPONENTIAL SIMPLIFICATIONS ***% - -% FRACTIONAL POWERS % -8 ^ (2/3);12 ^ (1/2);% POWERS OF THE IMAGINARY NUMBER % - -#I^2;#I^-7;% COMPLEX EXPONENTIALS % - -#E ^ (#I*#PI); -%*** FACTORIALS ***% - -5!;50!^2;% BINOMIAL COEFFICIENTS [12:30] % - -N: 30;M: 12;N! / ((N-M)!*M!); -%*** BASIC ALGEBRA EXAMPLES ***% - -% AUTOMATIC ALGEBRAIC SIMPLIFICATION % - -% COMBINES SIMILAR TERMS AND FACTORS % - -3*X - X;Y^3 * Y^(R+1); -% EXPLOITS IDENTITIES AND ZEROS % - -0 + X;1 * Y;Z * 0;X^1;Y^0;1^X;% MULTIPLE SIMPLIFICATIONS % - -5*X^1*Y + Y^2*-3*X/Y + W^(Z^2 - Z*Z);% POLYNOMIAL MULTIPLICATION % - -(3*X - 2*Y) * (Y^2 + 4*X);% POLYNOMIAL POWERS % - -(X+1)^2;(X+5) * (X^2-2*X+3)^2;% CONTENT FACTORIZATION % - -FCTR (6*X^3*Y + 15*X^2*Y); -%*** LOGARITHMIC SIMPLIFICATIONS ***% - -% NATURAL LOG OF ONE % - -LN (1);% COMMON LOG OF 1000 % - -LOG (1000, 10);% EXPAND THE LOG OF A PRODUCT % - -LN (X*Y);% EXPAND THE LOG OF A POWER % - -LOG (Z^3, 10);% MULTIPLE SIMPLIFICATIONS % - -LN(X^2*Y) - 2*LN(X);% INTER-BASE SIMPLIFICATIONS % - -LOG(X,10) * LOG(10,#E);% LOGARITHMIC POWERS % - -#E ^ LN(X+5); -%*** TRIGONOMETRIC SIMPLIFICATIONS ***% - -% ELEMENTARY ANGLE VALUES % - -COS (0);SIN (#PI/2);SIN (37*#PI/3);% EQUIVALENT FUNCTIONS % - -TAN(X) * COS(X);% MULTIPLE ANGLES EXPANSION % - -SIN (2*X);COS(3*X);% ANGLE SUMS EXPANSION % - -COS (X-Y);% COMBINATION EXPANSIONS % - -EG: SIN (2*X+Y); -%*** REPRESENT EQUATIONS ***% - -EQN: 2*X+7 == A^2 - X^2/X - 3;% STEP BY STEP SOLUTION FOR X % - -EQN: EQN + X - 7;EQN: EQN/3; -%*** CALCULUS OPERATIONS ***% - -% FIND DERIVATIVES % - -DIF (3*X^2 + 5*X - 4, X);DIF (LN(X)^2, X);DIF (#E^X^2, X);DIF (P*SIN(X) + X^2, X);% FIND INTEGRALS % - -INT (2*X - 1/X, X);INT (X * #E^X^2 * SIN(#E^X^2), X);INT (LN(LN(X))/X, X); -%*** PROGRAMMING IN MUSIMP ***% - -% TAYLOR SERIES EXPANSION FUNCTION % - -FUNCTION TAYLOR (EXPN, X, A, N, -% Locals: % J, C, ANS, NUMNUM, DENNUM), - NUMNUM: DENNUM: 30, - J: ANS: 0, - C: 1, - LOOP - ANS: ANS + C * EVSUB (EXPN, X, A), - WHEN J=N, ANS EXIT, - EXPN: DIF (EXPN, X), - J: J + 1, - C: C * (X-A) / J, - ENDLOOP, -ENDFUN ;% TAYLOR SERIES EXPANSION % - -TAYLOR (#E^X, X, 0, 6);TAYLOR (SIN(X), X, 0, 8);TAYLOR (#E^SIN(X), X, 0, 4); -MOVD ('CRLF, 'NEWLINE)$ RDS ()$ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/DIF.ALG b/software/CPM/CPM_MC_5/DIF.ALG deleted file mode 100644 index 9a8b53b..0000000 --- a/software/CPM/CPM_MC_5/DIF.ALG +++ /dev/null @@ -1,106 +0,0 @@ -% File DIF.ALG (c) 03/26/81 The Soft Warehouse % - - -FUNCTION DIF (EX1, INDET), - WHEN EX1=INDET, 1 EXIT, - WHEN ATOM(EX1), 0 EXIT, - WHEN APPLY (GET(DIF,FIRST(EX1)), ARGEX(EX1)) EXIT, - WHEN FREE(EX1,INDET), 0 EXIT, - LIST ('DIF, EX1, INDET), -ENDFUN $ - -PROPERTY DIF, DEFINT, FUNCTION (EX1, EX2, EX3, EX4), - EX4: THIRD(EX2:REST(EX2)), - EX3: SECOND(EX2), - DEFINT (DIF(EX1,INDET), EX2:FIRST(EX2), EX3, EX4) - + DIF(EX4,INDET) * EVSUB(EX1,EX2,EX4) - - DIF(EX3,INDET) * EVSUB(EX1,EX3,EX3), -ENDFUN $ - -PROPERTY DIF, INT, FUNCTION (EX1, EX2), - WHEN INDET=EX2, EX1 EXIT, - INT(DIF(EX1,INDET),EX2), -ENDFUN $ - -MINUSHALF: -1/2 $ - -PROPERTY DIF, ERF, FUNCTION (EX1), - 2 * #PI^MINUSHALF * #E^-(EX1^2) * DIF(EX1,INDET), -ENDFUN $ - -PROPERTY DIF, ACSC, FUNCTION (EX1), - -(EX1^-1) * (EX1^2-1)^MINUSHALF * DIF(EX1,INDET), -ENDFUN $ - -PROPERTY DIF, ASEC, FUNCTION (EX1), - EX1^-1 * (EX1^2-1)^MINUSHALF * DIF(EX1,INDET), -ENDFUN $ - -PROPERTY DIF, ACOT, FUNCTION (EX1), - -(1+EX1^2)^-1 * DIF(EX1,INDET), -ENDFUN $ - -PROPERTY DIF, ACOS, FUNCTION (EX1), - -(1-EX1^2)^MINUSHALF * DIF(EX1,INDET), -ENDFUN $ - -PROPERTY DIF, ASIN, FUNCTION (EX1), - (1-EX1^2)^MINUSHALF * DIF(EX1,INDET), -ENDFUN $ - -PROPERTY DIF, ATAN, FUNCTION (EX1), - (1+EX1^2)^-1 * DIF(EX1,INDET), -ENDFUN $ - -PROPERTY DIF, CSC FUNCTION (EX1), - -COT(EX1) * CSC(EX1) * DIF(EX1,INDET), -ENDFUN $ - -PROPERTY DIF, SEC FUNCTION (EX1), - TAN(EX1) * SEC(EX1) * DIF(EX1,INDET), - -ENDFUN $ - -PROPERTY DIF, COT, FUNCTION (EX1), - -CSC(EX1)^2 * DIF(EX1,INDET), -ENDFUN $ - -PROPERTY DIF, TAN, FUNCTION (EX1), - SEC(EX1)^2 * DIF(EX1,INDET), -ENDFUN $ - -PROPERTY DIF, COS, FUNCTION (EX1), - -SIN(EX1) * DIF(EX1,INDET), - -ENDFUN $ - -PROPERTY DIF, SIN, FUNCTION (EX1), - COS(EX1) * DIF(EX1,INDET), -ENDFUN $ - -PROPERTY DIF, LOG, FUNCTION (EX1, EX2), - WHEN EX2 EQ #E, DIF(EX1,INDET) / EX1 EXIT, - DIF (LOG(EX1,#E)/LOG(EX2,#E), INDET), -ENDFUN $ - -PROPERTY DIF, ^, FUNCTION (EX1, EX2), - EX1^EX2 * (LOG(EX1,#E)*DIF(EX2,INDET) + EX2*DIF(EX1,INDET)/EX1), -ENDFUN $ - -PROPERTY DIF, *, FUNCTION (EX1, EX2), - EX1*DIF(EX2,INDET) + EX2*DIF(EX1,INDET), -ENDFUN $ - -PROPERTY DIF, +, FUNCTION (EX1, EX2), - EX1: DIF(EX1,INDET), - WHEN SUM (EX2), - POP (EX2), - LOOP - EX1: EX1 + DIF(POP(EX2),INDET), - WHEN EMPTY (EX2), EX1 EXIT, - ENDLOOP EXIT, - EX1 + DIF(EX2,INDET), -ENDFUN $ - -RDS() $ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/EQN.ALG b/software/CPM/CPM_MC_5/EQN.ALG deleted file mode 100644 index c651b12..0000000 --- a/software/CPM/CPM_MC_5/EQN.ALG +++ /dev/null @@ -1,59 +0,0 @@ -% File EQN.ALG (c) 04/21/81 The Soft Warehouse % - - -FUNCTION MAPFUN (LOP1, LEX1), - WHEN ATOM(LEX1), FALSE EXIT, - ADJOIN (LOP1(POP(LEX1)), MAPFUN(LOP1,LEX1)), -ENDFUN $ - -FUNCTION SIMPU (LOP1, EX1), - WHEN NAME(EX1), LIST(LOP1,EX1) EXIT, - WHEN APPLY (GET(LOP1,FIRST(EX1)), ARGEX(EX1)) EXIT, - WHEN MEMBER (FIRST(EX1), '("==" [ {)), - ADJOIN (POP(EX1), MAPFUN(LOP1,EX1)) EXIT, - LIST (LOP1, EX1), -ENDFUN $ - -PROPERTY RBP, "==", 80 $ -PROPERTY LBP, "==", 80 $ - -PROPERTY +, "==", FUNCTION (EX1, EX2, EX3), - WHEN FIRST(EX1) = '"==", - SECOND(EX1) + EX2 "==" THIRD(EX1) + EX3, EXIT, - EX1 + EX2 "==" EX1 + EX3, -ENDFUN $ - -PROPERTY *, "==", FUNCTION (EX1, EX2, EX3), - WHEN FIRST(EX1) = '"==", - SECOND(EX1) * EX2 "==" THIRD(EX1) * EX3, EXIT, - EX1 * EX2 "==" EX1 * EX3, -ENDFUN $ - -PROPERTY BASE, "==", FUNCTION (EX1, EX2, EX3), - WHEN FIRST(EX1)='"==", - EX2^SECOND(EX1) "==" EX3^THIRD(EX1) EXIT, - EX2 ^ EX1 "==" EX3 ^ EX1, -ENDFUN $ - -PROPERTY EXPON, "==", FUNCTION (EX1, EX2, EX3), - EX1 ^ EX2 "==" EX1 ^ EX3, -ENDFUN $ - -PROPERTY LOG, "==", FUNCTION (EX1, EX2, EX3), - LOG (EX2,EX1) "==" LOG (EX3,EX1), -ENDFUN $ - -PROPERTY INFIX, =, EQPARSE (SCAN) $ - -FUNCTION EQPARSE (EX2), - WHEN EX2 EQ '=, - LIST ('"==", EX1, PARSE (SCAN(), 80)) EXIT, - LIST ('=, EX1, PARSE (SCAN, 80)), -ENDFUN $ - -FUNCTION LN (EX1), - LOG (EX1, #E), -ENDFUN $ - -RDS () $ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/FACTORS.MU b/software/CPM/CPM_MC_5/FACTORS.MU deleted file mode 100644 index 7f15618..0000000 --- a/software/CPM/CPM_MC_5/FACTORS.MU +++ /dev/null @@ -1,38 +0,0 @@ -% routine to calculate multiplicative factors % -FUNCTION PRIME (N,A,B) - WHEN N=2 OR N=3, TRUE EXIT, - WHEN INTEGER(N)=FALSE OR INTEGER(N/2), FALSE EXIT, - A:3 B:N^(1/2) % B=SQR(N) % - LOOP - WHEN INTEGER(N/A), FALSE EXIT - WHEN A>B, TRUE EXIT, - A:A+2, - ENDLOOP -ENDFUN $ -% % -% now the main function % -% % -FUNCTION FACTORS(N,J,ANS,B,D), - WHEN INTEGER(N)=FALSE, FALSE EXIT, - WHEN PRIME(N), ANS:LIST(1,N) EXIT, - J:N, ANS:LIST(), B:2, - LOOP - D:N/B - BLOCK - WHEN INTEGER(D)=FALSE OR PRIME(B)=FALSE, EXIT - WHEN INTEGER(D/B), N:D - LOOP - ANS:ADJOIN(B,ANS) - WHEN INTEGER(N/B)=FALSE, EXIT, - N:N/B, - ENDLOOP EXIT, - ANS:ADJOIN(B,ANS), - ENDBLOCK - B:B+1 - WHEN B>J/2, ANS EXIT - ENDLOOP -ENDFUN $ -))), - UNPARSE(2, TRUE, LIST(REST(FIRST(LEX2)))), - PRINTLINE('$), - LEX2:REST \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/FLOAT.MU b/software/CPM/CPM_MC_5/FLOAT.MU deleted file mode 100644 index e370f91..0000000 Binary files a/software/CPM/CPM_MC_5/FLOAT.MU and /dev/null differ diff --git a/software/CPM/CPM_MC_5/HEX.MU b/software/CPM/CPM_MC_5/HEX.MU deleted file mode 100644 index 36a646c..0000000 Binary files a/software/CPM/CPM_MC_5/HEX.MU and /dev/null differ diff --git a/software/CPM/CPM_MC_5/INT%.DIF b/software/CPM/CPM_MC_5/INT%.DIF deleted file mode 100644 index 89e558b..0000000 --- a/software/CPM/CPM_MC_5/INT%.DIF +++ /dev/null @@ -1,16 +0,0 @@ - file INT%.DIF 02/26/82 -Make a new file INT.DIF as follows: -(1) Start with the old file INT.DIF. -(2) Insert in it, at the end (just before RDS() $ ), - all of this file below the line: -------------------------------------------------------------- - -FUNCTION ERF(EX1), - WHEN EX1 EQ MINF, -1 EXIT, - WHEN EX1 < 0, -ERF(-EX1) EXIT, - WHEN ZERO(EX1), 0 EXIT, - WHEN EX1 EQ PINF, 1 EXIT, - SIMPU('ERF,EX1), -ENDFUN $ - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/INT.DIF b/software/CPM/CPM_MC_5/INT.DIF deleted file mode 100644 index 00d35f3..0000000 --- a/software/CPM/CPM_MC_5/INT.DIF +++ /dev/null @@ -1,197 +0,0 @@ -%File INT.DIF (c) 07/31/81 The Soft Warehouse % - - -FUNCTION QUERY (EX1, LEX1, LEX2, LEX3, READCHAR), - % EX1: relative subexpression % - % LEX1: query question % - % LEX2: possible responses % - % LEX3: AList of previous expressions & answers % - % READCHAR: set to FALSE for raw input mode % - % RSLT: dotted pair of response and revised AList % - WHEN ASSOC(EX1,LEX3), - ADJOIN (REST(ASSOC(EX1,LEX3)), LEX3) EXIT, - NEWLINE (), - PRINT ("???"), SPACES (2), - PRTMATH (EX1, 0, 0, TRUE), - SPACES (2), PRINTLINE ("???"), - PRINT ('ENTER), - LOOP - SPACES (1), - WHEN EMPTY (LEX1) EXIT, - PRINT (POP(LEX1)) - ENDLOOP, - PRINT (LEX2), - PRINT ("? "), - BLOCK - WHEN BELL, PRINT ("") EXIT, - ENDBLOCK, - LOOP - WHEN MEMBER (READCHAR(), LEX2) EXIT, - ENDLOOP, - PRINTLINE (SCAN), - ADJOIN (SCAN, ADJOIN(ADJOIN(EX1,SCAN),LEX3)) -ENDFUN $ - -FUNCTION SIGN(EX1), - WHEN ZERO(EX1), EX1 EXIT, - WHEN EX1 > 0, 1 EXIT, - WHEN EX1 < 0, -1 EXIT, - WHEN EX1 EQ PINF, 1 EXIT, - WHEN EX1 EQ MINF, -1 EXIT, - WHEN EX1 = PINF-MINF, 1 EXIT, - EX1: QUERY (EX1, '(SIGN), LIST(0, '+, '-), SIGN), - SIGN: REST(EX1), - EX1: FIRST(EX1), - WHEN ZERO(EX1), EX1 EXIT, - WHEN EX1 EQ '+, 1 EXIT, - -1 -ENDFUN $ - -HALF: 1/2 $ - -FUNCTION INT3 (), - % Global var HALF=1/2 & fluid vars INDET from INT & EX1 from INT1 % - WHEN EX1 = INDET, HALF*EX1^2 EXIT, - APPLY (GET('INT,FIRST(EX1)), ARGEX(EX1)), -ENDFUN $ - -FUNCTION DRVDIV (LEX1), - % Fluid vars, from INT & INT1: INDET, EX1, EX2, EX3, EX4, EX5 % - WHEN EMPTY (LEX1), INT3() EXIT, - WHEN (EX4:POP(LEX1)) = INDET, DRVDIV (LEX1) EXIT, - EX5: EX1 / EX4, - WHEN ZERO (EX3:DIF(EX4,INDET)), - EX2: EX2*EX4, EX1: EX5, DRVDIV (LEX1) EXIT, - WHEN FREE (EX3:EXPD(EX5/EX3), INDET), HALF*EX3*EX4^2 EXIT, - WHEN SUM(EX4), DRVDIV (LEX1) EXIT, - WHEN ZERO (EX3: DIF(SECOND(EX4), INDET)), - WHEN ZERO(EX3:DIF(THIRD(EX4),INDET)), DRVDIV (LEX1) EXIT, - WHEN FREE(EX3:EXPD(EX5/EX3), INDET), - WHEN EX5: APPLY (GET('INT, FIRST(EX4)), - LIST (SECOND(EX4), INDET)), - EX3 * EVSUB(EX5,INDET,THIRD(EX4)) EXIT, - DRVDIV (LEX1) EXIT, - DRVDIV (LEX1) EXIT, - WHEN FREE (RREST(EX4), INDET), - WHEN FREE (EX3:EXPD(EX5/EX3), INDET), - WHEN EX5: APPLY(GET('INT,FIRST(EX4)), ADJOIN(INDET,RREST(EX4))), - EX3 * EVSUB(EX5,INDET,SECOND(EX4)) EXIT, - DRVDIV (LEX1) EXIT, - DRVDIV (LEX1) EXIT, - DRVDIV (LEX1), -ENDFUN $ - -FUNCTION INT2 (), - % Fluid vars, from INT & INT1: INDET, EX1 % - WHEN PRODUCT(EX1), DRVDIV (REST(EX1)) EXIT, - WHEN FREE(EX1,INDET), EX1*INDET EXIT, - INT3(), -ENDFUN $ - -FUNCTION INT1 (EX1, - % Local: % EX2, EX3, EX4, EX5), - EX2: 1, - WHEN EX3:INT2(), EX2*EX3 EXIT, - TRGEXPD: LOGEXPD: NUMNUM: DENDEN: DENNUM: 30, - PWREXPD: 6, - EX1: EVAL(EX1), - WHEN EX3:INT2(), EX2*EX3 EXIT, - NUMNUM: DENDEN: DENNUM: -30, - TRGEXPD: 7, - EX1: EVAL(EX1), - WHEN EX3:INT2(), TRGEXPD:-7, EX2*EVAL(EX3) EXIT, - EX2 * LIST ('INT, EX1, INDET), -ENDFUN $ - -FUNCTION INT (EX1, INDET, - % Local: % PWREXPD, NUMNUM, DENDEN, DENNUM, NUMDEN, - BASEXP, EXPBAS, LOGEXPD, TRGEXPD, SIGN), - PWREXPD: NUMDEN: LOGEXPD: TRGEXPD: 0, - NUMNUM: DENNUM: 6, - DENDEN: 2, - BASEXP: -30, - EXPBAS: 30, - INT1 (EX1), -ENDFUN $ - -PROPERTY INT, COS, FUNCTION (EX1, - % Local: % EX2), - WHEN FREE (EX2:DIF(EX1,INDET), INDET), SIN(EX1) / EX2 EXIT, -ENDFUN $ - -PROPERTY INT, SIN, FUNCTION (EX1, - % Local: % EX2), - WHEN FREE (EX2:DIF(EX1,INDET), INDET), -COS(EX1) / EX2 EXIT, -ENDFUN $ - -PROPERTY INT, LOG, FUNCTION (EX2, EX3), - WHEN EX3 EQ #E, - WHEN FREE (EX3:DIF(EX2,INDET), INDET), - EX2 * (LN(EX2)-1)/EX3 EXIT EXIT, -ENDFUN $ - -MINUSHALF: -HALF $ - -PROPERTY INT, ^, FUNCTION (EX2, EX3, - % Local: % EX4, EX5), - % Globals HALF=1/2, MINUSHALF=-1/2 % - % Fluid var INDET from INT % - WHEN FREE (EX3, INDET), - WHEN EX2 = INDET, - WHEN EX3 EQ -1, LN(INDET) EXIT, - INDET^(EX3+1) / (EX3+1) EXIT, - APPLY (GET(INTPWR, FIRST(EX2)), ARGEX(EX2)) EXIT, - WHEN FREE (EX2, INDET), - WHEN FREE (EX4:DIF(EX3,INDET), INDET), - LIST('^, EX2, EX3) / EX4 / LN(EX2) EXIT, - WHEN FREE (EX5:DIF(EX4,INDET), INDET), - (MINUSHALF*#PI/EX5/LN(EX2))^HALF * EX2^(EX3-HALF*EX4^2/EX5) - * ERF (-EX4*(MINUSHALF*LN(EX2)/EX5)^HALF) EXIT EXIT, -ENDFUN $ - -PROPERTY INTPWR, +, FUNCTION ( - % Local: % EX6, EX7), - % Fluid vars from INT, INT1 & property INT ^: - INDET, EX1, EX2, EX3, EX4 % - WHEN FREE (EX6:DIF(EX2,INDET), INDET), - WHEN EX3 EQ -1, LN(EX2)/EX6 EXIT, - EX2^(EX3+1) / (EX3+1) / EX6 EXIT, - WHEN POSITIVE(EX3), FALSE EXIT, - WHEN FREE (EX7:DIF(EX6,INDET), INDET), - WHEN ZERO (EX4: SIGN(EX5: EXPD(2*EX2*EX7-EX6^2))), - (2*EX7)^-EX3 * INT1(EX6^(2*EX3)) EXIT, - WHEN EX3 EQ -1, - WHEN EX4 EQ 1, - 2 * EX5^MINUSHALF * ATAN(EX6*EX5^MINUSHALF) EXIT, - (-EX5)^MINUSHALF - * LN (((-EX5)^HALF-EX6) / ((-EX5)^HALF+EX6)) EXIT, - WHEN NEGATIVE(EX3), - ((2*EX3+3)*EX7*INT1(EX2^(EX3+1)) - EX6*EX2^(EX3+1)) - / (EX3+1) / EX5 EXIT, - WHEN EX3 = MINUSHALF, - WHEN ZERO (EX4:SIGN(EX7)), - INT1 (EXPD ((EX2-HALF*EX7*INDET)^MINUSHALF)) EXIT, - WHEN EX4 EQ 1, - (HALF*EX7)^MINUSHALF * LN((2*EX2*EX7)^HALF+EX6) EXIT, - -(MINUSHALF*EX7)^MINUSHALF * ASIN(EX6*(-EX5)^MINUSHALF) EXIT, - WHEN NEGATIVE(2*EX3), - ((2*EX3+3)*EX7*INT1(EX2^(EX3+1)) - EX6*EX2^(EX3+1)) - / (EX3+1) / EX5 EXIT, - WHEN POSITIVE(2*EX3), - HALF * (EX1*EX6 + EX3*EX5*INT1(EX2^(EX3-1))) - / (HALF+EX3) / EX7 EXIT EXIT, -ENDFUN $ - -PROPERTY INT, +, FUNCTION (EX1, EX2), - EX1: INT1(EX1), - WHEN SUM (EX2), - POP (EX2), - LOOP - EX1: EX1 + INT1(POP(EX2)), - WHEN EMPTY (EX2), EX1 EXIT, - ENDLOOP EXIT, - EX1 + INT1(EX2), -ENDFUN $ - -RDS() $ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/INTMORE.INT b/software/CPM/CPM_MC_5/INTMORE.INT deleted file mode 100644 index 68918be..0000000 --- a/software/CPM/CPM_MC_5/INTMORE.INT +++ /dev/null @@ -1,214 +0,0 @@ -% File INTMORE.INT (c) 07/31/81 The Soft Warehouse % - - -FUNCTION DEFINT (EX1, EX2, EX3, EX4, - % Local: % EX5), - WHEN FREE (EX5:INT(EX1,EX2), 'INT), - WHEN INTEGER(#LIM), - WHEN POSITIVE(SIGN(EX4-EX3)), - LIM (LIM(EX5,EX2,EX4,TRUE) - LIM(EX5,EX2,EX3)) EXIT, - LIM (LIM(EX5,EX2,EX4) - LIM(EX5,EX2,EX3,TRUE)) EXIT, - EVSUB(EX5,EX2,EX4) - EVSUB(EX5,EX2,EX3) EXIT, - LIST ('DEFINT, EX1, EX2, EX3, EX4), -ENDFUN $ - -PROPERTY INT, ASIN, FUNCTION (EX2, - % Local: % EX3), - % Fluid var from INT1: EX1 % - WHEN FREE (EX3:DIF(EX2,INDET), INDET), - (EX1*EX2 + (1-EX2^2)^HALF) / EX3 EXIT, -ENDFUN $ - -PROPERTY INT, ATAN, FUNCTION (EX2, - % Local: % EX3), - % Fluid var from INT1: EX1 % - WHEN FREE (EX3:DIF(EX2,INDET), INDET), - (EX1*EX2 - HALF*LN(EX2^2+1)) / EX3 EXIT, -ENDFUN $ - -FUNCTION INTPROD (EX2, EX3, - % Local: % EX4, EX5), - % Fluid var from INT: INDET % - WHEN EX2 = INDET, - APPLY (GET(INTMONTMS,FIRST(EX3)), ADJOIN(1,ARGEX(EX3))) EXIT, - WHEN POWER(EX2), - WHEN FREE (THIRD(EX2), INDET), - WHEN SECOND(EX2)=INDET, - APPLY (GET(INTMONTMS,FIRST(EX3)), - ADJOIN (THIRD(EX2), ARGEX(EX3))) EXIT, - APPLY (GET(INTPWRTMS,FIRST(SECOND(EX2))), - ADJOIN (THIRD(EX2), ARGEX(SECOND(EX2)))) EXIT, - WHEN FREE (EX4:SECOND(EX2), INDET), - WHEN FREE (EX5:DIF(THIRD(EX2),INDET), INDET), - APPLY (GET(INTEXPTMS,FIRST(EX3)), ARGEX(EX3)) EXIT EXIT EXIT, -ENDFUN $ - -PROPERTY INT, *, FUNCTION (EX2, EX3), - WHEN PRODUCT(EX3), FALSE EXIT, - WHEN INTPROD(EX2,EX3) EXIT, - INTPROD(EX3,EX2), -ENDFUN $ - -PION4: #PI/4 $ - -PROPERTY INTPWR, COS, FUNCTION (EX4), - % Fluid vars from property "INT^": EX2, EX3, EX5 % - WHEN FREE (EX5:DIF(EX4,INDET), INDET), - WHEN EX3 EQ -1, LN (TAN (PION4 + HALF*EX4)) / EX5 EXIT, - WHEN NEGATIVE(EX3), - ((EX3+2)*INT1(EX2^(EX3+2)) - SIN(EX4)*EX2^(EX3+1)/EX5) - / (EX3+1) EXIT EXIT, -ENDFUN $ - -PROPERTY INTPWR, SIN, FUNCTION (EX4), - % Fluid vars from property "INT^": EX2, EX3, EX5 % - WHEN FREE (EX5:DIF(EX4,INDET), INDET), - WHEN EX3 EQ -1, LN (TAN(HALF*EX4)) / EX5 EXIT, - WHEN NEGATIVE(EX3), - ((EX3+2)*INT1(EX2^(EX3+2)) + COS(EX4)*EX2^(EX3+1)/EX5) - / (EX3+1) EXIT EXIT, -ENDFUN $ - -PROPERTY INTPWR, LOG, FUNCTION (EX4, EX5), - % Fluid vars from INT1 & property "INT^": EX1, EX2, EX3 % - WHEN EX5 EQ #E, - WHEN POSITIVE(EX3), - WHEN FREE (EX5:DIF(EX4,INDET), INDET), - EX1*EX4/EX5 - EX3*INT1(EX2^(EX3-1)) EXIT EXIT EXIT, -ENDFUN $ - -PROPERTY INTEXPTMS, COS, FUNCTION (EX6,EX7), - % Fluid vars, from INT and INTPROD: INDET, EX1, EX2, EX3, EX4 % - WHEN FREE (EX7:DIF(EX6,INDET), INDET), - EX2 * EX4^(INDET-EX6/EX7) * (EX3*EX5*LN(EX4) + EX7*SIN(EX6)) - / ((EX5*LN(EX4))^2 + EX7^2) EXIT, -ENDFUN $ - -PROPERTY INTEXPTMS, SIN, FUNCTION (EX6, EX7), - % Fluid vars, from INT and INTPROD: INDET, EX1, EX2, EX3, EX4 % - WHEN FREE (EX7:DIF(EX6,INDET), INDET), - EX2 * EX4^(INDET-EX6/EX7) * (EX3*EX5*LN(EX4) - EX7*COS(EX6)) - / ((EX5*LN(EX4))^2 + EX7^2) EXIT, -ENDFUN $ - -PROPERTY INTMONTMS, LOG, FUNCTION (EX5, EX6, EX7), - % Fluid vars from INT and INTPROD: INDET, EX1, EX2 % - WHEN EX7 EQ #E, - WHEN FREE (EX7:DIF(EX6,INDET), INDET), - WHEN ZERO (EX4: EXPD(EX6-INDET*EX7)), - INDET * (EX1 - EX2/(EX5+1)) / (EX5+1) EXIT, - WHEN POSITIVE (EX5), - EVSUB (INT1(EXPAND(((INDET-EX4)/EX7)^EX5*LN(INDET))), - INDET, EX6) / EX7 EXIT EXIT EXIT, -ENDFUN $ - -PROPERTY INTMONTMS, ^, FUNCTION (EX6, EX7, EX8, EX9), - % Fluid vars from INT, INT1, & INTPROD: - INDET, EX1, EX2, EX3, EX4, EX5 % - WHEN NEGATIVE (EX8), - WHEN FREE (EX4:DIF(EX7,INDET), INDET), - WHEN POSITIVE (EX6), - EX4^(-1-EX6) * EVSUB (INT1((INDET-EX7+EX4*INDET)^EX6 - * INDET^EX8), INDET, EX7) EXIT, - WHEN NEGATIVE (EX6), - -(EX7-EX4*INDET)^(1+EX6+EX8) * EVSUB (INT1( - (INDET-EX4)^(-2-EX6-EX8)*INDET^EX8), INDET, EX7/INDET) - EXIT EXIT, - WHEN FREE (EX5:DIF(EX4,INDET), INDET), - EX9: EX4 - EX5*INDET, - WHEN NEGATIVE (EX6), - WHEN EX6 EQ -1, - WHEN EX8 EQ -1, - (LN(INDET^2*EX3) - EX9*INT1(EX3)) - / (2*EX7 - INDET*(EX4+EX9)) EXIT, - (EX7^(EX8+1)/(EX8+1) - EX9*INT1(EX3) - + 2*INT1(EX2*EX7^(EX8+1))) / (2*EX7-INDET*(EX4+EX9)) EXIT, - (2*(INDET^(EX6+1)*EX7^(EX8+1) - - 2*(2+EX6+EX8)*EX9*INT1(INDET^(EX6+1)*EX3)) - - EX5*(3+EX6+2*EX8)*INT1(INDET^(EX6+2)*EX3)) - / (EX6+1) / (2*EX7 - INDET*(EX4+EX9)) EXIT, - WHEN POSITIVE (EX6), - WHEN ZERO (EX6+1+2*EX8), - WHEN EX6 EQ 1, - (LN(EX7) - EX9*INT1(EX3)) / EX5 EXIT EXIT, - 2 * (INDET^(EX6-1)*EX7^(EX8+1) - + (1-EX6)*(EX7-HALF*INDET*(EX4+EX9)) - * INT1(INDET^(EX6-2)*EX3) - - (EX6+EX8)*EX9*INT1(INDET^(EX6-1)*EX3)) / EX5 - / (EX6 + 2*EX8 + 1) EXIT EXIT EXIT, - WHEN FREE (EX7,INDET), - WHEN POSITIVE(EX6), - WHEN FREE (EX4:DIF(EX8,INDET), INDET), - (EX1 - EX6*INT1(EX1/INDET)) / EX4 / LN(EX7) EXIT EXIT EXIT, - WHEN POSITIVE (EX8), - WHEN LOGARITHM (EX7), - WHEN THIRD(EX7) EQ #E, - WHEN SECOND(EX7) = INDET, - (INDET*EX1 - EX8*INT1(EX1/EX7)) / (EX6+1) EXIT, - WHEN FREE (EX5:DIF(SECOND(EX7),INDET), INDET), - WHEN POSITIVE(EX6), - EVSUB (INT1((INDET-SECOND(EX7)+EX5*INDET)^EX6 - * LN(INDET)^EX8), INDET, SECOND(EX7)) / EX5^(EX6+1) - EXIT EXIT EXIT EXIT EXIT, -ENDFUN $ - -PROPERTY INTMONTMS, COS, FUNCTION (EX5, EX6), - % Fluid vars from INT & INTPROD: EX2, EX4, INDET % - WHEN POSITIVE (EX5), - WHEN EX6 = INDET, - EX2*SIN(EX6) - EX5*INT1(EX2/INDET*SIN(EX6)) EXIT, - WHEN FREE (EX4:DIF(EX6,INDET), INDET), - EVSUB (INT1(EXPAND((INDET+INDET*EX4-EX6)^EX5*COS(INDET))), - INDET, EX6) / EX4^(EX5+1) EXIT EXIT, -ENDFUN $ - -PROPERTY INTMONTMS, SIN, FUNCTION (EX5, EX6), - % Fluid vars from INT & INTPROD: EX2, EX4, INDET % - WHEN POSITIVE (EX5), - WHEN EX6 = INDET, - EX5*INT1(EX2/INDET*COS(EX6)) - EX2*COS(EX6) EXIT, - WHEN FREE (EX4:DIF(EX6,INDET), INDET), - EVSUB (INT1(EXPAND((INDET+INDET*EX4-EX6)^EX5*SIN(INDET))), - INDET, EX6) / EX4^(EX5+1) EXIT EXIT, -ENDFUN $ - -PROPERTY INTPWRTMS, SIN, FUNCTION (EX6, EX7), - % Fluid vars from INT & INTPROD: EX2, EX3, EX4, EX5, INDET % - WHEN POWER(EX3), - WHEN FIRST(SECOND(EX3)) EQ 'COS, - WHEN SECOND(SECOND(EX3))=EX7, - WHEN FREE (EX4:DIF(EX7,INDET), INDET), - WHEN POSITIVE (EX5:THIRD(EX3)), - WHEN EX6 EQ -1, - ((EX5-1)*INT1(EX2*SECOND(EX3)^(EX5-2)) - + SECOND(EX2)^(EX6+1)*SECOND(EX3)^(EX5-1)/EX4) - / (EX5+EX6) EXIT, - WHEN NEGATIVE(EX6), - (SECOND(EX2)^(EX6+1)*SECOND(EX3)^(EX5-1)/EX4 - + (EX5-1)*INT1(SECOND(EX2)^(EX6+2)*SECOND(EX3)^(EX5-2))) - / (EX6+1) EXIT EXIT, - WHEN POSITIVE (EX6), - WHEN EX5 EQ -1, - ((EX6-1)*INT1(SECOND(EX2)^(EX6-2)*EX3) - - SECOND(EX2)^(EX6-1)*SECOND(EX3)^(EX5+1)/EX4) - / (EX5+EX6) EXIT, - WHEN NEGATIVE (EX5), - ((EX6-1)*INT1(SECOND(EX2)^(EX6-2)*SECOND(EX3)^(EX5+2)) - - SECOND(EX2)^(EX6-1)*SECOND(EX3)^(EX5+1)/EX4) - / (EX5+1) EXIT EXIT, - WHEN EX6 EQ -1, - WHEN EX5 EQ -1, FALSE EXIT, - WHEN NEGATIVE (EX5), - ((EX5+EX6+2)*INT1(EX2*SECOND(EX3)^(EX5+2)) - - SECOND(EX2)^(EX6+1)*SECOND(EX3)^(EX5+1)/EX4) - / (EX5+1) EXIT EXIT, - WHEN NEGATIVE (EX6), - WHEN NEGATIVE(EX5), - ((EX5+EX6+2)*INT1(SECOND(EX2)^(EX6+2)*EX3) - + SECOND(EX2)^(EX6+1)*SECOND(EX3)^(EX5+1)/EX4) - / (EX6+1) EXIT EXIT EXIT EXIT EXIT EXIT, -ENDFUN $ - -RDS () $ - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/LIM%.DIF b/software/CPM/CPM_MC_5/LIM%.DIF deleted file mode 100644 index 5556904..0000000 --- a/software/CPM/CPM_MC_5/LIM%.DIF +++ /dev/null @@ -1,16 +0,0 @@ - file LIM%.DIF GAE - Feb. 1982 -Make a new version of file LIM.DIF as follows: -(1) Start with the original LIM.DIF. -(2) Add at the end (just before RDS () $ ) the rest of this - file: -------------------------------------------------------------- - -PROPERTY LIM, ERF, FUNCTION (EX1), - WHEN (EX1:LIM1(EX1,#LIM)) EQ PINF, 1 EXIT, - WHEN EX1 EQ MINF, -1 EXIT, - WHEN EX1 EQ CINF, ? EXIT, - WHEN MEMBER (EX1, '(? PZERO MZERO)), EX1 EXIT, - ERF(EX1), -ENDFUN $ - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/LIM.DIF b/software/CPM/CPM_MC_5/LIM.DIF deleted file mode 100644 index faaaac4..0000000 --- a/software/CPM/CPM_MC_5/LIM.DIF +++ /dev/null @@ -1,316 +0,0 @@ -% File LIM.DIF (c) 01/16/82 The Soft Warehouse % - - -FUNCTION QUERY (EX1, LEX1, LEX2, LEX3, READCHAR), - % EX1: relative subexpression % - % LEX1: query question % - % LEX2: possible responses % - % LEX3: AList of previous expressions & answers % - % READCHAR: set to FALSE for raw input mode % - % RSLT: dotted pair of response and revised AList % - WHEN ASSOC(EX1,LEX3), - ADJOIN (REST(ASSOC(EX1,LEX3)), LEX3) EXIT, - NEWLINE (), - PRINT ("???"), SPACES (2), - PRTMATH (EX1, 0, 0, TRUE), - SPACES (2), PRINTLINE ("???"), - PRINT ('ENTER), - LOOP - SPACES (1), - WHEN EMPTY (LEX1) EXIT, - PRINT (POP(LEX1)) - ENDLOOP, - PRINT (LEX2), - PRINT ("? "), - BLOCK - WHEN BELL, PRINT ("") EXIT, - ENDBLOCK, - LOOP - WHEN MEMBER (READCHAR(), LEX2) EXIT, - ENDLOOP, - PRINTLINE (SCAN), - ADJOIN (SCAN, ADJOIN(ADJOIN(EX1,SCAN),LEX3)) -ENDFUN $ - -FUNCTION SIGN(EX1), - WHEN ZERO(EX1), EX1 EXIT, - WHEN EX1 > 0, 1 EXIT, - WHEN EX1 < 0, -1 EXIT, - WHEN EX1 EQ PINF, 1 EXIT, - WHEN EX1 EQ MINF, -1 EXIT, - WHEN EX1 = PINF-MINF, 1 EXIT, - EX1: QUERY (EX1, '(SIGN), LIST(0, '+, '-), SIGN), - SIGN: REST(EX1), - EX1: FIRST(EX1), - WHEN ZERO(EX1), EX1 EXIT, - WHEN EX1 EQ '+, 1 EXIT, - -1 -ENDFUN $ - -FUNCTION ODDEVEN (EX1), - WHEN NUMBER (EX1), - WHEN INTEGER (EX1), - WHEN EVEN (EX1), 'E EXIT, - 'O EXIT EXIT, - EX1: QUERY (EX1, '(ODD,EVEN,OR,NONINTEGER), '(O,E,N), ODDEVEN), - ODDEVEN: REST(EX1), - FIRST (EX1), -ENDFUN $ - -FUNCTION SIZE (EX1), - WHEN ATOM(EX1), 1 EXIT, - SIZE(POP(EX1)) + SIZE(EX1), -ENDFUN $ - - -#LIM: 3 $ - -FUNCTION LIM1 (EX1, #LIM), - % Fluid var from LIM: INDET % - WHEN EX1=INDET, PZERO EXIT, - WHEN ATOM(EX1), EX1 EXIT, - WHEN APPLY (GET('LIM,FIRST(EX1)), ARGEX(EX1)), EXIT, - LIST ('LIM, EX1, INDET, 0), -ENDFUN $ - -FUNCTION LIM (EX1, % Optional: % INDET, EX2, EX3, - % Local: % LOGBAS, PWREXPD, NUMNUM, DENDEN, DENNUM, - NUMDEN, BASEXP, EXPBAS, LOGEXPD, TRGEXPD, SIGN, ODDEVEN), - LOGBAS: #E, - PWREXPD: NUMDEN: 0, - NUMNUM: DENDEN: EXPBAS: 30, - DENNUM: BASEXP: -30, - LOGEXPD: 70, - TRGEXPD: 2, - BLOCK - WHEN EX2, EXIT, - EX2: 0 - ENDBLOCK, - WHEN EX2 EQ PINF, LIM1 (EVSUB(EX1,INDET,1/INDET), #LIM) EXIT, - WHEN EX2 EQ MINF, LIM1 (EVSUB(EX1,INDET,-1/INDET), #LIM) EXIT, - WHEN EX3, LIM1 (EVSUB(EX1,INDET,EX2-INDET), #LIM) EXIT, - WHEN INDET, LIM1 (EVSUB(EX1,INDET,EX2+INDET), #LIM), EXIT, LIM1(EX1,#LIM), -ENDFUN $ - -FUNCTION INDET (EX1, EX2, - % Local: % EX3), - % Fluid vars from LIM & LIM1: #LIM, INDET % - WHEN ZERO(#LIM), LIST ('LIM, EX1*EX2, INDET, 0) EXIT, - WHEN ATOM (EX3:DIF(EX1,INDET)/DIF(1/EX2,INDET)), - LIM1 (EX3, #LIM-1) EXIT, - WHEN SIZE (EX1:DIF(EX2,INDET)/DIF(1/EX1,INDET)) < SIZE(EX3), - LIM1 (EX1, #LIM-1) EXIT, - LIM1 (EX3, #LIM-1), -ENDFUN $ - - -PROPERTY LIM, +, FUNCTION ( - % Local: % EX2, EX3, EX4, EX5, DENNUM), - % Fluid vars from LIM & LIM1: EX1, #LIM, INDET % - DENNUM: -30, - EX2: EX3: 0, - LOOP - WHEN ATOM (EX1:REST(EX1)), - WHEN ZERO(EX2), - WHEN ZERO(EX3), EX4 EXIT, - MINF EXIT, - WHEN ZERO(EX3), PINF EXIT, - DENNUM: 0, - WHEN MEMBER (EX5:INDET(1+EX3/EX2,EX2), '(? PINF MINF)), - EX5 EXIT, - WHEN EX5 EQ PZERO, - WHEN EX4 EQ MZERO, 0 EXIT, - WHEN EX4, EXIT, - PZERO EXIT, - WHEN EX5 EQ MZERO, - WHEN EX4 EQ PZERO, 0 EXIT, - WHEN EX4, EXIT, - MZERO EXIT, - WHEN MEMBER (EX4, '(FALSE PZERO MZERO)), EX5 EXIT, - DENNUM: -30, - EX4+EX5 EXIT, - WHEN (EX5:LIM1(FIRST(EX1),#LIM)) EQ ? - OR EX4 EQ CINF AND MEMBER(EX5,'(CINF,PINF,MINF)) - OR EX5 EQ CINF AND NOT(ZERO(EX2) AND ZERO(EX3)), ? EXIT, - BLOCK - WHEN EX5 EQ CINF, EX4:CINF EXIT, - WHEN EX5 EQ PINF, EX2: EX2+FIRST(EX1) EXIT, - WHEN EX5 EQ PZERO, - WHEN EX4 EQ MZERO, EX4:0 EXIT, - WHEN NOT EX4, EX4:PZERO EXIT EXIT, - WHEN EX5 EQ MZERO, - WHEN EX4 EQ PZERO, EX4:0 EXIT, - WHEN NOT EX4, EX4:MZERO EXIT EXIT, - WHEN EX5 EQ MINF, EX3: EX3+FIRST(EX1) EXIT, - WHEN MEMBER(EX4,'(FALSE PZERO MZERO)), EX4:EX5 EXIT, - EX4: EX4+EX5 - ENDBLOCK - ENDLOOP, -ENDFUN $ - -PROPERTY LIM, *, FUNCTION ( - % Local: % EX2, EX3, EX4, EX5, EX6), - % Fluid from LIM & LIM1: EX1, #LIM, INDET % - EX2: EX3: EX4: EX5: 1, - LOOP - WHEN ATOM (EX1:REST(EX1)), - WHEN EX2 EQ 1, - WHEN EX3 EQ 1, EX4 EXIT, - WHEN POSITIVE (EX5:EX5*SIGN(EX4)), PZERO EXIT, - WHEN NEGATIVE(EX5), MZERO EXIT, - 0 EXIT, - WHEN EX3 EQ 1, - WHEN POSITIVE (EX5:EX5*SIGN(EX4)), PINF EXIT, - WHEN NEGATIVE(EX5), MINF EXIT, - CINF EXIT, - WHEN (EX6:INDET(EX3,EX2)) EQ ?, ? EXIT, - WHEN MEMBER (EX6, '(CINF PINF PZERO MZERO MINF)), - EX5: SIGN(EX4), - WHEN EX6 EQ CINF, - WHEN ZERO(EX5), ? EXIT, - CINF EXIT, - WHEN EX6 EQ PINF, - WHEN POSITIVE(EX5), PINF EXIT, - WHEN NEGATIVE(EX5), MINF EXIT, - ? EXIT, - WHEN EX6 EQ PZERO, - WHEN POSITIVE(EX5), PZERO EXIT, - WHEN NEGATIVE(EX5), MZERO EXIT, - 0 EXIT, - WHEN EX6 EQ MZERO, - WHEN POSITIVE(EX5), MZERO EXIT, - WHEN NEGATIVE(EX5), PZERO EXIT, - 0 EXIT, - WHEN POSITIVE(EX5), MINF EXIT, - WHEN NEGATIVE(EX5), PINF EXIT, - ? EXIT, - EX4*EX6 EXIT, - WHEN (EX6:LIM1(FIRST(EX1),#LIM)) EQ ?, ? EXIT, - BLOCK - WHEN EX6 EQ CINF, EX2: EX2*FIRST(EX1), EX5:0 EXIT, - WHEN EX6 EQ PINF, EX2: EX2*FIRST(EX1) EXIT, - WHEN EX6 EQ PZERO, EX3: EX3*FIRST(EX1) EXIT, - WHEN EX6 EQ MZERO, EX3: EX3*FIRST(EX1), EX5:-EX5 EXIT, - WHEN EX6 EQ MINF, EX2: EX2*FIRST(EX1), EX5:-EX5 EXIT, - WHEN ZERO(EX6), EX3: EX3*FIRST(EX1), EX5:0 EXIT, - EX4: EX4*EX6 - ENDBLOCK - ENDLOOP, -ENDFUN $ - -PROPERTY LIM, ^, FUNCTION (EX1, EX2), - % Fluid vars from LIM & LIM1: #LIM, INDET % - WHEN (EX1:LIM1(EX1,#LIM)) EQ 1, 1 EXIT, - WHEN EX1 EQ ? OR MEMBER (EX2:LIM1(EX2,#LIM), '(? CINF)), ? EXIT, - WHEN MEMBER (EX2, '(PZERO 0 MZERO)), - WHEN MEMBER (EX1, '(PZERO 0 MZERO)), ? EXIT, - 1 EXIT, - WHEN EX2 EQ PINF, - WHEN MEMBER (EX1, '(CINF MINF)), CINF EXIT, - WHEN MEMBER (EX1, '(PINF PZERO)), EX1 EXIT, - WHEN EX1 EQ MZERO, 0 EXIT, - WHEN EX1 EQ #E OR POSITIVE(EX2:SIGN(EX1-1)), PINF EXIT, - WHEN ZERO(EX2), 1 EXIT, - WHEN POSITIVE(EX2:SIGN(EX1)), PZERO EXIT, - WHEN ZERO(EX2), 0 EXIT, - WHEN POSITIVE (EX2:SIGN(EX1+1)), 0 EXIT, - WHEN NEGATIVE(EX2), CINF EXIT, - ? EXIT, - WHEN EX2 EQ MINF, - WHEN EX1 EQ PZERO, PINF EXIT, - WHEN EX1 EQ MZERO, CINF EXIT, - WHEN MEMBER (EX1, '(CINF MINF)), 0 EXIT, - WHEN EX1 EQ PINF OR EX1 EQ #E OR POSITIVE(EX2:SIGN(EX1-1)), PZERO EXIT, - WHEN ZERO(EX2), 1 EXIT, - WHEN POSITIVE (EX2:SIGN(EX1)), PINF EXIT, - WHEN ZERO(EX2), CINF EXIT, - WHEN NEGATIVE (EX2:SIGN(EX1+1)), 0 EXIT, - WHEN POSITIVE(EX2), CINF EXIT, - ? EXIT, - WHEN EX1 EQ CINF, - WHEN POSITIVE (EX2:SIGN(EX2)), CINF EXIT, - WHEN NEGATIVE(EX2), 0 EXIT, - 1 EXIT, - WHEN EX1 EQ PINF, - WHEN POSITIVE (EX2:SIGN(EX2)), PINF EXIT, - WHEN NEGATIVE(EX2), PZERO EXIT, - 1 EXIT, - WHEN EX1 EQ PZERO, - WHEN POSITIVE (EX2:SIGN(EX2)), PZERO EXIT, - WHEN NEGATIVE(EX2), PINF EXIT, - ? EXIT, - WHEN EX1 EQ MZERO, - WHEN POSITIVE(EX1:SIGN(EX2)), - WHEN (EX2:ODDEVEN(EX2)) EQ 'E, PZERO EXIT, - WHEN EX2 EQ 'O, MZERO EXIT, - 0 EXIT, - WHEN NEGATIVE(EX1), - WHEN (EX2:ODDEVEN(EX2)) EQ 'E, PINF EXIT, - WHEN EX2 EQ 'O, MINF EXIT, - CINF EXIT, - ? EXIT, - WHEN EX1 EQ MINF, - WHEN POSITIVE (EX1:SIGN(EX2)), - WHEN (EX2:ODDEVEN(EX2)) EQ 'E, PINF EXIT, - WHEN EX2 EQ 'O, MINF EXIT, - CINF EXIT, - WHEN NEGATIVE(EX1), - WHEN (EX2:ODDEVEN(EX2)) EQ 'E, PZERO EXIT, - WHEN EX2 EQ 'O, MZERO EXIT, - 0 EXIT, - 1 EXIT, - WHEN ZERO(EX1), - WHEN POSITIVE(EX1:SIGN(EX2)), - WHEN ODDEVEN(EX2) EQ 'E, PZERO EXIT, - 0 EXIT, - WHEN NEGATIVE(EX1), - WHEN ODDEVEN(EX2) EQ 'E, PINF EXIT, - CINF EXIT, - ? EXIT, - EX1^EX2, -ENDFUN $ - -PROPERTY LIM, !, FUNCTION (EX1), - WHEN MEMBER (EX1:LIM(EX1,#LIM), '(? PZERO PINF)), EX1 EXIT, - WHEN EX1 EQ MINF OR EX1 EQ MZERO, ? EXIT, - EX1 !, -ENDFUN $ - -PROPERTY LIM, LOG, FUNCTION (EX1 - % Local: % EX2), - WHEN (EX1:LIM1(EX1,#LIM)) EQ PZERO, MINF EXIT, - WHEN EX1 EQ PINF, PINF EXIT, - WHEN MEMBER (EX1, '(CINF MZERO MINF)) OR ZERO(EX2:SIGN(EX1)), - CINF EXIT, - WHEN NEGATIVE(EX2), ? EXIT, - LN(EX1), -ENDFUN $ - -PROPERTY LIM, ASIN, FUNCTION (EX1), - WHEN MEMBER (EX1:LIM1(EX1,#LIM), '(? PZERO MZERO)), EX1 EXIT, - WHEN EX1 EQ PINF OR EX1 EQ MINF, ? EXIT, - ASIN(EX1), -ENDFUN $ - -PROPERTY LIM, ATAN, FUNCTION (EX1), - WHEN (EX1:LIM1(EX1,#LIM)) EQ PINF, #PI/2 EXIT, - WHEN EX1 EQ MINF, -#PI/2 EXIT, - WHEN EX1 EQ CINF, ? EXIT, - WHEN MEMBER (EX1, '(? PZERO MZERO)), EX1 EXIT, - ATAN(EX1), -ENDFUN $ - -PROPERTY LIM, SIN, FUNCTION (EX1), - WHEN MEMBER (EX1:LIM1(EX1,#LIM), '(? CINF PINF MINF)), ? EXIT, - WHEN MEMBER (EX1, '(PZERO, MZERO)), EX1 EXIT, - SIN(EX1), -ENDFUN$ - -PROPERTY LIM, COS, FUNCTION (EX1), - WHEN MEMBER (EX1:LIM1(EX1,#LIM), '(? CINF PINF MINF)), ? EXIT, - WHEN MEMBER (EX1, '(PZERO, MZERO)), 1 EXIT, - COS(EX1), -ENDFUN $ - -RDS() $ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/LOG%.ALG b/software/CPM/CPM_MC_5/LOG%.ALG deleted file mode 100644 index e950976..0000000 --- a/software/CPM/CPM_MC_5/LOG%.ALG +++ /dev/null @@ -1,25 +0,0 @@ - file LOG%.ALG -Make a new version of LOG.ALG as follows: -(1) Start with the original LOG.ALG. -(2) Replace FUNCTION LOG (near the beginning of the file) - with this file below the line: ------------------------------------------------------------ - -FUNCTION LOG (EX1, % Optional: % EX2), - WHEN EMPTY(EX2), LOG (EX1, LOGBAS) EXIT, - WHEN ZERO(EX1), ?(LIST('LOG, EX1, EX2)) EXIT, - WHEN EX2 EQ 1, ?(LIST('LOG, EX1, EX2)) EXIT, - WHEN PBRCH AND EX1 EQ 1, 0 EXIT, - WHEN PBRCH AND EX1=EX2, 1 EXIT, - WHEN NEGMULT(TRGEXPD,7) AND EX2=#E, - 2*#I*ATAN(#I*(1-EX1)/(1+EX1)) EXIT, - WHEN PBRCH AND ZERO (MOD(EX1,EX2)), - 1 + LOG (QUOTIENT(EX1,EX2), EX2) EXIT, - WHEN NOT(EX2 EQ LOGBAS) AND POSMULT(LOGEXPD,2), - LOG(EX1,LOGBAS) / LOG(EX2,LOGBAS) EXIT, - WHEN ATOM(EX1), LIST('LOG, EX1, EX2) EXIT, - WHEN APPLY(GET('LOG,FIRST(EX1)), ADJOIN(EX2,ARGEX(EX1))) EXIT, - LIST('LOG, EX1, EX2), -ENDFUN $ - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/LOG.ALG b/software/CPM/CPM_MC_5/LOG.ALG deleted file mode 100644 index ad15468..0000000 --- a/software/CPM/CPM_MC_5/LOG.ALG +++ /dev/null @@ -1,71 +0,0 @@ -% File LOG.ALG (c) 05/21/81 The Soft Warehouse % - - -FUNCTION LOGEXPD (EX1, LOGEXPD), - EVAL (EX1), -ENDFUN $ - -FUNCTION LOG (EX1, % Optional: % EX2), - WHEN EMPTY(EX2), LOG (EX1, LOGBAS) EXIT, - WHEN ZERO(EX1), ?(LIST('LOG, EX1, EX2)) EXIT, - WHEN EX2 EQ 1, ?(LIST('LOG, EX1, EX2)) EXIT, - WHEN PBRCH AND EX1 EQ 1, 0 EXIT, - WHEN PBRCH AND EX1=EX2, 1 EXIT, - WHEN PBRCH AND ZERO (MOD(EX1,EX2)), - 1 + LOG (QUOTIENT(EX1,EX2), EX2) EXIT, - WHEN NOT(EX2 EQ LOGBAS) AND POSMULT(LOGEXPD,2), - LOG(EX1,LOGBAS) / LOG(EX2,LOGBAS) EXIT, - WHEN ATOM(EX1), LIST('LOG, EX1, EX2) EXIT, - WHEN APPLY(GET('LOG,FIRST(EX1)), ADJOIN(EX2,ARGEX(EX1))) EXIT, - LIST('LOG, EX1, EX2), -ENDFUN $ - -PROPERTY PRTMATH, LOG, FUNCTION (LEX1, - % Local: % EX1), - EX1 : POP(LEX1), - LEX1: FIRST(LEX1), - WHEN LEX1 EQ #E, - PRTLIST ('LN, EX1) EXIT, - WHEN LEX1 = LOGBAS, - PRTLIST ('LOG, EX1) EXIT, -ENDFUN $ - -FUNCTION LN (EX1), - LOG(EX1, #E), -ENDFUN $ - -PROPERTY LOG, *, FUNCTION (EX1, EX2, EX3), - WHEN POSMULT(LOGEXPD,5), LOG(EX2,EX1) + LOG(EX3,EX1) EXIT, -ENDFUN $ - -PROPERTY LOG, ^, FUNCTION (EX1, EX2, EX3), - WHEN POSMULT(LOGEXPD,3), EX3*LOG(EX2,EX1) EXIT, - WHEN PBRCH AND EX1=EX2, EX3*LOG(EX2,EX1) EXIT, -ENDFUN $ - -PROPERTY *, LOG, FUNCTION (EX1, EX2, EX3), - WHEN NEGMULT(LOGEXPD,2) AND POWER(EX1) - AND LOGARITHM(SECOND(EX1)) AND THIRD(EX1) EQ -1 - AND THIRD(SECOND(EX1))=EX3, - LOG (EX2, SECOND(SECOND(EX1))) EXIT, - WHEN NEGMULT(LOGEXPD,3), LOG (EX2^EX1, EX3) EXIT, -ENDFUN $ - -FUNCTION LOGARITHM (EX1), - FIRST(EX1) EQ 'LOG, -ENDFUN $ - -PROPERTY +, LOG, FUNCTION (EX1, EX2, EX3), - WHEN LOGARITHM(EX1), - WHEN NEGMULT(LOGEXPD,5), - WHEN THIRD(EX1)=EX3, - LOG (SECOND(EX1)*EX2, EX3) EXIT EXIT EXIT, -ENDFUN $ - -PROPERTY EXPON, LOG, FUNCTION (EX1, EX2, EX3), - WHEN EX1 = EX3, EX2 EXIT, -ENDFUN $ - -RDS() $ - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/MATRIX.ARR b/software/CPM/CPM_MC_5/MATRIX.ARR deleted file mode 100644 index 4402f80..0000000 --- a/software/CPM/CPM_MC_5/MATRIX.ARR +++ /dev/null @@ -1,219 +0,0 @@ -% File MATRIX.ARR (c) 04/26/81 The Soft Warehouse % - -PROPERTY RBP, ., 125 $ -PROPERTY LBP, ., 125 $ - -FUNCTION INPROD (LEX1, LEX2, - % Local: % EX1), - EX1: 0, - LOOP - WHEN ATOM (LEX1) OR ATOM (LEX2), - EX1 EXIT, - EX1: EX1 + POP(LEX1).POP(LEX2), - ENDLOOP, -ENDFUN $ - -FUNCTION MAPDOTRT (LEX1), - % Fluid var from OUTPROD or ".": EX1 % - WHEN ATOM (LEX1), LEX1 EXIT, - ADJOIN (EX1.POP(LEX1), MAPDOTRT(LEX1)), -ENDFUN $ - -FUNCTION OUTPROD (LEX1, LEX2, - % Local: % EX1), - WHEN ATOM (LEX1), LEX1 EXIT, - EX1: POP(LEX1), - ADJOIN (ADJOIN ('[, MAPDOTRT(LEX2)), OUTPROD(LEX1, LEX2)), -ENDFUN $ - -FUNCTION MAPDOTLFT (LEX1), - % Fluid var from ".": EX2 % - WHEN ATOM (LEX1), FALSE EXIT, - ADJOIN (POP(LEX1) . EX2, MAPDOTLFT(LEX1)), -ENDFUN $ - -FUNCTION . (EX1, EX2), - WHEN ROW (EX1), - WHEN COL (EX2), - INPROD (REST(EX1), REST(EX2)) EXIT, - WHEN ROW (EX2), - ADJOIN ('[, MAPDOTRT(REST(EX2))) EXIT, - EX1 * EX2 EXIT, - WHEN COL(EX1), - WHEN ROW (EX2), - ADJOIN ('{, OUTPROD (REST(EX1), REST(EX2))) EXIT, - WHEN COL (EX2), - ADJOIN ('{, MAPDOTLFT(REST(EX1))) EXIT, - EX1 * EX2 EXIT, - EX1 * EX2, -ENDFUN $ - - -%******************* Optional Transpose Package ******************% - - -PROPERTY LBP, `, 170 $ - -FUNCTION ` (EX1), - WHEN ATOM (EX1), EX1 EXIT, - WHEN APPLY (GET('`, FIRST(EX1)), ARGEX(EX1)) EXIT, - EX1, -ENDFUN $ - -PROPERTY `, {, FUNCTION (LEX1), - ADJOIN ('[, MAPFUN('`, LEX1)), -ENDFUN $ - -PROPERTY `, [, FUNCTION (LEX1), - ADJOIN ('{, MAPFUN('`, LEX1)), -ENDFUN $ - -PROPERTY LBP, TR, 170 $ - -MOVD ('`, 'TR) $ - -%***************** Optional Matrix Division Package **************% - - -FUNCTION APPEND (LEX1, LEX2), - WHEN ATOM (LEX1), LEX2 EXIT, - ADJOIN (POP(LEX1), APPEND(LEX1,LEX2)), -ENDFUN $ - -FUNCTION IDMAT (EX1, - % Local: % EX2), - EX2: LIST (1), - LOOP - WHEN ZERO (EX1:EX1-1) EXIT, - PUSH (0, EX2), - ENDLOOP, - EX1: FALSE, - LOOP - PUSH (ADJOIN ('[, EX2), EX1), - WHEN ATOM (EX2:REST(EX2)), ADJOIN ('{, EX1) EXIT, - ENDLOOP, -ENDFUN $ - -PROPERTY RBP, \, 125 $ -PROPERTY LBP, \, 125 $ - -#ARB: 0 $ - -FUNCTION STARTBACK (LEX1, - % Local: % EX1), - % Global: #ARB % - WHEN ATOM (LEX1), FALSE EXIT, - WHEN ZERO (EX1:POP(LEX1)), - ADJOIN (ARB(#ARB:#ARB+1), STARTBACK(LEX1)) EXIT, - WHEN ARRAY (EX1), - ADJOIN (ADJOIN (FIRST(EX1), - STARTBACK (REST(EX1))), STARTBACK(LEX1)) EXIT, - ADJOIN (? (LIST ('/, EX1, 0)), STARTBACK(LEX1)), -ENDFUN $ - -FUNCTION BACKSUB(LEX3), - % Fluid vars from \: LEX1 & LEX2 % - LOOP - WHEN ATOM (LEX1), - ADJOIN ('{, LEX3) EXIT, - PUSH (POP(LEX2) - POP(LEX1).ADJOIN('{,LEX3), LEX3), - ENDLOOP, -ENDFUN $ - -FUNCTION COLMAT(EX1), - WHEN FIRST(EX1) EQ '{, - LOOP - WHEN ATOM (EX1:REST(EX1)) EXIT, - WHEN NOT ROW(FIRST(EX1)), FALSE EXIT - ENDLOOP EXIT -ENDFUN $ - -FUNCTION \ (EX1, EX2, - % Local: % EX3, EX4, LEX1, LEX2, LEX3, LEX4), - WHEN (COLMAT(EX1) OR ROW(EX1) AND COLMAT(EX1: EX1.IDMAT(LENGTH(REST(EX1))))) - AND (COL(EX2) OR ROW(EX2) AND COL(EX2: EX2.IDMAT(LENGTH(REST(EX2))))), - EX1: REST(EX1), EX2: REST(EX2), - LOOP % make EX1 unit upper triangular, then back substitute % - LOOP % make implied unit diagonal above a column of zeros % - WHEN (EX4:REST(FIRST(EX1))) AND NOT ZERO(EX4:FIRST(EX4)), - EX3: EX4 \ ADJOIN('[, RREST(POP(EX1))), - EX4: EX4 \ POP(EX2), - LOOP % update remainder of EX1: % - WHEN ATOM(EX1), - EX1: LEX3, EX2: APPEND(LEX4,EX2) EXIT, - PUSH (ADJOIN ('[, RREST(FIRST(EX1))) - - SECOND(FIRST(EX1)).EX3, LEX3), - PUSH (POP(EX2) - SECOND(POP(EX1)).EX4, LEX4), - ENDLOOP EXIT, - PUSH (ADJOIN ('[, RREST(POP(EX1))), LEX3), - PUSH (FIRST(EX2), LEX4), - WHEN ATOM(EX1) EXIT, % Singular matrix: % - EX2: REST(EX2), - ENDLOOP, - WHEN ATOM(EX1), % do back substitution: % - WHEN ATOM(LEX3), BACKSUB(ADJOIN(EX4,STARTBACK(EX2))) EXIT, - EX3: LEX3, % have singular matrix: % - LOOP - WHEN ATOM(EX3), BACKSUB(STARTBACK(EX2)) EXIT, - WHEN REST(POP(EX3)), % maybe a nonzero in next col % - EX2: REST (ADJOIN ('{,LEX3) \ ADJOIN('{,LEX4)), - BACKSUB(ADJOIN(POP(EX2:REVERSE(EX2)),REVERSE(EX2))) - EXIT, - ENDLOOP EXIT, - LEX3: LEX4: FALSE, - PUSH (EX3, LEX1), PUSH (EX4, LEX2), - ENDLOOP EXIT, - EX2 / EX1, -ENDFUN $ - - -%********* Optional Matrix Power & Inverse Package ****************% - - -PROPERTY BASE, [, FUNCTION (EX1, LEX1), - WHEN COLMAT (LEX1: ADJOIN('[,LEX1).IDMAT(LENGTH(LEX1))), - LEX1 ^ EX1 EXIT -ENDFUN $ - -PROPERTY BASE, {, FUNCTION (EX1, LEX1, - % Local: % EX2), - WHEN ZERO(EX1), IDMAT (LENGTH(LEX1)) EXIT, - WHEN COLMAT(EX2:ADJOIN('{,LEX1)) OR COLMAT(EX2.IDMAT(LENGTH(LEX1))), - WHEN POSITIVE (EX1), - WHEN EX1 EQ 1, EX2 EXIT, - EX2 . EX2^(EX1-1) EXIT, - WHEN NEGATIVE (EX1), - WHEN EX1 EQ -1, EX2 \ IDMAT (LENGTH(LEX1)) EXIT, - (EX2 ^ -1) ^ -EX1 EXIT EXIT, -ENDFUN $ - -%***************** Optional Determinant Package *****************% - -FUNCTION DET (EX1, - % Local: % EX2, EX3, EX4, EX5, LEX3), - WHEN COLMAT(EX1) - OR ROW(EX1) AND COLMAT(EX1:EX1.IDMAT(LENGTH(REST(EX1)))), - EX1: REST(EX1), EX2: EX3: 1, - LOOP - LOOP - WHEN (EX4:REST(FIRST(EX1))) AND NOT ZERO(EX4:FIRST(EX4)), - EX2: EX2.EX4, - EX4: EX4 \ ADJOIN('[,RREST(POP(EX1))), - LOOP - WHEN ATOM(EX1), EX1: LEX3 EXIT, - PUSH (ADJOIN('[,RREST(FIRST(EX1))) - - SECOND(POP(EX1)).EX4, LEX3) - ENDLOOP EXIT, - PUSH (ADJOIN('[,RREST(POP(EX1))), LEX3), - EX5: NOT EX5, - WHEN ATOM(EX1), EX2: 0 EXIT - ENDLOOP, - WHEN ATOM(EX1) - WHEN (MOD(EX3,4) EQ 3) EQ EX5, EX2 EXIT, - -EX2 EXIT, - EX3: EX3+1, LEX3: FALSE - ENDLOOP EXIT -ENDFUN $ - -RDS () $ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/MUMATH%.DOC b/software/CPM/CPM_MC_5/MUMATH%.DOC deleted file mode 100644 index 49ec1d7..0000000 --- a/software/CPM/CPM_MC_5/MUMATH%.DOC +++ /dev/null @@ -1,429 +0,0 @@ - -MUMATH%.DOC documentation for the muMATH files on this disk - -These files are to be used with the muMATH/muSIMP symbolic -mathematics system. I will assume that anyone reading this -has at least a minimal familiarity with that system. The -files have been named according to the usual muSIMP scheme to -display their dependences upon each other. Most of the files -are intended as enhancements or replacements for files fur- -nished with muMATH. I recommend that you keep the original -files and give the new files different names, since you may -sometimes want to use the old version instead of the new one. - -These files will allow many calculations to be done that could -not be done with the original muMATH release. When PBRCH is -non-false (so that picking a branch for a multi-valued function -is expected), the calculation of #I^(2/3) as 1/2 + 3^(1/2)*#I/2 -can be carried out. Formulas for the solution of third and -fourth degree equations are included. Exact values of many -more of the trig functions can be obtained; for example -COS(#PI/16) and SIN(11*#PI/15). Evaluation of the inverse -trig functions are included, so that calculations like -DEFINT(1/(1+X^2),X,MINF,PINF) can be done (answer: #PI). -Also,values for the error function have been added, so that -DEFINT(#E^-X^2,X,MINF,PINF) can be calculated. Many of the -most common infinite series can be evaluated. - -Most of the files furnished here cannot be loaded as-is by -muSIMP. I have included the character `%' in the names of -such files: muSIMP will not load a file containing it unless -the % is doubled. Instructions for creating a RDS-able file -from the %-file are contained at the beginning of the file. -Normally this is involves merging the file with one of the old -muMATH files, using a text editor. - -Descriptions of the new files and/or the differences in the -new versions are given below. I have included many -calculator-mode examples. When you have loaded a new file, -I recommend that you try at least a couple of the examples for -that file to make sure it is working properly. - -I would be interested in hearing from other users of muMATH, -especially those who have written programs to do non-trivial -mathematical tasks. My address: Gerald Edgar, 107 W. Dodridge -St., Columbus, OH 43202. Perhaps we can exchange programs -(hard copy form, or even on disk - 8" CP/M only, please). - -G. A. Edgar -March 1, 1982 - -============================================================ -ARITH.MUS - -This file is a replacement for the existing ARITH.MUS. The -only difference is in evaluation of powers #I^R when PBRCH -is non-false and the exponent is rational. In that case, -#I^R is replaced by a complex exponential. Example: - - ? #I^(2/3); - @: #E ^ (#I*#PI/3) - - ? TRGEXPD: -7; - @: -7 - - ? #I^(2/3); - @: #I*SIN(#PI/3) + COS(#PI/3) - -With TRGNEG, we get: - - ? #I^(2/3); - @: 1/2 + 3^(1/2)*#I/2 - - -============================================================ -SOLVE4.EQN - -The file SOLVE4.EQN replaces SOLVE.EQN. It was constructed by -adding the formulas for third and fourth degree equations to -SOLVE.EQN. Usage is the same as described in the manual. (In -some of the following examples, the new version of ARITH.MUS -has made a difference.) - - ? SOLVE(9*X^3-3*X^2-8*X+4==0,X); - @: {X == -1, - X == 2/3+5*#I/(3^(1/2)*6)-3^(1/2)*5*#I/18} - - ? EXPD(@); - @: {X == -1, - X == 2/3} - - ? EXPD((X-1)*(X-2)*(X-3)*(X-4)); - @: 24 - 50*X + 35*X^2 - 10*X^3 + X^4 - - ? SOLVE(@,X); - @: {X == 4, - X == 1, - X == 3, - X == 2} - - ? EXPD((X-1)*(X+1)*(X+3)); - @: -3 - X + 3*X^2 + X^3 - - ? SOLVE(@,X); - @: {X == -1+6/(3^(3/2)*#E^(#I*#PI/6))+2*#E^(#I*#PI/6)/ - 3^(1/2), - X == -1-1/(3^(1/2)*#E^(#I*#PI/6))-#E^(#I*#PI/6)/ - 3^(1/2)+#I/#E^(#I*#PI/6)-#E^(#I*#PI/6)*#I, - X == -1-1/(3^(1/2)*#E^(#I*#PI/6))-#E^(#I*#PI/6)/ - 3^(1/2)-#I/#E^(#I*#PI/6)+#E^(#I*#PI/6)*#I} - - ? TRGEXPD(@,-7); - @: {X == 1-#I/3^(1/2)+#I/3^(1/2), - X == -1, - X == -3} - - ? EXPD(@); - @: {X == 1, - X == -1, - X == -3} - -Of course, this last example used file TRGNEG.ALG for the -evaluation of the complex exponentials. - -This file is not as useful as you might expect at first. I -must admit that the above examples are contrived so that they -will look good. To see an example where the formulas do not -work well, try EXPD((X-1)*(X-2)*(X+4)); and then SOLVE(@,X); -Can you get muMATH to simplify these roots to 1, 2, and -4 ? -Can you even tell which root is 1 ? - - -============================================================ -TRGNEG.ALG - -This is a replacement for the existing TRGNEG.ALG. Exact -evaluation of many more functions is now possible. SIN and COS -of rational multiples of #PI, where the denominator is a power -of 2 possibly multiplied by 3 or 5 (or both) are included. -These are cases that can be evaluated using only square roots. -(I have not included all such angles that are theoretically -possible, such as #PI/17 and #PI/65537.) Examples: - - ? DENNUM: -6; - @: -6 - - ? COS(2*#PI/5); - @: -1/4 + 5^(1/2)/4 - - ? COS(#PI/16); - @: (2^(3/4)+(1+2^(1/2))^(1/2))^(1/2) / 2^(7/8) - - ? SIN(11*#PI/15); - @: (7-5^(1/2)+(30-5^(1/2)*6)^(1/2))^(1/2) / 4 - - -============================================================ -ATRG.TRG - -This file handles inverse trigonometric functions. It depends -on TRGNEG.ALG. - -The functions in this file are: - - ASIN(X) arc sine of X - ACOS(X) arc cosine of X - ATAN(X) arc tangent of X - ACOT(X) arc cotangent of X - ASEC(X) arc secant of X - ACSC(X) arc cosecant of X - -Firstly, if PBRCH is non-false, these functions are all written -in terms of ASIN and ATAN. Example: - - ? ACOS(U); - @: #PI/2 - ASIN(U) - -Certain elementary reductions are carried out: - - ? ATAN(TAN(U)); - @: U - - ? ACOS(SIN(X)); - @: #PI/2 - X - -Inverse trig functions are evaluated in a few cases. (I -have essentially just included a list of the cases in the -program, probably not a very good algorithm.) - - ? ASIN(1/2); - @: #PI / 6 - - ? ASEC(2^(1/2)); - @: #PI / 4 - - ? ATAN(MINF); - @: -#PI / 2 - -This is useful in connection with some of the other files: - - ? DEFINT(1/(1+X+X^2),X,-1/2,0); - @: #PI / 3^(3/2) - - ? DEFINT(1/(1+X^2),X,MINF,PINF); - @: #PI - -This feature is helpful also with SERIES.DIF, described below. - -When TRGEXPD is a positive multiple of 7, inverse trigonometric -functions are converted to expressions involving logarithms: - - ? ATAN(U); - @: ATAN (U) - - ? TRGEXPD(@,7); - @: #I*LN((#I+U)/(#I-U)) / 2 - -The reverse transformation is described below in file LOG.ALG. - - -============================================================ -LOG.ALG - -This file contains only one new feature. I can't think of a -situation in which to use it; I have included it only because -it is the logical reverse of a feature of ATRG.TRG, above. - -In file ATRG, inverse trig functions are replaced by logarithms -when TRGEXPD is a positive multiple of 7. In this file, the -reverse can be done. If TRGEXPD is a negative multiple of -7, then natural logarithms are converted to inverse trig -functions. Example: - - ? A:LOG(U); - @: LN(U) - - ? TRGEXPD: -7; - @: -7 - - ? EVAL(A); - @: 2 * #I * ATAN((#I-#I*U)/(1+U)) - - -============================================================ -INT.DIF and LIM.DIF - -There are minor changes in these files to take into account -the error function ERF. Examples: - - ? ERF(0); - @: 0 - - ? ERF(MINF); - @: -1 - -The following example is done with INT.DIF, INTMORE.INT, -LIM.DIF, and LOG.ALG (for those with a lot of memory): - - ? DEFINT(#E^-X^2,X,MINF,PINF); - @: #PI ^ (1/2) - - -============================================================ -SERIES.DIF - -This file is a replacement for the existing file SIGMA.ALG. -Usage of SIGMA and PROD are as described in the manual. The -file has been completely rewritten. Notice that SERIES -requires DIF.ALG and is larger than SIGMA. All of the series -that SIGMA can do and several of the most common infinite -series can be summed. - -The program may ask questions in the manner of LIM in order to -determine which method to use or to determine whether a series -converges. The files LOG.ALG, TRGNEG.ALG, and ATRG.TRG may be -useful with this file. Some of the examples below were done -with the help of these additional files. - - ? SIGMA(N^2*3^N,N,1,K); - @: -3/2 + 3^(1+K)*K + 3^(1+K)*K^2/2 - 3^(2+K)*K/2 + - 3^(1+K)/2 - 3^(3+K)/4 + 3^(3+K)/4 - - ? SIGMA((-1)^N*X^(2*N+1)/(2*N+1)!,N,0,PINF); - @: - ??? - X^2 ??? - ENTER SIGN (0 + -)? - - SIN(X) - - ? SIGMA(2^N/(4*N-1)!,N,3,PINF); - @: -421/1260 - SIN(2^(1/4))/2^(3/4) - 2^(1/4)/(4* - #E^2^(1/4)) + 2^(1/4)*#E^2^(1/4)/4 - - ? SIGMA((-1)^N/N,N,1,PINF); - @: - LN(2) - - ? SIGMA(X^N/(2*N+3),N,1,PINF); - @: - ??? 1 + X ??? - ENTER SIGN (0 + -)? + - - ??? 1 - X ??? - ENTER SIGN (0 + -)? + - - ??? X ??? - ENTER SIGN (0 + -)? + - -1/3 - LN(1-X^(1/2))/(2*X^(3/2)) + LN(1+X^(1/2))/(2* - X^(3/2)) - 1/X - - ? SIGMA((-1)^N/(3*N+1),N,1,PINF); - @: -1 + #PI/3^(3/2) + LN(2)/3 - - ? SIGMA(N^2/((2*N+1)*4^N),N,0,PINF); - @: -1/9 + LN(3/2)/4 - LN(1/2)/4 - - ? LOGEXPD(@,30); - @: -1/9 + LN(3)/4 - -Without LOG.ALG: - - ? SIGMA(N*X^N/N!,N,0,PINF); - @: #E^X * X * LOG(#E,#E) - -Try this one to see an impressive-looking answer: - - ? SIGMA((-1)^N/(5*N+2),N,0,PINF); - - -============================================================ - -In addition to these descriptions, let me list a few bugs (or -misprints - the distinction is a bit fuzzy here) in muMATH -(at least in version 2.12). - -1. In file DIF.ALG, in the function beginning - - PROPERTY DIF, DEFINT, - - the line just before ENDFUN should end - - EVSUB(EX1,EX2,EX3), - - For example, - - ? DIF( DEFINT(F(T),T,X,0), X ); - - should yield - - @: -F(X) - - not - - @: -F(T) - -2. In file LIM.DIF, in the function beginning - - PROPERTY LIM, !, - - (near the end of the file), the second line should - contain - - EX1:LIM1(EX1,#LIM), - - rather than - - EX1:LIM(EX1,#LIM), - -3. Also in file LIM.DIF, the handling of LIM with only one - argument supplied is not as specified in the manual. - For example, try the following: - - ? LIM(R+S); - @: ? - - ? LIM((X-X^2)/(1-X)); - @: 0 - - If you get these (wrong) answers, here is a fix: In - FUNCTION LIM , move the four lines between BLOCK and - ENDBLOCK (inclusive) to the beginning (just before - `LOGBAS: #E,') and then just after these four lines - (still before `LOGBAS: #E,') add a new line: - - WHEN NOT INDET, LIM1(EX1,#LIM) EXIT, - - Now you should get the correct answers: - - ? LIM(R+S); - @: R + S - - ? LIM((X-X^2)/(1-X)); - @: (X-X^2) / (1-X) - -4. This one is not really a bug, but it will speed up LIM - involving exponents when LOG.ALG is not loaded. In - FUNCTION LIM , change - - LOGEXPD: 70, - - to - - LOGEXPD: 10, - - then in PROPERTY LIM, ^, at the beginning (just after the - comment % Fluid vars ... % ) add five new lines: - - BLOCK - WHEN FREE(EX3,INDET) OR FREE(EX4,INDET), - EX2:EX4, EX1:EX3 EXIT, - EX2:EX4*LOG(EX3,#E), EX1:#E, - ENDBLOCK, - - and finally change the next-to-last line (just before - ENDFUN) from - - EX1^EX2, - - to - - LIM1(EX3,#LIM)^LIM1(EX4,#LIM), - - -5. In the manual, page 9-4, item 4. near the top of the - page, the second sentence should begin - - When TRGEXPD is a negative multiple of 7, - - The correct information is given on page 9-28. - -============================================================= - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/MUSIMP.COM b/software/CPM/CPM_MC_5/MUSIMP.COM deleted file mode 100644 index ba0617c..0000000 Binary files a/software/CPM/CPM_MC_5/MUSIMP.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_5/MUSIMP.OBJ b/software/CPM/CPM_MC_5/MUSIMP.OBJ deleted file mode 100644 index 42a9637..0000000 Binary files a/software/CPM/CPM_MC_5/MUSIMP.OBJ and /dev/null differ diff --git a/software/CPM/CPM_MC_5/PI.MU b/software/CPM/CPM_MC_5/PI.MU deleted file mode 100644 index f44e425..0000000 Binary files a/software/CPM/CPM_MC_5/PI.MU and /dev/null differ diff --git a/software/CPM/CPM_MC_5/PLES1.TRA b/software/CPM/CPM_MC_5/PLES1.TRA deleted file mode 100644 index 6e9f93b..0000000 --- a/software/CPM/CPM_MC_5/PLES1.TRA +++ /dev/null @@ -1,578 +0,0 @@ -%File: PLES1.TRA (c) 09/24/80 - The Soft Warehouse % - -MATHTRACE: FALSE $ -RFFIRST: 'RFFIRST $ - -MOVD (PRINT, #PRINT) $ -FUNCTION PRINT (EX1), - WHEN ATOM (EX1), #PRINT (EX1) EXIT, - #PRINT (LPAR), PRINT (FIRST (EX1)), #PRINT (" . "), - PRINT (REST (EX1)), #PRINT (RPAR), EX1, -ENDFUN $ - -MOVD (PRINTLINE, #PRINTLINE) $ -FUNCTION PRINTLINE (EX1), - PRINT (EX1), NEWLINE (), EX1, -ENDFUN $ -NEWLINE: 1$ ECHO: TRUE $ - -% This is the first of a sequence of -interactive lessons about muSIMP -programming. It presumes as a minimum -that you have read section 8 of the -muSIMP/muMATH Reference Manual. Also -the first part of CLES1.ARI should be -completed since it explains the -mechanics of how to interact with the -lessons. The file TRACE.MUS should be -loaded. - - muSIMP supplies a number of built- -in functions and operators. The -calculator-mode lessons introduced a -few of these, such as RDS, RECLAIM, +, -*, etc. These progamming-mode lessons -introduce more built-in functions and -operators, but more important, the -lessons reveal how to supplement the -built-in functions and operators with -definitions of your own, thus extending -muSIMP itself. - - It is important to realize that, -until the last programming-mode -lessons, we will not deal with muMATH. -Instead we deal first with muSIMP, the -language in which muMATH is written. -The illustrative examples for these -first few lessons are utterly different -from muMATH, because we want to suggest -a few of the many other applications -for which muSIMP is especially well -suited, and because we want these -lessons to be comprehensible regardless -of math training level. - - Data is what programs operate upon. -The most primitive UNSTRUCTURED muSIMP -data are integers and names, -collectively called ATOMS to suggest -their indivisibility by ordinary means. -Some programs must distinguish these -two types of atoms, so there are two -corresponding RECOGNIZER functions: % - -INTEGER (X76#) ; NAME (X76#) ; EG: -3271 $ INTEGER (EG) ; NAME (EG) ; -% Do you suppose that "137", " ", "", -and "X + 3", with the quotation marks -included, are integers, names, or -invalid? Find out for yourself% RDS: -FALSE $ -% Data can be stored in the computer's -memory. The location at which a data -item is stored is called its ADDRESS. -An address is analogous to a street -address on the outside of a mailbox. -The data stored there is analogous to -mail inside the mailbox. As with a row -of mailboxes, the contents of computer -memory can change over time. - - There are useful programs which -deal only with unstructured data, but -the most interesting applications -involve aggregates of primitive data -elements. One way to make an aggregate -of 2 data elements is to use a -structural data element called a NODE, -which stores the addresses of the 2 -data elements. Thus, a node is "data" -consisting of addresses of 2 other data -items. - - For example, suppose that we wish -to represent the aggregate consisting -of the name BILBO and his age 31. We -could store the name BILBO beginning at -location 7, the number 31 beginning at -location 2, and the node beginning at -location 4. Then, begining at location -4, there would be stored the addresses -7 and 2, as illustrated in the -following diagram: - - 1 2 3 4 5 6 7 ----+-----+-----+-----+-----+-----+----- - ! 31 ! ! 7 ! 2 ! !BILBO ----+-----+-----+-----+-----+-----+----- - - The specific placement of data -within memory is managed automatically, -so all we are concerned about is the -specific name and number values and the -connectivity of the aggregates. Thus, -for our purposes it is best to suppress -the irrelevant distracting detail -associated with the specific addresses. -The following diagram is one helpful -way to portray only what we are -concerned about: - - +----+----+ - ! / ! \ ! - +-/--+--\-+ - / \ - BILBO 31 - - This imagery suggests the word -"pointers" for the addresses stored in -nodes. - - If you have seen one bisected box -you have seen them all, so to reduce -the clutter and thus emphasize the -essential features, we henceforth -represent such nodes by a mere vertex -in our diagrams, giving schematics such -as - - /\ - / \ - BILBO 31 - - Although most muSIMP programs use -such aggregates internally, many muSIMP -programs are designed to read and print -data in whatever specialized notation -is most suitable for the application. -For example, muMATH uses operator and -functional notation. - - Suppose however that we want to -specify such aggregates directly in -input and output. How can we do it? -If we have a nice graphics terminal, -then then we conveniently could use -diagrams such as the above. Most of us -do not have nice graphics terminals, so -we must use another external -representation. For this purpose -muSIMP uses a representation consisting -of the first data item, followed by the -second data item, separated by a dot -and spaces, all enclosed in a pair of -matching parentheses. For example: - - (BILBO . 31) - - We call this representation of a -node a DOTTED PAIR. However, this is a -diferent use of parentheses and periods -from how they are otherwise used in -muSIMP input, so we must preceed the -dotted pair by the single-quote prefix -operator to indicate to the parser that -we are using dotted-pair notation -rather than the usual operator or -functional notation: - - '(BILBO . 31) - - Moreover, we must use an ampersand -rather than a semicolon as the -expression-terminator in order to -inform the driver to print the -expression as a dotted pair rather than -attempt to print it using operator and -functional notation. We say "attempt" -because not all dotted pairs are -appropriate for operator or functional -printing, as we will explain in the -last lessons. Here then is an example -of dotted-pair input and printing: % - -'(78 . TROMBONES) & -% Try a few of your own, and note what -happens when you forget the single- -quote or use a semicolon rather than an -ampersand: % -RDS: FALSE $ -% What about when we want to -represent an aggregate of more than two -atomic data elements? For example, -what if we want to include BILBO's last -name, BAGGINS? Well, we can let one of -the pointers of a node point to another -node, whose first pointer points to -BILBO and whose other pointer points to -BAGGINS. For example: - - /\ - / \ - /\ 31 - / \ - BILBO BAGGINS - - We can input this as a dotted pair -nested within a dotted pair: % - -'((BILBO . BAGGINS) . 31) & -% Note that we only quote the -outermost dotted pair. Now suppose -that we want to also include BILBO's -species, structured as follows: - - /\ - / \ - /\ HOBBIT - / \ - /\ 31 - / \ - BILBO BAGGINS - - How would you input that? - Remember, your input must be -terminated by an ampersand. -% RDS: FALSE $ -% We would input it as: % - -EG: '(((BILBO . BAGGINS) . 31) . HOBBIT) & - -% An alternative structure for this -information is the one corresponding to -the input - '((BILBO . BAGGINS) . (31 . HOBBIT)). - -On a piece of scratch paper, sketch the -corresponding diagram, then hold it -close to my face so I can check it. - - ----- - / O^O \ - \ \-/ / - \---/ - -% RDS: FALSE $ -% My eyes must be getting bad, I -couldn't see it. Oh well... - - Since either element of a dotted -pair can be a dotted pair, they can be -used to represent arbitrary "binary -tree structures". Moreover, although -perhaps unprintable using pure dotted- -pair notation, linked networks of -binary nodes can be used to represent -any data-structure whatsoever. - - In order to do anything interesting -with data aggregates, a program must be -able to extract their parts. -Accordingly, there are a pair of -SELECTOR functions named FIRST and REST -which respectively return the left and -right pointers in a node. For example: -% - -REST (EG) & FIRST (EG) & FIRST (FIRST (EG)) & REST (FIRST (EG)) & -% See if you can extract BILBO and -BAGGINS from EG, using nested -compositions of FIRST and/or REST: % -RDS: FALSE $ -% Our answers are: % -FIRST (FIRST (FIRST (EG))) & REST (FIRST (FIRST (EG))) & -% Deeply nested function invocations -become difficult to type and read, so -let's define our first muSIMP function -named FFFIRST, so that FFFIRST (EG) -could be used as shorthand for the -first of the above two examples and for -any analogous example thereafter: % - -FUNCTION FFFIRST (U), - FIRST (FIRST (FIRST (U))) -ENDFUN & -% If you are not using a hard-copy -terminal, jot down this function -definition and all subsequent ones for -reference later in the lesson. - - Despite the word ENDFUN, the fun -has just begun: Now that FFFIRST is -defined, we can apply it at any -subsequent time during the dialogue. -For example: % -FFFIRST (EG) & -FFFIRST ('(((BIG . MAC) . CATSUP) . (FRENCH . FRIES))) & -% Using the definition of FFFIRST as -a model, define a function named -RFFIRST which extracts the REST of the -FIRST of the FIRST of its argument, -then test RFFIRST on EG: % RDS: FALSE -$ -% Our solution is: % - -FUNCTION RFFIRST (FOO), - REST (FIRST (FIRST (FOO))), -ENDFUN & -RFFIRST (EG) & -% The name FOO in the definition is -called a PARAMETER, whereas EG where -the function is applied is an example -of an ARGUMENT. We can use any name -for a parameter -- even a name which -has been bound to a value or even the -same name as an argument. The name is -merely used as a "dummy variable" to -help indicate what to do to an argument -when the function is subsequently -applied. A function definition is like -a recipe. It is filed away, without -actually being EXECUTED until applied -to actual arguments. - - As another simple example, since an -atom is defined as being either a name -or an integer, it is convenient to have -a recognizer function for atoms, so -that we do not have to test separately -for names and atoms when we do not care -which type of atom is involved. We -could define this recognizer as -follows: - -FUNCTION ATOM (U), - NAME (U) OR NUMBER (U) -ENDFUN & - - Actually, ATOM is already built- -into muSIMP, but the example provides a -good opportunity to introduce the -built-in infix OR operator, which -returns FALSE if both of its operands -are FALSE, returning TRUE otherwise. -Try out ATOM on the examples -5, X and -EG % RDS: FALSE $ -% Analogous to OR, there is a built- -in infix AND operator which returns -FALSE if either operand is FALSE, -returning TRUE otherwise. There is -also a built-in prefix NOT operator -which returns TRUE if its operand is -FALSE, returning FALSE otherwise. -Knowing this, see if you can define a -recognizer named NODE, which returns -TRUE if its argument is a node, -returning FALSE otherwise: % RDS: -FALSE $ -% In programming there is rarely, if -ever, one unique solution, but ours is: -% - -FUNCTION NODE (U), - NOT ATOM (U) -ENDFUN & -NODE (EG) & -NODE (5) & -% So much for trivial exercises. Now -let's write a function which counts the -number of atoms in its argument. We -will count each instance of each atom, -even if some atoms occur more than -once. - - At first this may seem like a -formidable task, because a tree can be -arbitrarily branched. How can we -anticipate ahead of time all of these -possibilities. Well, let's -procrastinate by disposing of the most -trivial cases even though we can't yet -see the whole solution: If the -argument is an atom, then there is -exactly 1 atom in it. - - So much for trivial cases. We -haven't yet solved the whole problem, -but it builds our self-confidence to -make progress, so that is a good -psychological reason for first -disposing of the easy cases. Also, -with the easy cases out of the way, we -can turn our full intellectual powers -on the harder cases, unfettered by any -distractions to trivial loose ends. - - We are left with the case where we -know we have a node. Perhaps we could -somehow subdivide the problem into -smaller cases? - - Let's see ... Nodes have a FIRST -part and a REST part, so perhaps that -provides the natural subdivision. Hmmm -... - - If we knew the number of atoms for -the left part and the number for the -right part, clearly the number for the -whole aggregate is merely their sum. -But how can we find out the number of -atoms in these parts? Why not -RECURSIVELY use the very function we -are defining to determine these two -contributions! - - It may sound like cheating to refer -to the function we are defining from -with the definition itself, but -remembering that the definition is not -actually APPLIED until sometime after -its definition is complete, perhaps it -will work. We are working in a highly -interactive environment, so the -quickest way to resolve questions about -muSIMP is to try it and see! Here then -is a formal muSIMP function definition -corresponding the the above informal -English "algorithm": % - -FUNCTION #ATOMS (U), - WHEN ATOM (U), 1 EXIT, - #ATOMS (FIRST(U)) + #ATOMS (REST(U)) -ENDFUN & -% Here we introduce 2 new concepts: - - The BODY of a function definition -can consist of a sequence of one or -more expressions separated by commas. -A CONDITIONAL-EXIT is an expression -consisting of a sequence of one or more -expressions nested between the matching -pair of words WHEN and EXIT. When a -function definition is APPLIED, the -expressions in its body are evaluated -sequentially, until perhaps a -conditional exit causes an exit from -the procedure or until the delimiter -named ENDFUN is reached. - - For a conditional exit, the first -expression after the word WHEN is -evaluated. If the value is FALSE, then -evaluation proceeds to the point -immediately following the matching -delimiter named EXIT. Otherwise, -evaluation proceeds sequentially -through the remaining expressions in -the conditional exit, if any, exactly -as if the body of the conditional exit -replaced that of the function. The -value of a conditional exit is that of -the last expression evaluated therein, -and the value returned by a function is -that of the last expression evaluated -therein when the function is applied. - - Thus, #ATOMS immediately returns -the value 1 whenever the argument is an -atom, and otherwise the function breaks -the problems into two parts which are -necessarily smaller, hence closer to -being atoms. Let's test it, starting -with trivial cases first: % - -#ATOMS (FOO) & #ATOMS (5) & EG & #ATOMS (EG) & -% It looks promising, but it is still -perhaps mysterious how muSIMP and -#ATOMS keep track of all of these -recursive function invocations. Since -the trace package is supposedly loaded, -to trace the execution of #ATOMS, we -merely issue the command: % - -TRACE (#ATOMS) & -% Now every time #ATOMS is entered, -it prints its name and argument values, -whereas every time it is exited, it -prints its name followed by an equal -sign, followed by the returned value. -Moreover, the trace is indented in a -manner which allows corresponding -entries and exits to be visually -associated. Watch: % - -#ATOMS (FOO) & EG & #ATOMS (EG) & -% Try a few examples of your own, -until these new ideas begin to gel: % -RDS: FALSE $ - -UNTRACE (#ATOMS) & #ATOMS (FOO) & -% Here is a function which counts -only the number of integers in its -argument: % - -FUNCTION #INTEGERS (U), - WHEN INTEGER (U), 1 EXIT, - WHEN NAME (U), 0 EXIT, - #INTEGERS (FIRST(U)) + #INTEGERS (REST(U)) -ENDFUN $ -EG & #INTEGERS (EG) ; -% Now, using it as a model, try -writing a function named #NAMES, which -returns the number of names in its -argument. If your first syntactically -accepted attempt fails any test, try -using TRACE to reveal the reason why: -% RDS: FALSE $ -% Our solution is ... - - On second thought, we won't give -you our solution. Consequently, if you -were lazy and didn't try, you had -better try now, because the examples -will get steadily harder now. % RDS: -FALSE $ -% The HEIGHT of an atom is 1, and the -HEIGHT of a node is 1 more than the -maximum of the two heights of its FIRST -and REST parts. Accordingly, let's -first write a function named MAX, which -returns the maximum of its two integer -arguments. There is a built-in infix -integer comparator named ">", so here -is a hint: - -FUNCTION MAX (INT1, INT2), - WHEN INT1 > INT2, ... EXIT, - ... -ENDFUN $ - -Enter such a definition, with -appropriate substitutions for the -missing portions, then test your -function to make sure it works -correctly: % RDS: FALSE $ -% Now, with the help of our friend -MAX, see if you can write a function -named HEIGHT, which returns the height -of its argument: % -RDS: FALSE $ -% Our solution is: % - -FUNCTION HEIGHT (U), - WHEN ATOM (U), 1 EXIT, - 1 + MAX (HEIGHT(FIRST(U)), HEIGHT(REST(U))) -ENDFUN $ -% This brings us to the end of the -first programming-mode lessons. It may -be a good idea to review this lesson -before proceeding to lesson PLES2.TRA. -% - -ECHO: FALSE$ NEWLINE: 0$ -MOVD (#PRINT, PRINT)$ -MOVD (#PRINTLINE, PRINTLINE)$ -RDS ()$ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/PLES2.TRA b/software/CPM/CPM_MC_5/PLES2.TRA deleted file mode 100644 index e424c8c..0000000 --- a/software/CPM/CPM_MC_5/PLES2.TRA +++ /dev/null @@ -1,297 +0,0 @@ -%File: PLES2.TRA (c) 09/24/80 - The Soft Warehouse % - -MATHTRACE: FALSE $ -MOVD (PRINT, #PRINT) $ - -FUNCTION PRINT (EX1), - WHEN ATOM (EX1), #PRINT (EX1) EXIT, - #PRINT (LPAR), PRINT (FIRST(EX1)), #PRINT (" . "), - PRINT (REST(EX1)), #PRINT (RPAR), EX1, -ENDFUN $ - -MOVD (PRINTLINE, #PRINTLINE) $ -FUNCTION PRINTLINE (EX1), - PRINT (EX1), NEWLINE (), EX1, -ENDFUN $ - -NEWLINE: 1$ ECHO: TRUE $ -% This is the second of a sequence of -muSIMP programming lessons. - - EQ is a primitive muSIMP Comparator -operator which returns TRUE if its two -operands are the same object or equal -integers, returning FALSE otherwise: % - -FIVE: 5 $ 5 EQ FIVE ; -% Names are stored uniquely, so two -occurences of a name must involve the -same address: % - -ACTOR: 'BOGART ; ACTOR EQ 'BOGART ; -% Here is an example of two different -references to the same physical node: -% - -DATE: '(JULY . 4) & FOO: DATE $ FOO EQ DATE ; -% However, watch this: % - -DATE EQ '(JULY . 4) ; -% What happened? The two aggregates -are DUPLICATES, but since they were -independently formed they do not start -with the same node. In fact, only the -name JULY is shared among them, as -shown below: - - second - DATE argument - /\ /\ - / \ / \ - ! \ \ - ! / \ \ - JULY 4 4 - - Clearly it is desirable to have a -more comprehensive equality comparator -which also returns TRUE for aggregates -which are duplicates in the sense of -printing similarly. Let's write such a -function, called DUP. Following the -general advice given in PLES1, let's -first dispose of the trivial cases: - - If either argument is an atom, then -they are duplicates if and only if they -are EQ. - - Otherwise, they are both nodes, -which is the nontrivial case. Now, -let's employ our "divide-and-conquer" -strategem, using FIRST and REST as the -partitioning. Two nodes refer to -duplicate aggregates if and only if the -FIRST parts are duplicates and the REST -parts are duplicates. Moreover, that -can be tested with our beloved -recursion, using DUP itself! - - See if you can write a -corresponding function named DUP: % -RDS: FALSE $ -% There are many possible variants, -but here is one of the most compact: % - -FUNCTION DUP (U, V), - WHEN ATOM (U), U EQ V EXIT, - WHEN ATOM (V), FALSE EXIT, - WHEN DUP (FIRST(U), FIRST(V)), DUP (REST(U), REST(V)) EXIT, -ENDFUN $ -% An interesting challenge for your -spare time is to see how many different -but reasonable ways this function can -be written. - - Actually, there already is a built- -in infix operator named "=", which is -equivalent to DUP: % - -DATE: '(JULY . 4) $ -DATE = '(JULY . 4) ; -% Do you feel DUPed to learn that an -exercise duplicated an existing -facility? - - It is crucial to understand exactly -what the existing facilities do, and -the best way to learn that is to -understand how they work by creating -them independently. - - Here is a good exercise: See if -you can write a comparator function -named SAMESHAPE, which returns TRUE if -its two arguments are similar in the -sense of having nodes and atoms at -similar places. For example, - -SAMESHAPE ('((KINGS . ROOK) . 5), - '((QUEENS . 3) . PAWN)) - -is TRUE: % RDS: FALSE $ -% This is one of those instances -where we will not give the answer. - - Now, using the infix operator named -"=", see if you can write a function -named CONTAINS which returns TRUE if -its first argument is a duplicate of -its second argument or contains a -duplicate of its second argument. For -example, - - ((JULY . 4) . (1931 . FRIDAY)) - -contains (1931 . FRIDAY). It is at -least as hard as DUP, so take your time -and don't give up easily. % RDS: -FALSE $ -% Here is a harder exercise: The two -aggregates - - /\ /\ - / \ / \ - CARBON /\ CARBON /\ - / \ / \ - SULFUR IRON IRON SULFUR - -are ISOMERS because they are either the -same atom or at every level either the -left branches are isomers and the right -branches are isomers, or the left -branch of one is an isomer of the right -branch of the other and vice-versa. -Write a corresponding comparator -function named ISOMERS. (It's similar -to DUP, with a twist.) % RDS: FALSE $ -% Our answer is: % - -FUNCTION ISOMERS (U, V), - WHEN ATOM (U), U EQ V EXIT, - WHEN ATOM (V), FALSE EXIT, - ISOMERS (FIRST(U), FIRST(V)) AND ISOMERS (REST(U), REST(V)) - OR ISOMERS (FIRST(U), REST(V)) AND ISOMERS (REST(U), FIRST(V)) -ENDFUN $ - -% Because of all the combinations -which might have to be checked, the -execution time for this function can -grow quite quickly with depth. Try -tracing a few examples of moderate -depth: % RDS: FALSE $ -% So far our functions have merely -dismantled or analyzed aggregates given -to them as arguments. None of our -examples have constructed new -aggregates. The dot of course results -in aggregates, but this occurs as the -dot is read. Moreover, since the -single quote necessarily preceeding an -outermost dotted pair prevents -evaluation, bound variables in a dotted -pair contribute merely their names -rather than their values. For example: -% - -EG: 7 $ '(EG . 3) & -% What we want is a function which -evaluates its two arguments in the -usual way, then returns a node whose -two pointers point to those values. -There is such a function, named ADJOIN: -% - -ADJOIN (EG, 3) & -% A dotted pair within a function -definition is a static entity, frozen -at the time the function is defined. -In contrast, a reference to ADJOIN -within a function definition is -dynamic. The node creation is done -afresh, with the current values of its -arguments every time that part of the -function is applied. As an example of -the use of ADJOIN, let's write a -function named SKELETON, which -constructs a new tree which is -structurally similar to its argument -but has the name of length zero, "", -wherever its argument has an atom. -Thus, when printed, the new aggregate -will display the skeletal structure of -the aggregate without visually- -discernable atoms. For example, - - SKELETON - ('((HALLOWEEN . GHOSTS) . WITCHES)) - -will yield (( . ) . ) - - OK, let's recite the litany: What -comes first? - - TRIVIAL CASES. - - So, if the argument is an atom we -return what? - - "". - - Otherwise we have a node, which is -the most general case. However, nodes -have a FIRST and a REST, so can we -somehow recurse, using SKELETON on -these parts, then combine them? - - Yes, as follows: % - -FUNCTION SKELETON (U), - WHEN ATOM (U), "" EXIT, - ADJOIN (SKELETON (FIRST(U)), SKELETON (REST(U))) -ENDFUN $ -SKELETON ('((MOO . GOO) . (GUY . PAN))) & -% Easy. Yes? - - Now it is your turn. Write a -function named TREEREV, which produces -a copy of its argument in which every -left and right branch are interchanged -at every level. For example, - - TREEREV -('((MOO . GOO) . (GUY . (PAN . CAKE)))) - -should yield - (((CAKE . PAN) . GUY) . (GOO . MOO)) - -% RDS: FALSE $ -% If you didn't get the following -solution, you may groan when you see -how easy it is: % - -FUNCTION TREEREV (U), - WHEN ATOM (U), U EXIT, - ADJOIN (TREEREV (REST(U)), TREEREV (FIRST(U))) -ENDFUN & -TREEREV ('(("Isn't" . that) . easy)) & -% Here is a somewhat harder exercise: -Write a function named SUBST, which -returns a copy of its first argument -wherein every instance of its second -argument is replaced by its third -argument. For example, if - -PHRASE: - '(((THIS . (GOSH . DARN)) . CAR) - . (IS . ((GOSH . DARN) . BAD))) $ - -then - SUBST (PHRASE, '(GOSH . DARN), - '(expletive . deleted)) yields - -(((THIS . (expletive . deleted)) . CAR) -. (IS . ((expletive . deleted) . BAD))) -% RDS: FALSE $ -% That's all folks. - - The next lesson deals with a -special form of tree called a list. -Many people find lists more to their -liking, and perhaps you will too.% - -ECHO: FALSE$ NEWLINE: 0$ -MOVD (#PRINT, PRINT)$ -MOVD (#PRINTLINE, PRINTLINE)$ -RDS ()$ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/PLES3.TRA b/software/CPM/CPM_MC_5/PLES3.TRA deleted file mode 100644 index b7b8cf4..0000000 --- a/software/CPM/CPM_MC_5/PLES3.TRA +++ /dev/null @@ -1,441 +0,0 @@ -%File: PLES3.TRA (c) 09/24/80 - The Soft Warehouse % - -MATHTRACE: FALSE$ NEWLINE: 1$ ECHO: TRUE$ - -% This is the third in a series of -muSIMP programming lessons. - - Often, it is most natural to -represent a data aggregate as a -sequence or LIST of items rather than -as a general binary tree. For example, -such a sequence is quite natural for -the elements of a vector or of a set. -We can represent such a sequence in -terms of nodes by having all of the -FIRST cells point to the data elements, -using the REST cells to link the -sequence together. The last linkage -node can have a REST cell which is -FALSE to indicate that there are no -further linkage nodes: - - /\ - / \ - item1 /\ - / \ - item2 . - . - /\ - / \ - itemN FALSE - - - When this diagram is rotated 45 -degrees in the counter-clockwise -direction, it looks like a clothes line -with the successive data elements -suspended from it. - - +-------+-- - - - ---+----- FALSE - ! ! ! -item1 item2 itemN - - This latter diagram more clearly -suggests a sequence or list of items. -The simple regularity of the structure -permits correspondingly simple function -definitions for processing such -structures. Moreover, the linear -structure suggests an external printed -representation which is far more -readable than dotted pairs. In -response to an ampersand terminator, -muSIMP prints the above aggregate in -the more natural LIST notation: - - (item1 item2 ... itemN) - -rather than the equivalent dot notation - - (item1 . (item2 . ... - (itemN . FALSE) ... )) - - Conversely, the reader accepts -list notation as an alternative input -form to dot notation. Naturally, any -of the items in a list can themselves -be either lists or more general dotted -pairs. The printer uses list notation -as much as possible. Thus, a structure -of the form - - /\ - / \ - item1 /\ - / \ - item2 . - . - /\ - / \ - itemN atom - -where "atom" is not the atom FALSE, is -printed in a mixed notation as - - (item1 item2 ... (itemN . atom)) - -The muSIMP read routines will correctly -read such mixed notation. You may -wonder why you never noticed list -notation being output in PLES1 and -PLES2. At the beginning of those -lessons the function PRINT was -redefined so that it printed expression -entirely in dot notation. - - It is important to fully understand -the connection between dotted pairs and -lists, so take 5 minutes or so to type -in some lists, nested lists, nested -dotted pairs, and mixtures, noting -carefully how they print. % RDS: -FALSE $ -% Did your examples include: % - -'() & -% Is that surprising? Since FALSE is -used to signal the end of the list, -FALSE and the empty list must be -equivalent. % - -FALSE EQ '() & -% Clearly functions which -successively process each element of a -list must somehow determine when the -end of the list has been reached. This -TERMINAL CASE is easily achieved by an -equality test for the name FALSE. -Since the need for this test is so -pervasive in muSIMP, the empty list -recognizer EMPTY is written in machine -language for efficiency reasons. -However, it could be defined using an -EQ test as follows: - -FUNCTION EMPTY (LIS), - LIS EQ '(), -ENDFUN; - - Using EMPTY, see if you can define -a function named #ITEMS, which returns -the number of (top-level) items in its -list argument. For example, #ITEMS -('(FROG, (FRUIT . BAT), NEWT)) should -yield 3. Here is an incomplete -solution. All you have to do is enter -it with the portions marked "..." -appropriately filled. - -FUNCTION #ITEMS (LIS), - WHEN EMPTY (LIS), ... EXIT, - 1 + #ITEMS ( ... ) -ENDFUN $ - -% RDS: FALSE $ -% Actually, there is already a built- -in function called LENGTH, which -returns the length of a list. It is -somewhat more general in that it -returns the number of characters -necessary for printing when given an -atom. - - Note that with lists it is typical -to recur only on the REST of the list, -whereas with general binary trees it is -typical to recur on both the FIRST and -the REST. - - So far, the examples and exercises -have been relatively isolated ones. -Now we will focus on writing a -collection of functions which together -provide a significant applications -package: - - A list provides a natural -representation for a set. For example, -(MANGO, (CHOCOLATE . FUDGE), (ALFALFA, -SPROUTS)) can represent a set of three -foods. Using this representation, -let's write functions which test set -membership and form unions, -intersections, etc. - - First, write a function named ISIN, -which returns TRUE if its first -argument is in the list which is its -second argument, returning FALSE -otherwise: % RDS: FALSE $ -% Our solution is: % - -FUNCTION ISIN (U, LIS), - WHEN EMPTY (LIS), FALSE EXIT, - WHEN U = FIRST (LIS), EXIT, - ISIN (U, REST(LIS)) -ENDFUN $ -ISIN ('FROG, '(SALAMANDER NEWT TOAD)) ; -% Actually, there is already a built- -in version of ISIN called MEMBER. - - A set contains no duplicates, so we -really should have a recognizer -function named ISSET, which returns -TRUE if its list argument contains no -duplicates, returning FALSE otherwise. -Try to write such a function: % RDS: -FALSE $ -% Here is a hint, in case you gave -up: - -FUNCTION SET (LIS), - WHEN ... EXIT, - WHEN MEMBER (FIRST(LIS), ... ), - FALSE EXIT, - SET ( ... ) -ENDFUN; - -%RDS: FALSE $ -% In case it isn't clear by now, a -rule of this game is that you are free -(and encouraged) to use any functions -we have already discussed, whether they -are built-in, previous examples, or -previous exercises. That is one reason -it is adviseable for you to actually do -the exercises. - - Now write a function named SUBSET, -which returns TRUE if the set which is -its first argument is a subset of that -which is its second argument. -(Remember that every set is a subset of -itself and the empty set is a subset of -every set.) % RDS: FALSE $ -% Here is a hint, in case you gave up -or had a less compact solution: - -FUNCTION SUBSET (SET1, SET2), - WHEN ... EXIT, - WHEN MEMBER (FIRST(SET1), ...), - SUBSET( ...) EXIT -ENDFUN; - -%RDS: FALSE $ -% Two sets are equal if and only if -they contain the same elements. -However, the elements need not occur in -the same order. Write a corresponding -comparator function named EQSET: % -RDS: FALSE $ -% Ah yes, a hint perhaps?: - -FUNCTION EQSET (SET1, SET2), - ... -ENDFUN; % RDS: FALSE $ -% Do you think that's not much of a -hint? - - Well, the body of the function -really can be written with one modest -line, so try harder: % RDS: FALSE $ -% Remember the rules of the game: -You are encouraged to use any function -discussed previously: % - -FUNCTION EQSET (SET1, SET2), - SUBSET (SET1, SET2) - AND SUBSET (SET2, SET1) -ENDFUN; -% Our examples so far have merely -analyzed sets. We can use ADJOIN to -construct lists, just as we used ADJOIN -to construct binary trees. As an -example of this, write a function named -MAKESET, which returns a copy of its -list argument, except without -duplicates if there are any: % RDS: -FALSE $ -% If you need a hint, here is one, -but it is all you will get: - -FUNCTION MAKESET (LIS) - WHEN ..., '() EXIT, - WHEN MEMBER ( ... ), ... EXIT, - ADJOIN ( ... ) -ENDFUN; - -%RDS: FALSE $ -% Let's see if your solution works -correctly: % - -MAKESET ('(FROG, FROG, FROG)) & -% If there is a duplicate in the -answer, then back to the computer -terminal: % RDS: FALSE $ -% (It helps to think of nasty test -cases BEFORE you start programming). - - Now for the crowning glory of our -set package: The UNION of two sets is -defined as the set of all elements -which are in either (perhaps both) -sets. Give it a try: % RDS: FALSE $ -% A hint perhaps? Well, the function -body can be written in 3 lines, each of -which begins just like the -corresponding line in our hint for -MAKESET. % RDS: FALSE $ -% Here is our solution: % - -FUNCTION UNION (SET1, SET2), - WHEN EMPTY (SET1), SET2 EXIT, - WHEN MEMBER (FIRST(SET1), SET2), - UNION (REST(SET1), SET2) EXIT, - ADJOIN (FIRST(SET1), - UNION (REST(SET1), SET2)) -ENDFUN $ -UNION ('(DOG, CAT, 5, RAT), - '(-5, CAT, PIG, DOG))& -% The intersection of two sets is the -set of all elements which are in both -sets. Using our definition of UNION as -inspiration, write a corresponding -function for the intersection: % RDS: -FALSE $ -% So far, our set algebra package has -been developed in a so-called BOTTOM-UP -manner, with the most primitive -functions defined first, and with the -more sophisticated functions defined in -terms of them. The opposite approach -is TOP-DOWN, where we define the most -comprehensive functions in terms of -more primitive ones, then we define -those more primitive ones in terms of -still more primitive ones, until no -undefined functions remain. - - As an example of the top-down -attitude, let's write a SYMMETRIC -DIFFERENCE function for our set-algebra -package. The symmetric difference of -two sets is the set of all elements -which are in exactly one of the two -sets. This is in contrast to the -ordinary diference of two sets, which -is all of the elements that are in the -first set but not the second. - - However, if an ordinary difference -function was available, we could write -the symmetric difference as the union -of the ordinary difference between set1 -and set2, with the ordinary difference -between set2 and set1. We have already -written UNION, but an ordinary set -difference is not yet available. -Nevertheless, let's bravely proceed to -write the symmetric difference in terms -of the ordinary difference, then we -will worry about how to write the -latter: % - -FUNCTION SYMDIF (SET1, SET2), - UNION (ORDDIF (SET1, SET2), - ORDDIF (SET2, SET1)) -ENDFUN $ -% Now you try to write ORDDIF. It -may help you to know that it can be -written very similarly to UNION: % -RDS: FALSE $ -% Some programmers are initially -uncomfortable with the top-down -approach because it makes them nervous -to refer to undefined functions: there -are obvious loose ends during the -writing process. However, it is not -necessary to understand how an -auxiliary function can be written -before daring to refer to it. All that -is necessary is that the duty relegated -to the auxiliary function be somehow -more elementary than the overall duty -performed by the function which refers -to it. - - There are necessarily loose ends -during the writing of a program in any -sequential order. With the bottom-up -approach, the loose ends are neither -written nor referred to until lower- -level functions have been written. -Unfortunately, as such hidden loose -ends are revealed they often make -apparent the need to completely -reorganize and rewrite all subordinate -functions into a more suitable -organization. - - In contrast, the obvious loose -ends during a top-down development -provide invaluable clues about how to -organize the remaining functions. -Moreover, any subsequent changes tend -to be easier, because communication -between the functions is more -localized, more independent, and more -hierarchial. - - For example, we know that in the -definition of SYMDIF we are taking the -union of two DISJOINT sets, because -from the definition of ORDDIF it is -clear that ORDDIF (SET1, SET2) and -ORDDIF (SET2, SET1) cannot have -elements in common. Hence it would be -more efficient merely to append the -second ordinary set difference to the -first ordinary set difference, or vice- -versa. Unfortunately, ADJOIN does not -accomplish the desired effect. - - For example, - - ADJOIN ('(5, 9), '(3, 7)) - -yields ((5, 9), 3, 7) rather than the -desired (5, 9, 3, 7). What we must do -is ADJOIN 9 to (3, 7), then adjoin 5 to -that result. See if you can generalize -this process into a function named -APPEND, which returns a list consisting -of the list which is its first argument -appended onto the beginning of the list -which is its second argument:% RDS: -FALSE $ -% How about: % - -FUNCTION APPEND (LIS1, LIS2), - WHEN EMPTY (LIS1), LIS2 EXIT, - ADJOIN (FIRST(LIS1), - APPEND (REST(LIS1), LIS2)) -ENDFUN $ -% You may not be getting tired, but -my circuits are weary, so let's bring -this lesson to a close. % - -ECHO: FALSE$ NEWLINE: 0$ RDS ()$ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/PLES4.TRA b/software/CPM/CPM_MC_5/PLES4.TRA deleted file mode 100644 index b147842..0000000 --- a/software/CPM/CPM_MC_5/PLES4.TRA +++ /dev/null @@ -1,395 +0,0 @@ -%File: PLES4.TRA (c) 09/24/80 - The Soft Warehouse % - -MATHTRACE: FALSE$ NEWLINE: 1$ ECHO: TRUE$ -% This is the fourth in a series of -muSIMP programming lessons. - - Often within a function definition -it is necessary to DYNAMICALLY create a -list. Suppose we want to make a list -of the values of the variables -FIRSTNAME, LASTNAME, and MAILADDRESS. -It will not do to use the program -statement - - '(FIRSTNAME, LASTNAME, MAILADDRESS), - -because the quote operator prevents -evaluation of the variables. However, -the desired effect can be achieved by -the statement - -ADJOIN (FIRSTNAME, ADJOIN (LASTNAME, - ADJOIN (MAILADDRESS, '()))). - -muSIMP provides the function LIST to -achieve this effect much more compactly -and conveniently. Thus, the above list -could be created with the following -statement: - -LIST (FIRSTNAME, LASTNAME, MAILADDRESS) - - Unlike most functions, LIST can -have any arbitrary number of arguments. -For example consider the following -assignments: % - -FIRSTNAME: 'JOHN & -LASTNAME: 'DOE & -MAILADDRESS: 'TIMBUKTU & -% Create a list of these variables -using the quote operartor and compare -it with a list created using the -function LIST: % RDS: FALSE $ -% A useful utility to have is a -constructor function which reverses a -list. Writing such a function can be -somewhat tricky. The following -skeletal definition uses our friends -APPEND and LIST as helper functions: - -FUNCTION REVLIS (LIS), - WHEN ... , FALSE EXIT, - APPEND ( ... , LIST (FIRST (LIS))), -ENDFUN $ - -See if you can successfully complete -this definition. Naturally, you also -have to reenter APPEND if a correct -version is not around from the previous -lesson. (Remember to jot down all -function definitions if you are not -using a hard-copy terminal.) % -RDS:FALSE $ -% A well-written APPEND necessarily -requires execution time which is -approximately proportional to the -length of its first argument. The -REVLIS function outlined above invokes -APPEND n times if n is the length of -its original argument, and the average -length of the argument to APPEND is -n/2. Thus, the time is approximately -proportional to n*(n/2), which is -proportional to n^2. - - An technique using COLLECTION -VARIABLES permits a list to be reversed -in time proportional to n, yielding -tremendous time savings for long lists: -% - -FUNCTION REVLIS (LIS, ANS), - WHEN EMPTY (LIS), ANS EXIT, - REVLIS (REST(LIS), ADJOIN (FIRST(LIS), ANS)) -ENDFUN $ -TRACE (REVLIS) & -REVLIS ('(1, 2, 3)) & -% A collection variable accumulates -the answer during successive recursive -invocations. Then, the resulting value -is passed back through successive -levels as the returned answer. - - As is illustrated here, we can -invoke a function with fewer arguments -than there are parameters. When this -is done, the extra parameters are -initialized to FALSE, and they are -available for use as LOCAL VARIABLES -within the function body. Quite often, -as in this example, the initial value -of FALSE is exactly what we want, -because it also represents the empty -list. (When we want some other initial -value, either the user can supply it, -or the function can supply it to an -auxiliary function which does the -recursion.) - - Of course, if a user of REVLIS -supplies a second argument, then the -function returns the reversed first -argument appended onto the second -argument. This "feature" is -occasionally quite useful. - - What if the user supplies more -arguments than there are parameters? -The extra arguments are evaluated, but -ignored. - - Up to this point the lessons have -taught the "applicative" style of -programming. The emphasis has centered -on expression evaluation, functional -composition, and recursion. The power -and elegance of applicative programming -was the topic of an influential Turing -Lecture by J Backus. The lecture was -published in the August 1978 issue of -the Communications of the ACM. - - muSIMP also supports the -alternative "Von Neumann" style -emphasizing loops, assignments, and -other side-effects. To illustrate this -style, here is an alternative -definition of REVLIS which introduces -the LOOP construct: % - -FUNCTION REVLIS (LIS, ANS), - LOOP - WHEN EMPTY (LIS), ANS EXIT, - ANS: ADJOIN (FIRST(LIS), ANS), - LIS: REST (LIS) - ENDLOOP -ENDFUN $ -% muSIMP has a function named REVERSE -which is defined in machine language. -Since it is entirely equivalent to -REVLIS and much faster, REVERSE should -normally be used in place of REVLIS in -application programs written by the -user. - - An iterative loop is an expression -consisting of the keyword LOOP, -followed by a sequence of one or more -expressions separated by commas, -followed by the matching delimiter -named ENDLOOP. The body of a loop is -evaluated similarly to a function body, -except: - - 1. When evaluation reaches the -delimiter named ENDLOOP, evaluation -proceeds back to the first expression -in the loop. - - 2. When evaluation reaches an EXIT -within the loop, evaluation proceeds to -the point immediately following -ENDLOOP, and the value of the loop is -that of the last expression evaluated -therein. - - There can be any number of -conditional exits anywhere in a loop. -Ordinarily there is at least one exit -unless the user plans to have the loop -repeat indefinitely. Now consider the -following sequence: % - -L1: '(THE ORIGINAL ) $ -L2: '(TAIL) $ -LIS: 'DOG & -ANS: 'CAT & -REVLIS (L1, L2) & -% The above definition of REVLIS -makes assignments to its parameters LIS -and ANS. For this example, the final -assignments are - LIS: '() -and - ANS: '(ORIGINAL, THE, TAIL). - -So, what do you guess are the -corresponding current values for LIS -and ANS? See for yourself: % -RDS: FALSE $ -% The assignments to parameters LIS -and ANS in REVLIS has no effect on -their values once the function has -returned! The restoration of the -original environment following the -return from a called function allows -the programmer to change the value of a -function's parameters without fear of -damaging the values the parameters of -the same name have outside the -function. Thus functions can be -thought of as "black boxex" which have -no effect other than their returned -value. - - A function's parameters can not be -used to pass information back to the -calling function. If we wish to return -more than one piece of information, a -list of values can be returned. -However, another way is to make -assignments within the function body to -variables which are not among its -parameters. Such variables are called -"fluid" or "global" variables. - - The iterative version of REVLIS -using the LOOP construct is slightly -faster than the recursive version, but -the latter is more compact. When there -is such a trade-off between speed and -compactness, a good strategy is to -program for speed in the crucial most -frequently used functions, and program -for compactness elsewhere. - - Another consideration when choosing -between iteration and recursion is the -amount of storage required to perform a -given task. Each time a function is -called information must be stored on a -STACK so the original environment can -be restored when the function returns. -Since recursion involves the nesting of -function calls, a highly recursive -function can exhaust all available -memory before completing its task. -This will result in the - - ALL Spaces Exhausted - -error trap. The use of iteration in -this situation might permit an -equivalent computation to proceed to -termination. - - For practice with loops, use one to -write a nonrecursive recognizer named -ISSET, which returns TRUE if its list -argument contains no duplicate -elements, returning FALSE otherwise. -(Compare your definition with the -recursive version in lesson PLES3.) % -RDS: FALSE $ -% Here is our solution: % - -FUNCTION ISSET (LIS), - LOOP - WHEN EMPTY (LIS), EXIT, - WHEN MEMBER (FIRST(LIS), REST(LIS)), FALSE EXIT, - LIS: REST (LIS) - ENDLOOP -ENDFUN $ -ISSET ('(DOG, CAT, COW, CAT, RAT)) & -% Another good exercise adapted from -PLES3 is to use a loop to write a -nonrecursive function named SUBSET, -which returns TRUE if its first -argument is a subset of its second -argument, returning FALSE otherwise: % -RDS: FALSE $ -% A BLOCK is another control -construct which is sometimes -convenient, particularly in conjuction -with the Von Neumann style. As an -illustration of its use, the following -iterative version of the MAKESET -function from PLES3 returns a set -composed of the unique elements in the -list which is its first argument: % - -FUNCTION MAKESET (LIS, ANS), - LOOP - WHEN EMPTY (LIS), ANS EXIT, - BLOCK - WHEN MEMBER (FIRST(LIS), ANS), EXIT, - ANS: ADJOIN (FIRST(LIS), ANS) - ENDBLOCK, - LIS: REST (LIS) - ENDLOOP -ENDFUN $ -MAKESET ('(FROG, FROG, FROG, TERMITE)) & -% When evaluation reaches an EXIT, it -proceeds to the point following the -next ENDBLOCK, ENDLOOP, or ENDFUN -delimiter -- whichever is nearest. -Thus, BLOCK provides a means for -alternative evaluation paths which -rejoin within the same function body or -loop body, without causing an exit from -that body. - - The first expression in a block -must be a conditional-exit (anything -else can be moved outside anyway), but -since there can be any number of other -conditional exits or other expressions -within the block, the block provides a -very general structured control -mechanism. For example, the CASE- -statement and IF-THEN-ELSE construct of -some other languages are essentially -special cases of a block. - - You may not have noticed, but the -loop version of MAKESET has the effect -of reversing the order of the set -elements. Using ADJOIN in a loop -generally has this effect, which is why -it is so suitable for REVERSE. With -sets, incidental list reversal is -perhaps acceptable, but for most -applications of lists it is not. - - We could of course use a -preliminary or final invocation of -REVERSE so that the final list would -emerge in the original order, but that -would relinquish the speed advantage of -the loop approach, while further -increasing its greater bulk. Thus, -recursion is usually preferable to -loops when ADJOIN is involved. For -example, recursion is used almost -exclusively to implement muMATH, -because its symbolic expressions are -represented as ordered lists. - - Loops are also less applicable to -general tree structures than to lists, -but it is often possible to loop on the -REST pointer while recursing on the -first pointer, or vice-versa, -particularly if ADJOIN is not involved. -For example, compare the following -semi-recursive definition of #ATOMS -with the fully-recursive one in PLES1: -% - -FUNCTION #ATOMS (U, N), - N: 1, - LOOP - WHEN ATOM (U), N EXIT, - N: N + #ATOMS (FIRST(U)), - U: REST (U) - ENDLOOP -ENDFUN $ -#ATOMS ('((3 . FOO), BAZ)) & -% If the answer surprises you, don't -forget the FALSE which BAZ is -implicitly dotted with. - - See if you can similarly write a -semi-recursive function named DUP which -does what the infix operator named "=" -does: % RDS: FALSE $ -% Those of you with previous exposure -to only Von Neumann style programming -undoubtedly feel more at home now. The -reason we postponed revealing these -features until now is that we wanted to -force the use of applicative -programming long enough for you to -appreciate it too. Naturally, one -should employ whichever style is best -suited for each application, so it is -worthwhile to become equally conversant -with both styles. - - Thus endeth the sermon. % - -ECHO: FALSE$ NEWLINE: 0$ RDS ()$ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/PLES5.TRA b/software/CPM/CPM_MC_5/PLES5.TRA deleted file mode 100644 index f14cbb4..0000000 --- a/software/CPM/CPM_MC_5/PLES5.TRA +++ /dev/null @@ -1,392 +0,0 @@ -%File: PLES5.TRA (c) 09/24/80 - The Soft Warehouse % - -MATHTRACE: FALSE$ NEWLINE: 1$ ECHO: TRUE$ - -% This is the fifth in a series of -muSIMP programming lessons. - - In the previous lesson our original -version of REVERSE, called REVLIS, -required time proportional to n^2, -where n is the length of the first -argument. We then showed how a -collection variable or a loop could -yield a much faster technique using -time proportional only to n. Now, -let's consider the speed of some of the -other set functions that we defined: - - Whether iterative or recursive, -MEMBER can require a number of equality -comparisons equal to the length of its -second argument. Whether defined -iteratively or recursively, SUBSET, -EQSET, UNION, and INTERSECTION all -require a membership test for each -element of one argument in the list -which is the other argument. Thus, -these definitions can all consume -computation time which grows as the -product of the lengths of the two -arguments. - - By similar reasoning, the one- -argument functions ISSET and MAKESET -are seen to require time proportional -to the square of the length of their -argument. Data-base applications and -others can involve thousands of set -operations on sets having thousands of -elements, so it is worthwhile to seek -methods for which the computation time -grows more slowly with set size. - - In muSIMP, every name has an -associated PROPERTY LIST which is -immediately accessible in an amount of -time that is independent of the total -number of names in use. Provided the -elements of the sets are all names, -this permits techniques for the above -set operations requiring time -proportional merely to the length of -the one set or to the sum of the -lengths of the two sets. - - A property list is a list of dotted -pairs. The first of each dotted pair -is an expression called the KEY or -INDICATOR, and the rest of each dotted -pair is an expression called the -associated INFORMATION. For example, -in a meteorological data-base -application, the name HONOLULU might -have the property list - -((RAIN . 2), (HUMIDITY . 40), - (TEMPERATURE, 58, 96)) - - The function used in the form GET -(name, key) returns the information -which is dotted with the value of "key" -on the property list of the value of -"name", returning FALSE if no such key -occurred on the property list. - - A command of the form PUT (name, -key, information) causes the value of -"key" dotted with the value of -"information" to be put on the property -list of the value of "name". PUT -returns the value of "information". - - Using property lists, the basic -technique for accomplishing our various -operations on two sets of names is: - - 1. For each name in one of the two -sets of names, store TRUE under the key -SEEN. - - 2. For each name in the other set, -check to determine whether or not the -name has already been seen, and act -accordingly. - - 3. For each name in the first set, -remove the property SEEN so that we -won't invalidate subsequent set -operations which utilize any of the -same elements. - - A simpler variant of this idea is -applicable to the one-argument -functions named ISSET and MAKESET. - - As an example, here is UNION -defined using this technique together -with the applicative style: % - -FUNCTION UNION (SET1, SET2), - MARK (SET1), - UNMARK (SET1, UNIONAUX (SET2)) ENDFUN $ -FUNCTION MARK (SET1), - WHEN EMPTY (SET1), EXIT, - PUT (FIRST(SET1), 'SEEN, TRUE), - MARK (REST (SET1)) ENDFUN $ -FUNCTION UNIONAUX (SET2), - WHEN EMPTY (SET2), SET1 EXIT, - WHEN GET (FIRST(SET2), 'SEEN), UNIONAUX (REST(SET2)) EXIT, - ADJOIN (FIRST(SET2), UNIONAUX(REST(SET2))) ENDFUN $ -FUNCTION UNMARK (SET1, ANS), - WHEN EMPTY (SET1), ANS EXIT, - PUT (FIRST(SET1), 'SEEN, FALSE), - UNMARK (REST(SET1), ANS) ENDFUN $ -UNION ('(A, B, C, D), '(F, A, E, C)) & -% Each time any function is invoked, -the outside values of its parameter -names, if any, are "stacked" away to be -restored later, just prior to return -from that invocation. If a function -refers to a variable which is not among -its parameters, then the most recent -value of the variable on the stack is -used. - - Thus, when UNIONAUX is invoked -from within UNION, SET1 in the -definition of UNIONAUX refers to the -argument value associated with that -parameter of UNION. This treatment is -called "dynamic binding", and a -reference such as to SET1 in UNIONAUX -is called a "fluid reference". - - We could have avoided this by -making SET1 be an argument and a -parameter to UNIONAUX, but that would -have made the program slightly slower -and more bulky. However, fluid -variables make programs much harder to -debug and maintain, especially if -assignments are made to them in -functions other than the ones which -establish them. Consequently, we -recommend generally avoiding fluid -variables. The only reason we used one -here is to introduce the concept to -issue this advice. - - Values assigned at the top-level of -muSIMP, outside all function -definitions, are called GLOBAL values. -Examples are the initial values of -muSIMP control variables such as RDS -and ECHO, or of muMATH control -variables such as PBRCH or PWREXPD. - - Reference to a global value from -within a function definition is not -quite as confusing as reference to a -fluid value, and it is indeed onerous -to create numerous long lists of -parameters in order to pass such -environmental control values through a -long sequence of function definitions -for use deep within. - - The property-list technique for set -operations is one which we think is -more naturally implemented using the -Von Neumann programming style. Try to -write such a version of UNION: % -RDS: FALSE $ -% Now, using either style, write an -INTERSECTION function using the -property-list technique: %RDS: FALSE $ -% Taking the FIRST and/or REST of an -atom is generally not necessary, but it -does in fact have a well-defined value. -The FIRST cell of an atom points to the -atom's value, while the REST cell -points to the property list associated -with the atom. For example: % - -WEATHER: 'FOUL $ -PUT ('WEATHER, 'TEMPERATURE, -3) $ -PUT ('WEATHER, 'WIND, '((NORTH . WEST), 30)) $ -FIRST (WEATHER) & -REST ('WEATHER) & -% Integer atoms also have FIRST and -REST cells. The FIRST cell of an -integer normally points to the integer -itself. The REST cell is used to -determine the sign of the number: if -FALSE the integer is non-negative, if -TRUE the integer is negative. % - -FIRST (7) & -REST (7) & -NINE: 9 $ -PUT (NINE, 'TESTING, '(1, 2, 3)) & -GET (NINE, 'TESTING) & -GET (9, 'TESTING) & -% All muSIMP data objects (i.e. nodes, -names, and integers) have a FIRST cell -and a REST cell which can only point to -valid muSIMP data objects. Thus, -misuse of these selectors cannot -accidently give access to non-data -objects such as machine language code, -stack, print names, etc. This closed -pointer universe guarantees the -integrity of muSIMP from possible -excursions into the unknown. - - It is common practice to use EMPTY -to test for the end condition as a -function proceeds down a list. If such -a function is inadvertently given a -non-list (i.e. a Non-FALSE atom or a -structure whose final REST cell points -to a Non-FALSE atom), the function will -use the FIRST cell of that atom (i.e. -its Value cell) as an element of the -list and the REST cell of the atom -(i.e. its Property List cell) as the -REST of the list. Generally the -Property List is a well defined list so -the EMPTY test will ultimately cause -termination with no ill affects. - - We prefer to have non-list -arguments give more predictable results -confined to the argument. Thus, our -internal implementations of MEMBER, -REVERSE, and any other functions -ordinarily applied to lists use ATOM -rather than EMPTY as the termination -test. This is slightly faster too, so -you may wish to generally avoid EMPTY -in favor of ATOM. Alternatively, you -can redefine EMPTY to print and return -an error message when given a nonFALSE -atom: % - -FUNCTION EMPTY (LIS), - WHEN ATOM (LIS), - WHEN LIS EQ FALSE EXIT, - PRINT ("*** Warning: EMPTY given nonlist ") EXIT -ENDFUN $ -EMPTY (5) $ -% This is our first example -illustrating the fact that conditional -exits can be nested arbitrarily deep. -The same is true of loops or blocks. -This example also illustrates the PRINT -function, which prints its one argument -the same way that expressions -terminated with an ampersand are -printed. There is an analogous -function named PRTMATH which prints its -one argument the same way that -expressions terminated with a semicolon -are printed. - - When functions are called with -fewer actual arguments than the -function has formal arguments, the -remaining formal arguments are assigned -the value FALSE. This provides a -convenient mechanism for automatically -inserting default values for these -extra arguments. When an argument -evaluates to FALSE, the function can -assign the appropriate default value. -For example, if the user omits the -drive as the third argument of RDS, -that function uses the currently logged -in drive (i.e. the drive indicated by -the last operating system prompt given -before entering muSIMP). - - There are instances where it is -desirable to permit a function to have -an arbitrary number of arguments. This -is accomplished by making the formal -parameter list of a function definition -be an atom or non-list rather than a -list. The arguments are passed to the -function as a single list of argument -values, from which the function can -extract the values. For example, it is -convenient to have a function named MAX -which returns the largest of one or -more argument values. We can implement -this as follows: % - -FUNCTION MAX ARGLIS, - MAXAUX (FIRST(ARGLIS), REST(ARGLIS)) -ENDFUN $ -FUNCTION MAXAUX (BIGGEST, UNTRIED), - WHEN EMPTY (UNTRIED), BIGGEST EXIT, - WHEN BIGGEST > FIRST(UNTRIED), MAXAUX (BIGGEST, REST(UNTRIED)) EXIT, - MAXAUX (FIRST(UNTRIED), REST(UNTRIED)) -ENDFUN $ -MAX (7) ; -MAX (3, 8, -2) ; -% This collection of arguments into a -list is called NOSPREAD, to distinguish -from the SPREAD brand of peanut butter. - - Now, suppose that for some reason -we already have a list of integers such -as % - -NUMBLIS: '(18, 3, 7, 91, 12, 2) $ -% and we want to find their maximum. -The expression MAX (NUMBLIS) will not -work, because MAX is designed for -numeric arguments, not for a list of -numbers. We could of course extract -the elements and feed them individually -to MAX, but this is awkward, especially -if we are referring to MAX inside a -function and we do not know ahead of -time how many integers are in NUMBLIS. - - Fortunately there is a convenient -function named APPLY, which applies the -function whose name is the value of its -first argument to the argument list -which is the value of its second -argument. Consequently, we need merely -write % - -APPLY ('MAX, NUMBLIS) & -% APPLY works on either SPREAD or -NOSPREAD functions. Why don't you try -out a few examples: %RDS: FALSE $ -% A function written in muSIMP is -stored internally in a very compact -form called D-code (see Section 13.9 of -the muMATH Reference Manual). In order -to retrieve the definition for use as -data, the function GETD (GET -Definition) of one argument can be used -to decompile the definition and return -it is as a linked list. If GETD is -given the name of a primitively defined -machine language routine instead, the -physical memory address of the routine -is returned. Finally, if its argument -is not a defined function, GETD returns -returns FALSE. The following examples -show the result of all three types of -arguments: % - -GETD ('UNION) & GETD ('FIRST) & GETD ('FOO) & -% Since function definitions can be -converted into lists and then -recompiled back into D-code, a muSIMP -program can actuately be made to modify -muSIMP functions! In fact, this is -exactly what the TRACE and UNTRACE -commands do to the traced function. -Other examples which could use this -feature include a muSIMP function -editor and pretty printer, a cross -reference program, and even a compiler -all of which could be written in -muSIMP. - - This is the end of programming -lesson 5. These lessons should have -provided you with sufficient knowledge -to be able to use the muSIMP Section of -the Reference Manual to achieve any -desired muSIMP programming goal. % - -ECHO: FALSE$ NEWLINE: 0$ RDS ()$ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/PLOT.MU b/software/CPM/CPM_MC_5/PLOT.MU deleted file mode 100644 index 121d6b2..0000000 --- a/software/CPM/CPM_MC_5/PLOT.MU +++ /dev/null @@ -1,189 +0,0 @@ -% % -% function plotter for muMath (trs-80) % -% % -FUNCTION BOX (XHIGH, A) - CLS(), - A:0, - BLOCK - WHEN A>XHIGH, EXIT - LOOP - SET(A,0), SET(A,47) - A: A+1, - WHEN A>XHIGH, EXIT - ENDLOOP - ENDBLOCK - A:0, - BLOCK - WHEN A>47, TRUE EXIT, - LOOP - WHEN A>47, TRUE EXIT, - SET(0,A), SET(XHIGH,A) - A:A+1, - ENDLOOP - ENDBLOCK -ENDFUN $ -% % -DOT: '. $ -% % -% this portion is the main program % -% this function may run out of vector % -% space on complex functions, if this % -% happens, use plot#1() below % -% if you don't want to use auto scaling % -% for the Y axis, then use plot#2() below % -% % -FUNCTION PLOT(EXPR, X, LOW, HIGH, YLIST, ZINT, - INCX, INCY, A, B, Y, SLOPEY, INTERY, Q) - WHEN (LOW=HIGH) OR - (NUMBER(HIGH)=FALSE) OR (NUMBER(LOW)=FALSE), - PRINT("ERROR IN LIMITS!") EXIT, - CLS(), PRINT("THINKING"), YLIST: LIST(), - INCX: (HIGH-LOW)/100, ZINT: 0 - % % - % now find scaling factor for y-axis % - % % - UPY: EVSUB(EXPR,X,HIGH), LOWY: EVSUB(EXPR,X,LOW), - WHEN (NUMBER(UPY)=FALSE) OR (NUMBER(LOWY)=FALSE), - PRINT("ONLY UNIVARIATE FUNCTIONS!") EXIT, - A: LOW, - LOOP - BLOCK - WHEN INTEGER(ZINT/10), PRTMATH(ZINT) EXIT, - PRINT(DOT), - ENDBLOCK - ZINT: ZINT+1 - B: EVSUB(EXPR,X,A), - YLIST: ADJOIN(B,YLIST) % save generated points % - UPY: MAX(UPY,B), - LOWY: MIN(LOWY,B), - A: A+INCX - WHEN A>HIGH EXIT, - ENDLOOP - A: LOW, Q: 1, YLIST: REVERSE(YLIST), - WHEN LOWY=UPY, PRINT("CHOOSE DIFFERENT X-LIMITS"), EXIT - SLOPE: 45/(UPY-LOWY) - INTER: 1-SLOPE*LOWY -% % -% ok, now that we have the scaling % -% factors, let's plot the function % -% % - BOX(100), % set up screen % - LOOP - WHEN Q>100, EXIT - Y: 47 - INT(FIRST(YLIST)*SLOPE + INTER) - YLIST:REST(YLIST) - SET(Q,Y) - Q: Q+1, - ENDLOOP -% % -% now keep looping until any key is pressed % -% (see definition by PUTD below) (another % -% way to do the loop would be: % -% LOOP % -% ENDLOOP % -% in which case the only way out is to use % -% the key to exit) % -% % - W#SCAN (), -ENDFUN $ % end_plot % -% % -% PLOT#1() is just like PLOT() except % -% that it doesn't store all the numbers, so % -% you won't have as much tendency to run out % -% of vector space due to storage % -% % -FUNCTION PLOT#1(EXPR,X,LOW,HIGH,ZINT,INCX,INCY,A,B,Y, - SLOPEY,INTERY,Q) - WHEN (LOW=HIGH) OR - (NUMBER(HIGH)=FALSE) OR (NUMBER(LOW)=FALSE), - PRINT("ERROR IN LIMITS!") EXIT, - CLS(), PRINT("THINKING"), - INCX: (HIGH-LOW)/126, ZINT:0 - UPY: EVSUB(EXPR,X,HIGH), LOWY: EVSUB(EXPR,X,LOW), - WHEN (NUMBER(UPY)=FALSE) OR (NUMBER(LOWY)=FALSE), - PRINT("ONLY UNIVARIATE FUNCTIONS!") EXIT, - A: LOW, - LOOP - BLOCK - WHEN INTEGER(ZINT/10), PRTMATH(ZINT) EXIT, - PRINT(DOT), - ENDBLOCK - ZINT: ZINT+1 - B: EVSUB(EXPR,X,A), - UPY: MAX(UPY,B), - LOWY: MIN(LOWY,B), - A: A+INCX - WHEN A>HIGH EXIT, - ENDLOOP - A: LOW, Q:1, - WHEN LOWY=UPY, PRINT("CHOOSE DIFFERENT X-LIMITS!"), EXIT - SLOPE: 45/(UPY-LOWY) - INTER: 1-SLOPE*LOWY - BOX(126), - LOOP - WHEN Q>126, EXIT - Y: 47 - INT(EVSUB(EXPR,X,A)*SLOPE + INTER) - SET(Q,Y) - Q: Q + 1, A: A+INCX - ENDLOOP - W#SCAN(), -ENDFUN $ % end_plot#1 % -% % -% PLOT#2 is different in that you must % -% enter the limits for x and y, rather % -% than have auto y-scaling. The calling % -% sequence is: % -% PLOT#2(expr, X, X_low, X_high, Y_low, Y_high) % -% % -FUNCTION PLOT#2(EXPR,X,LOW,HIGH,LOWY,UPY,INCX,A,B,Y, - SLOPEY,INTERY,Q) - WHEN (LOW=HIGH) OR (LOWY=UPY) OR - (NUMBER(HIGH)=FALSE) OR (NUMBER(LOW)=FALSE) OR - (NUMBER(LOWY)=FALSE) OR (NUMBER(UPY)=FALSE), - PRINT("ERROR IN LIMITS!") EXIT, - INCX: (HIGH-LOW)/126, - A:LOW, Q:1, - WHEN LOWY=UPY, PRINT("CHOOSE DIFFERENT X-LIMITS"), EXIT - SLOPE: 45/(UPY-LOWY) - INTER: 1-SLOPE*LOWY - BOX(126), - LOOP - WHEN Q>126, EXIT - Y: 47 - INT(EVSUB(EXPR,X,A)*SLOPE + INTER) - SET(Q,Y) - Q:Q+1, A:A+INCX - ENDLOOP - W#SCAN(), -ENDFUN $ % end_plot#2 % -% % -% define a function to find the maximum % -% of two arguments % -% % -FUNCTION MAX(X,Y) - WHEN MIN(X,Y)=Y, X EXIT - Y -ENDFUN $ % end_max % -% % -% define a function to find the integer % -% part of a rational number % -% % -FUNCTION INT(X) - QUOTIENT(NUM(X), DEN(X)) -ENDFUN $ % end_int % -% % -% define the trs-80 rom call at 0049h to be % -% W#SCAN(); it waits until a key is pressed % -% % -PUTD ('W#SCAN, 73) $ -% % -% calling sequence: % -% PLOT(fun, var, low, high) % -% where % -% fun = function to be plotted % -% var = variable in the function % -% low & high are limits of the function % -% % -STOP() $ -RDS () $ -W, - LOOP \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/READ.ME b/software/CPM/CPM_MC_5/READ.ME deleted file mode 100644 index 0eca72e..0000000 --- a/software/CPM/CPM_MC_5/READ.ME +++ /dev/null @@ -1,13 +0,0 @@ - -This package was originally issued for the OSBORNE 1. -The MUSIMP.COM file contains my patch to make it useable -under generic cp/m. The original osborne version of this -executable is enclosed as MUSIMP.OBJ - -The CLES?.* files are a tutorial in using the calculation -parts of MUMATH. The PLES?.* comprise a programming tutorial -for MUSIMP. - - -rwd -06/09/98 \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/SERIES%.DIF b/software/CPM/CPM_MC_5/SERIES%.DIF deleted file mode 100644 index f3af51e..0000000 --- a/software/CPM/CPM_MC_5/SERIES%.DIF +++ /dev/null @@ -1,314 +0,0 @@ - file SERIES%.DIF GAE - Feb. 1982 -Make a file called SERIES.DIF as follows: -(1) Start with this file (SERIES%.DIF). -(2) Insert in it (at the spot marked INSERT HERE) the two - functions FUNCTION QUERY and FUNCTION SIGN. They - can be found at the beginning of file LIM.DIF or - file INT.DIF. -(3) Finally, delete this comment up to the line. ------------------------------------------------------------ - - -% File SERIES.DIF Infinite series. % - -% rewritten, Feb. 1982 - GAE - DIF.ALG is required. - LOG, TRGNEG, ATRG may be useful with this file. % - - - - % INSERT HERE % - - - -FUNCTION FCTR1(EX1, - % Local: % PWREXPD, NUMNUM, DENDEN, DENNUM, NUMDEN, BASEXP, EXPBAS), - PWREXPD: 6, - DENNUM: NUMNUM: DENDEN: -30, - EXPBAS: BASEXP: 30, - NUMDEN: 0, - EVAL (EX1), -ENDFUN $ - -FUNCTION LINCF(EX1, INDET), - WHEN FREE(EX1:(EVSUB(EX1,INDET,INDET+1)-EX1),INDET), EX1 EXIT, -ENDFUN $ - -FUNCTION SIGSB2(EX1,EX2, - % Local: % EX3, EX4), - EX3: COS(EX1), EX4: SIN(EX1), - #E^(EX3*EX2)*COS(EX4*EX2), -ENDFUN $ - -FUNCTION SIGF(EX1,EX2,EX3, - % Local: % EX4, INDET2, INDET3), - INDET2: 'INDET2, INDET3: 'INDET3, - WHEN EX3 > 0, - EX4: SIGF(INDET3,EX2,0), - LOOP - WHEN EX3 EQ EX2, EXIT, - EX4: DIF(EX4,INDET3), - EX3: EX3+1, - ENDLOOP, - EVSUB(EX4,INDET3,EX1) EXIT, - % EX3 EQ 0 % - EX4: 2*#PI/EX2, - WHEN MOD(EX2,2) EQ 0, - (#E^EX1+#E^-EX1+ - 2*SIGMA(SIGSB2(INDET2*EX4,EX1),INDET2,1,(EX2-2)/2))/EX2 EXIT, - (#E^EX1+2*SIGMA(SIGSB2(INDET2*EX4,EX1),INDET2,1,(EX2-1)/2))/EX2, -ENDFUN $ - -FUNCTION SIGFM(EX1,EX2,EX3, - % Local: % EX4, INDET2, INDET3), - INDET2: 'INDET2, INDET3: 'INDET3, - WHEN EX3 > 0, - EX4: -SIGFM(INDET3,EX2,0), - LOOP - WHEN EX3 EQ EX2, EXIT, - EX4: DIF(EX4,INDET3), - EX3: EX3+1, - ENDLOOP, - EVSUB(EX4,INDET3,EX1) EXIT, - % EX3 EQ 0 % - EX4: #PI/EX2, - WHEN MOD(EX2,2) EQ 0, - SIGMA(SIGSB2((2*INDET2+1)*EX4,EX1),INDET2,0,(EX2-2)/2)/(EX2/2) EXIT, - (#E^-EX1+2*SIGMA(SIGSB2((2*INDET2+1)*EX4,EX1),INDET2,0,(EX3-3)/2))/EX2, -ENDFUN $ - -FUNCTION SIGSB3(EX1,EX2,EX6, - % Local: % EX3,EX4,EX5), - EX3: COS(EX2), - EX4: SIN(EX2), - EX5: COS(EX1*EX2), - EX1: 2*(COS((EX1-1)*EX2)-EX3*EX5)/EX4, - -EX5*LOG(1-2*EX3*EX6+EX6^2,#E)+EX1*ATAN((EX6-EX3)/EX4)+EX1*(#PI/2-EX2), -ENDFUN $ - -FUNCTION SIGMA2(EX1, EX2, - % Local: % EX3, EX4, EX5, EX6), - EX4: DEN(EX1), EX5: NUM(EX1), EX6: EX2^(1/EX4), - EX3: (2/EX4)*#PI, - EX1: -LOG(1-EX6,#E), - BLOCK - WHEN EX5 EQ 0, EXIT, - EX1: EX1+(-EX4/EX5)*EX6^EX5, - ENDBLOCK, - WHEN MOD(EX4,2) EQ 0, - EX1: EX1-(-1)^EX5*LOG(1+EX6,#E), - EX2: (EX4-2)/2, - LOOP - WHEN EX2 EQ 0, EXIT, - EX1: EX1+SIGSB3(EX5,EX2*EX3,EX6), - EX2: EX2-1, - ENDLOOP, - EX1 EXIT, - EX2: (EX4-1)/2, - LOOP - WHEN EX2 EQ 0, EXIT, - EX1: EX1+SIGSB3(EX5,EX2*EX3,EX6), - EX2: EX2-1, - ENDLOOP, - EX1, -ENDFUN $ - -FUNCTION SIGMA2M(EX1,EX2, - % Local: % EX3,EX4,EX5,EX6), - EX4: DEN(EX1), EX5: NUM(EX1), EX6: EX2^(1/EX4), - EX3: #PI/EX4, - EX1: 0, - BLOCK - WHEN EX5 EQ 0, EXIT, - EX1: (EX4/EX5)*EX6^EX5, - ENDBLOCK, - WHEN MOD(EX4,2) EQ 0, - EX2: EX4-1, - LOOP - WHEN EX2 EQ -1, EXIT, - EX1: EX1-SIGSB3(EX5,EX2*EX3,EX6), - EX2: EX2-2, - ENDLOOP, - WHEN EX5 EQ 0, -EX1 EXIT, - EX1 EXIT, - EX1: EX1+(-1)^EX5*LOG(1+EX6,#E), - EX2: EX4-2, - LOOP - WHEN EX2 EQ -1, EXIT, - EX1: EX1-SIGSB3(EX5,EX2*EX3,EX6), - EX2: EX2-2, - ENDLOOP, - WHEN EX5 EQ 0, -EX1 EXIT, - EX1, -ENDFUN $ - -FUNCTION SIGMA1(EX7,EX6,EX1, - % Local: % INDET3,INDET4,EX8,EX9), - % Fluid: EX2,EX3,EX5,INDET % - INDET3: 'INDET3, INDET4: 'INDET4, - WHEN POSITIVE(EX6), - WHEN EX5 EQ 1 AND EX7 EQ 1, - WHEN EX3 EQ PINF, PINF EXIT, - EX8: EXPD(PROD(INDET-INDET3,INDET3,0,EX6-1)), - EX9: (INDET+1)*EX8, - EX9: EVSUB(EX9,INDET,EX3)-EVSUB(EX9,INDET,EX2-1), - EXPD(EX9)/(1+EX6)+SIGMA(INDET^EX6-EX8,INDET,EX2,EX3) EXIT, - EX8: SIGMA1(INDET4,0,EX1), - WHEN FREE(EX8, 'SIGMA), - WHEN MEMBER(EX8, '(PINF MINF CINF ?) ), EX8 EXIT, - LOOP - EX6: EX6-1, - WHEN EX6<0, EXIT, - EX8: INDET4*DIF(EX8,INDET4), - ENDLOOP, - INDET4: EX7, - EXPD(EX8) EXIT, - LIST('SIGMA,EX5*INDET^EX6*EX7^INDET,INDET,EX2,EX3) EXIT, - % EX6=0 % - WHEN FREE(EX5,INDET), - WHEN EX3 EQ PINF, - WHEN SIGN(1-EX1) EQ 1, - WHEN SIGN(1+EX1) EQ 1, - EX5*EX7^EX2/(1-EX7) EXIT, - '? EXIT, - PINF EXIT, - WHEN EX7=1, EX5*(EX3-EX2+1) EXIT, - EX5*(EX7^EX2-EX7^(EX3+1))/(1-EX7) EXIT, - WHEN NUMBER(EX6:LINCF(1/EX5,INDET)) AND EX3=PINF, - WHEN (EX8:SIGN(1+EX1)) EQ -1, '? EXIT, - WHEN EX8 EQ 0 AND NOT EX7=EX1, '? EXIT, - WHEN SIGN(1-EX1) EQ 1, - EX8: EXPD(1/EX5-EX6*INDET), - EX10: EX8/EX6, - EX4: QUOTIENT(NUM(EX10),DEN(EX10)), - EX2: EX2+EX4, - EX8: EX8-EX4*EX6, - EX10: EX8/EX6, - WHEN MOD(DEN(EX10),2) EQ 0, - WHEN SIGN(EX1) EQ -1, - (-SIGMA2M(EX10,-EX7)+ - SIGMAX((-EX7)^(INDET+EX10)*(-1)^INDET/(INDET+EX10),INDET,EX2,0)) - *(-EX7)^-EX10*EX7^-EX4/EX6 EXIT, - (SIGMA2(EX10,EX7)+SIGMAX(EX7^(INDET+EX10)/(INDET+EX10),INDET,EX2,0)) - *EX7^-(EX10+EX4)/EX6 EXIT, - (SIGMA2(EX10,EX7)+SIGMAX(EX7^(INDET+EX10)/(INDET+EX10),INDET,EX2,0)) - *EX7^-(EX10+EX4)/EX6 EXIT, - WHEN SIGN(EX6) EQ 1, PINF EXIT, - MINF EXIT, - WHEN FIRST(EX9:1/EX5) EQ '! AND EX3=PINF, - EX9:SECOND(EX9), - WHEN POSITIVE(EX6:LINCF(EX9,INDET)) AND INTEGER(EX8:EXPD(EX9-INDET*EX6)), - EX4: QUOTIENT(EX8,EX6), - EX8: MOD(EX8,EX6), - EX2: EX2+EX4, - WHEN MOD(EX6,2) EQ 0, - WHEN SIGN(EX1) EQ 1, - EX7^(-EX8/EX6-EX4)*SIGF(EX7^(1/EX6),EX6,EX8) - -SIGMAX(EX5*EX7^INDET,INDET,-EX4,EX2-EX4-1) EXIT, - (-EX7)^(-EX8/EX6-EX4)*(SIGFM((-EX7)^(1/EX6),EX6,EX8) - -SIGMAX(EX5*EX7^INDET,INDET,-EX4,EX2-EX4-1)) EXIT, - EX7^(-EX8/EX6-EX4)*SIGF(EX7^(1/EX6),EX6,EX8) - -SIGMAX(EX5*EX7^INDET,INDET,-EX4,EX2-EX4-1) EXIT, - LIST('SIGMA,EX5*EX7^INDET,INDET,EX2,EX3) EXIT, - LIST('SIGMA,EX5*EX7^INDET,INDET,EX2,EX3), -ENDFUN $ - -FUNCTION SIGMAX(EX1, INDET, EX2, EX3), - WHEN EX2 > EX3+1, -SIGMA(EX1,INDET,EX3+1,EX2-1) EXIT, - SIGMA(EX1,INDET,EX2,EX3), -ENDFUN $ - -FUNCTION SIGMA (EX1, INDET, EX2, EX3, - % Local: % EX4, EX5, EX6, EX7, EX8, EX9, EX10, - DENNUM, LEX1, SIGN), - DENNUM: 30, - WHEN EX2 = MINF, - WHEN EX3 = PINF, - SIGMA(EX1,INDET,0,PINF)+SIGMA(EVSUB(EX1,INDET,-INDET),INDET,1,PINF) EXIT, - SIGMA(EVSUB(EX1,INDET,-INDET),INDET,-EX3,PINF) EXIT, - WHEN INTEGER(EX2) AND INTEGER(EX3), - EX4: 0, - LOOP - WHEN EX2 > EX3, EX4 EXIT, - EX4: EX4 + EVSUB(EX1,INDET,EX2), - EX2: EX2 + 1, - ENDLOOP EXIT, - EX1: EXPD(NUM(EX1))/DEN(EX1), - WHEN APPLY(GET('SIGMA,FIRST(EX1)), ARGEX(EX1)) EXIT, - EX4: FCTR1(EX1), - BLOCK - WHEN PRODUCT(EX4), LEX1: REST(EX4) EXIT, - LEX1: LIST(EX4), - ENDBLOCK, - EX6: 0, EX4: EX5: EX7: 1, - LOOP - WHEN ATOM(LEX1), EXIT, - EX8: POP(LEX1), - BLOCK - WHEN FREE(EX8, INDET), EX4: EX4*EX8 EXIT, - WHEN EX8=INDET, EX6:EX6+1 EXIT, - WHEN POWER(EX8), - EX9: SECOND(EX8), EX10: THIRD(EX8), - WHEN EX9=INDET AND POSITIVE(EX10), - EX6: EX6+EX10 EXIT, - WHEN FREE(EX10: EX10/INDET, INDET) AND FREE(EX9,INDET), - EX7: EX7*EX9^EX10 EXIT, - EX5: EX5*EX8 EXIT, - EX5: EX5*EX8, - ENDBLOCK, - ENDLOOP, - EX4*SIGMA1(EX7,EX6,EX7), -ENDFUN $ - -PROPERTY SIGMA, +, FUNCTION (EX1, EX4), - % fluid: INDET, EX2, EX3 % - WHEN ZERO (EVSUB(EX1,INDET,INDET+1) + EX4), - EVSUB(EX1,INDET,EX2)+EVSUB(EX4,INDET,EX3) EXIT, - WHEN ZERO (EVSUB(EX4,INDET,INDET+1) + EX1), - EVSUB(EX4,INDET,EX2)+EVSUB(EX1,INDET,EX3) EXIT, - SIGMA(EX1,INDET,EX2,EX3) + SIGMA(EX4,INDET,EX2,EX3) -ENDFUN $ - -FUNCTION PROD (EX1, INDET, EX2, EX3, - % Local: % EX4, LOGEXPD), - WHEN INTEGER(EX2) AND INTEGER(EX3), - EX4: 1, - LOOP - WHEN EX2 > EX3, EX4 EXIT, - EX4: EX4 * EVSUB(EX1,INDET,EX2), - EX2: EX2 + 1, - ENDLOOP EXIT, - WHEN EX1=INDET, EX3!/(EX2-1)! EXIT, - WHEN FREE(EX1,INDET), EX1^(EX3-EX2+1) EXIT, - WHEN APPLY(GET('PROD,FIRST(EX1)), ARGEX(EX1)) EXIT, - LIST ('PROD, EX1, INDET, EX2, EX3), -ENDFUN $ - - -PROPERTY PROD, +, FUNCTION (EX1, EX4), - % fluid: EX2, EX3, INDET % - WHEN EX1=INDET AND FREE(EX4,INDET), - (EX3+EX4)!/(EX2+EX4-1)! EXIT, - WHEN EX4=INDET AND FREE(EX1,INDET), - (EX3+EX1)!/(EX2+EX1-1)! EXIT, -ENDFUN $ - -PROPERTY PROD, *, FUNCTION (EX1, EX4), - % fluid: EX2,EX3, INDET % - WHEN EXPD(EVSUB(EX1,INDET,INDET+1)*EX4) EQ 1, - EVSUB(EX1,INDET,EX2)*EVSUB(EX4,INDET,EX3) EXIT, - WHEN EXPD(EVSUB(EX4,INDET,INDET+1)*EX1) EQ 1, - EVSUB(EX4,INDET,EX2)*EVSUB(EX1,INDET,EX3) EXIT, - PROD(EX1,INDET,EX2,EX3) * PROD(EX4,INDET,EX2,EX3), -ENDFUN $ - -PROPERTY PROD, ^, FUNCTION (EX1, EX4) - % fluid: EX2, EX3, INDET % - WHEN FREE(EX4,INDET), - PROD(EX1,INDET,EX2,EX3)^EX4 EXIT, - WHEN FREE(EX1,INDET), - EX1^SIGMA(EX4,INDET,EX2,EX3) EXIT, -ENDFUN $ - -RDS() $ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/SIGMA.ALG b/software/CPM/CPM_MC_5/SIGMA.ALG deleted file mode 100644 index a1b12d1..0000000 --- a/software/CPM/CPM_MC_5/SIGMA.ALG +++ /dev/null @@ -1,97 +0,0 @@ -% File: SIGMA.ALG (c) 08/26/80 The Soft Warehouse % - - -FUNCTION LINCF (EX1, INDET), - WHEN FREE (EX1:(EX1-EVSUB(EX1,INDET,0))/INDET, INDET), EX1 EXIT, -ENDFUN$ - - -FUNCTION SIGMA (EX1, INDET, EX2, EX3, - % Local: % EX4, NUMNUM, DENDEN, DENNUM, NUMDEN, PWREXPD, LOGEXPD), - WHEN INTEGER(EX2) AND INTEGER(EX3), - EX4: 0, - LOOP - WHEN EX2 > EX3, EX4 EXIT, - EX4: EX4 + EVSUB(EX1,INDET,EX2), - EX2: EX2 + 1, - ENDLOOP EXIT, - NUMNUM: DENDEN: 30, - DENNUM: -30, - NUMDEN: 0, - PWREXPD: LOGEXPD: 6, - WHEN FREE (EX4:ANTIDF(EX1), ANTIDF), - WHEN INTEGER(#LIM), LIM(EX4,INDET,EX3+1) - LIM(EX4,INDET,EX2) EXIT, - EVSUB(EX4,INDET,EX3+1) - EVSUB(EX4,INDET,EX2) EXIT, - WHEN APPLY(GET('SIGMA,FIRST(EX1)), ARGEX(EX1)) EXIT, - LIST('SIGMA, EX1,INDET,EX2,EX3), -ENDFUN $ - -FUNCTION ANTIDF (EX1), - WHEN EX1 = INDET, EX1*(-1+EX1)/2 EXIT, - WHEN FREE(EX1,INDET), INDET*EX1 EXIT, - SIMPU(ANTIDF,EX1) -ENDFUN $ - -PROPERTY ANTIDF, +, FUNCTION (EX1, EX2), - WHEN ZERO (EVSUB(EX1,INDET,INDET+1) + EX2), -EX1 EXIT, - WHEN ZERO (EVSUB(EX2,INDET,INDET+1) + EX1), -EX2 EXIT, - ANTIDF(EX1) + ANTIDF(EX2), -ENDFUN $ - -PROPERTY ANTIDF, *, FUNCTION (EX1, EX2), - WHEN FREE(EX1,INDET), EX1*ANTIDF(EX2) EXIT, - WHEN FREE(EX2,INDET), EX2*ANTIDF(EX1) EXIT, -ENDFUN $ - -PROPERTY ANTIDF, ^, FUNCTION (EX1, EX2, EX3), - WHEN EX1 = INDET AND POSITIVE(EX2), - (EX3:PROD(INDET-'##,'##,0,EX2-1)) * (INDET-EX2)/(1+EX2) - + ANTIDF(EX1^EX2-EX3) EXIT, - WHEN FREE(EX1,INDET) AND (EX3: LINCF(EX2,INDET)), - EX1^EX2/(EX1^EX3 - 1) EXIT, -ENDFUN $ - -FUNCTION PROD (EX1, INDET, EX2, EX3, - % Local: % EX4, LOGEXPD), - WHEN INTEGER(EX2) AND INTEGER(EX3), - EX4: 1, - LOOP - WHEN EX2 > EX3, EX4 EXIT, - EX4: EX4 * EVSUB(EX1,INDET,EX2), - EX2: EX2 + 1, - ENDLOOP EXIT, - WHEN FREE (EX4:ANTIDV(EX1), ANTIDV), - WHEN INTEGER(#LIM), LIM(EX4,INDET,EX3+1) / LIM(EX4,INDET,EX2) EXIT, - EVSUB(EX4,INDET,EX3+1) / EVSUB(EX4,INDET,EX2) EXIT, - WHEN APPLY(GET('PROD,FIRST(EX1)), ARGEX(EX1)) EXIT, - LIST ('PROD, EX1, INDET, EX2, EX3), -ENDFUN $ - -%************** Optional ANTIDV (PROD) Package ****************% - -FUNCTION ANTIDV (EX1), - WHEN EX1=INDET, (EX1-1)! EXIT, - WHEN FREE(EX1,INDET), EX1^INDET EXIT, - SIMPU (ANTIDV, EX1) -ENDFUN $ - -PROPERTY ANTIDV, +, FUNCTION (EX1, EX2), - WHEN EX1=INDET AND FREE(EX2,INDET), (EX1-1+EX2)! EXIT, - WHEN EX2=INDET AND FREE(EX1,INDET), (EX2-1+EX1)! EXIT, -ENDFUN $ - -PROPERTY ANTIDV, *, FUNCTION (EX1, EX2), - WHEN EXPD(EVSUB(EX1,INDET,INDET+1)*EX2) EQ 1, 1/EX1 EXIT, - WHEN EXPD(EVSUB(EX2,INDET,INDET+1)*EX1) EQ 1, 1/EX2 EXIT, - ANTIDV(EX1) * ANTIDV(EX2), -ENDFUN $ - -PROPERTY ANTIDV, ^, FUNCTION (EX1, EX2, INDET2), - WHEN FREE(EX2,INDET), ANTIDV(EX1)^EX2 EXIT, - INDET2: 'INDET2, - WHEN FREE(EX1,INDET), - EX1^SIGMA(EVSUB(EX2,INDET,INDET2-1),INDET2,1,INDET) EXIT, -ENDFUN $ - -RDS () $ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/SOLVE.EQN b/software/CPM/CPM_MC_5/SOLVE.EQN deleted file mode 100644 index d624cea..0000000 --- a/software/CPM/CPM_MC_5/SOLVE.EQN +++ /dev/null @@ -1,134 +0,0 @@ -% File SOLVE.EQN (c) 04/21/81 The Soft Warehouse % - - -FUNCTION UNION (LEX1, LEX2), - WHEN ATOM(LEX1), LEX2 EXIT, - WHEN MEMBER (FIRST(LEX1), LEX2), UNION (REST(LEX1), LEX2) EXIT, - ADJOIN (POP(LEX1), UNION (LEX1, LEX2)), -ENDFUN $ - -FUNCTION SOLF (EX1, - % Local: % EX3, EX4, EX5, EX6), - % Fluid vars from SOLVE & SOLEXP: INDET, EX2 % - WHEN EX2 = INDET, LIST (INDET "==" EX1) EXIT, - WHEN POWER (EX2), - EX3: SECOND (EX2), - EX4: THIRD (EX2), - WHEN FREE (EX3, INDET), - SOLEXP (EX4 - LOG(EX1,EX3)) EXIT, - WHEN NUMBER (EX4), - EX1: EX1 ^ (1/EX4), - EX4: NUM (EX4), - EX5: #E ^ (2*#I*#PI/EX4), - LOOP - EX6: UNION (SOLEXP(EX3-EX1), EX6), - EX4: EX4 - 1, - WHEN ZERO (EX4), EX6, EXIT, - EX1: EX5 * EX1, - ENDLOOP EXIT, - WHEN FREE (EX4,INDET), - SOLEXP (EX3 - EX1^(1/EX4)) EXIT, - LIST (EX2 "==" EX1) EXIT, - WHEN LOGARITHM (EX2) AND THIRD(EX2) EQ #E, - SOLEXP (SECOND(EX2) - #E^EX1) EXIT, - WHEN (EX6: GET(FIRST(EX2), 'INV)), - SOLEXP (SECOND(EX2) - EVAL(LIST(EX6, EX1))) EXIT, - WHEN PBRCH AND (EX6: GET(FIRST(EX2), 'PINV)), - SOLEXP (SECOND(EX2) - EVAL(LIST(EX6, EX1))) EXIT, - LIST (EX2 "==" EX1), -ENDFUN $ - -#ARB: 1 $ - -FUNCTION SOLEXP (EX1, - % Local: % EX2, EX3, EX4, EX5, EX6, EX7, EX8, LEX1, LEX2, LEX3, LEX4), - EX1: NUM (FCTR(EX1)), - BLOCK WHEN SUM(EX1), EX1: NUM(EXPD(EX1)) EXIT, - ENDBLOCK, - WHEN ZERO(EX1), LIST(INDET "==" ARB(#ARB)) EXIT, - WHEN FREE(EX1, INDET), FALSE EXIT, - BLOCK WHEN PRODUCT(EX1), LEX1: REST(EX1) EXIT, - LEX1: LIST(EX1) - ENDBLOCK, - LOOP - EX1: NUM(EXPD(POP(LEX1))), - BLOCK - WHEN SUM(EX1), - LEX3:REST(EX1), EX6:EX7:EX8:0, EX2:FALSE, - LOOP - EX3: POP(LEX3), - BLOCK WHEN FREE(EX3,INDET), EX6: EX6+EX3 EXIT, - EX4: EX5: 1, - BLOCK WHEN PRODUCT(EX3), LEX4: REST(EX3) EXIT, - LEX4: LIST(EX3) - ENDBLOCK, - LOOP - EX3: POP(LEX4), - BLOCK WHEN FREE(EX3, INDET), EX4: EX4*EX3 EXIT, - EX5: EX5*EX3 - ENDBLOCK, - WHEN ATOM(LEX4), EXIT - ENDLOOP, - WHEN EMPTY(EX2), EX7: EX4, EX2: EX5 EXIT, - WHEN EX5 = EX2, EX7: EX7+EX4 EXIT, - WHEN EX5 = EX2^2, EX8: EX8+EX4 EXIT, - WHEN EX5^2 = EX2 AND ZERO(EX8), EX8:EX7, EX7:EX4, EX2:EX5 EXIT, - EX2: 0 - ENDBLOCK, - WHEN ZERO(EX2), EX1: LIST (EX1 "==" 0) EXIT, - WHEN ATOM (LEX3), - WHEN ZERO(EX8), EX1: SOLF (-EX6/EX7) EXIT, - EX7: -EX7/(2*EX8), - EX6: EX6/EX8, - EX8: (EX7^2 - EX6)^(1/2), - EX1: UNION (SOLF(EX7+EX8), SOLF(EX7-EX8)) EXIT - ENDLOOP EXIT, - WHEN NOT FREE(EX1,INDET), - EX2: EX1, - EX1: SOLF(0) EXIT, - EX1: FALSE, - ENDBLOCK, - LEX2: UNION(EX1, LEX2), - WHEN ATOM (LEX1), LEX2 EXIT, - ENDLOOP, -ENDFUN $ - -PROPERTY PRTMATH, {, FUNCTION (LEX1, EX1), - PRINT ('{), - WHEN ATOM (LEX1), PRINT ('}) EXIT, - EX1: SPACES (), - LOOP - PRTMATH (POP(LEX1), 0, 0, TRUE), - WHEN ATOM (LEX1) EXIT, - PRINTLINE (COMMA), - SPACES (EX1), - ENDLOOP, - PRINT ('}), -ENDFUN $ - -FUNCTION SOLVE (EX1, INDET, TRGSQ, TRGEXPD, LOGEXPD), - TRGEXPD: LOGEXPD: -30, - TRGSQ: 1, - WHEN EMPTY(EX1) OR EMPTY(INDET), - ? (LIST(SOLVE, EX1, INDET)) EXIT, - WHEN FIRST(EX1) EQ '"==", - ADJOIN ('{, SOLEXP (SECOND(EX1)-THIRD(EX1))) EXIT, - ADJOIN ('{, SOLEXP(EX1)), -ENDFUN $ - -PROPERTY ATAN, INV, TAN $ -PROPERTY ASIN, INV, SIN $ -PROPERTY ACOS, INV, COS $ -PROPERTY ACOT, INV, COT $ -PROPERTY ASEC, INV, SEC $ -PROPERTY ACSC, INV, CSC $ - -PROPERTY TAN, PINV, ATAN $ -PROPERTY SIN, PINV, ASIN $ -PROPERTY COS, PINV, ACOS $ -PROPERTY COT, PINV, ACOT $ -PROPERTY SEC, PINV, ASEC $ -PROPERTY CSC, PINV, ACSC $ - -RDS() $ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/SOLVE4%.EQN b/software/CPM/CPM_MC_5/SOLVE4%.EQN deleted file mode 100644 index e462b2b..0000000 --- a/software/CPM/CPM_MC_5/SOLVE4%.EQN +++ /dev/null @@ -1,161 +0,0 @@ - file SOLVE4%.EQN GAE - Feb. 1982 -Make a file called SOLVE4.EQN as follows: -(1) Start with the existing file SOLVE.EQN. -(2) Delete the entire FUNCTION SOLEXP (about 50 lines). -(3) Insert in its place the entire file SOLVE4%.EQN below - this line: -------------------------------------------------------------- - -FUNCTION SOLEXP (EX1, - % Local: % EX2,EX3,EX4,EX5,EX6,EX7,EX8,EX9,EX10,LEX1,LEX2,LEX3,LEX4), - EX1: NUM (FCTR(EX1)), - BLOCK WHEN SUM(EX1), EX1: NUM(EXPD(EX1)) EXIT, - ENDBLOCK, - WHEN ZERO(EX1), LIST(INDET "==" ARB(#ARB)) EXIT, - WHEN FREE(EX1, INDET), FALSE EXIT, - BLOCK WHEN PRODUCT(EX1), LEX1: REST(EX1) EXIT, - LEX1: LIST(EX1) - ENDBLOCK, - LOOP - EX1: NUM(EXPD(POP(LEX1))), - BLOCK - WHEN SUM(EX1), - LEX3:REST(EX1), EX6:EX7:EX8:EX9:EX10:0, EX2:FALSE, - LOOP - EX3: POP(LEX3), - BLOCK WHEN FREE(EX3,INDET), EX6: EX6+EX3 EXIT, - EX4: EX5: 1, - BLOCK WHEN PRODUCT(EX3), LEX4: REST(EX3) EXIT, - LEX4: LIST(EX3) - ENDBLOCK, - LOOP - EX3: POP(LEX4), - BLOCK WHEN FREE(EX3, INDET), EX4: EX4*EX3 EXIT, - EX5: EX5*EX3 - ENDBLOCK, - WHEN ATOM(LEX4), EXIT - ENDLOOP, - WHEN EMPTY(EX2), EX7: EX4, EX2: EX5 EXIT, - WHEN EX5 = EX2, EX7: EX7+EX4 EXIT, - WHEN EX5 = EX2^2, EX8: EX8+EX4 EXIT, - WHEN EX5 = EX2^3, EX9: EX9+EX4 EXIT, - WHEN EX5 = EX2^4, EX10: EX10+EX4 EXIT, - WHEN NOT ZERO(EX9), EX2:0 EXIT, - WHEN NOT ZERO(EX10), EX2:0 EXIT, - WHEN EX5^2 = EX2, - EX10:EX8, EX8:EX7, EX7:EX4, EX2:EX5 EXIT, - WHEN NOT ZERO(EX8), EX2:0 EXIT, - WHEN EX5^3=EX2, - EX9:EX7, EX7:EX4, EX2:EX5 EXIT, - WHEN EX5^4=EX2, - EX10:EX7, EX7:EX4, EX2:EX5 EXIT, - WHEN EX5^3=EX2^2, - EX9: EX7, EX8: EX4, EX7: 0, EX2: EX2/EX5 EXIT, - WHEN EX5^2=EX2^2, - EX9: EX4, EX8: EX7, EX7: 0, EX2: EX5/EX2 EXIT, - EX2:0 - ENDBLOCK, - WHEN ZERO(EX2), EX1: LIST (EX1 "==" 0) EXIT, - WHEN ATOM (LEX3), - WHEN NOT ZERO(EX10), - EX1:BIQUAD1(EX6,EX7,EX8,EX9,EX10) EXIT, - WHEN NOT ZERO(EX9), - EX1:CUBIC1(EX6,EX7,EX8,EX9) EXIT, - WHEN NOT ZERO(EX8), - EX1:QUADRAT1(EX6,EX7,EX8) EXIT, - EX1:LINEAR1(EX6,EX7) EXIT, - ENDLOOP EXIT, - WHEN NOT FREE(EX1,INDET), - EX2: EX1, - EX1: SOLF(0) EXIT, - EX1: FALSE, - ENDBLOCK, - LEX2: UNION(EX1, LEX2), - WHEN ATOM (LEX1), LEX2 EXIT, - ENDLOOP, -ENDFUN $ - -FUNCTION LINEAR1(EX6,EX7), - % fluid : EX2 % - SOLF(-EX6/EX7), -ENDFUN $ - -FUNCTION QUADRAT1(EX6,EX7,EX8), - % fluid : EX2 % - EX6: QUADRAT(EX6,EX7,EX8), - UNION (SOLF(POP(EX6)),SOLF(POP(EX6))), -ENDFUN $ - -FUNCTION SQRT(EX1, - %local % PBRCH), - PBRCH: TRUE, - EX1^(1/2), -ENDFUN $ - -FUNCTION QUADRAT(EX6,EX7,EX8), - WHEN E6=0, ADJOIN(0,LINEAR(EX7,EX8)) EXIT, - EX6:SQRT(EX7^2-4*EX8*EX6), - LIST((-EX7+EX6)/(2*EX8), (-EX7-EX6)/(2*EX8)), -ENDFUN $ - -FUNCTION CUBIC1(EX6,EX7,EX8,EX9), - %fluid : EX2 % - EX6: CUBIC(EX6,EX7,EX8,EX9), - UNION(SOLF(POP(EX6)), - UNION(SOLF(POP(EX6)), - SOLF(POP(EX6)))), -ENDFUN $ - -#OMEGA: -1/2 + #I*3^(1/2)/2 $ -#OMSQ: -1/2 - #I*3^(1/2)/2 $ - -FUNCTION CUBRT(EX1, - % local : % PBRCH), - PBRCH: TRUE, - EX1^(1/3), -ENDFUN $ - -FUNCTION CUBIC(EX6,EX7,EX8,EX9) - WHEN EX6=0, ADJOIN(0,QUADRAT(EX7,EX8,EX9)) EXIT, - EX8: EX8/EX9, EX7: EX7/EX9, EX6: EX6/EX9, - EX6: QUADRAT((EX8^2-3*EX7)^3, 2*EX8^3-9*EX8*EX7+27*EX6,1), - EX9: CUBRT(POP(EX6)), - BLOCK - WHEN EX9=0, EX7: CUBRT(POP(EX6)) EXIT, - EX7: (EX8*EX8-3*EX7)/EX9, - ENDBLOCK, - LIST((-EX8+EX9+EX7)/3, - (-EX8+#OMSQ*EX9+#OMEGA*EX7)/3, - (-EX8+#OMEGA*EX9+#OMSQ*EX7)/3), -ENDFUN $ - -FUNCTION BIQUAD1(EX6,EX7,EX8,EX9,EX10), - %fluid : EX2 % - EX6: BIQUAD(EX6,EX7,EX8,EX9,EX10), - UNION(UNION(SOLF(POP(EX6)), - SOLF(POP(EX6))), - UNION(SOLF(POP(EX6)), - SOLF(POP(EX6)))), -ENDFUN $ - -FUNCTION BIQUAD(EX6,EX7,EX8,EX9,EX10, - % local : % EX1), - WHEN EX6=0, ADJOIN(0,CUBIC(EX7,EX8,EX9,EX10)) EXIT, - EX9: EX9/EX10, EX8: EX8/EX10, EX7: EX7/EX10, EX6: EX6/EX10, - EX1: CUBIC(-(EX9^3-4*EX9*EX8+8*EX7)^2, - 3*EX9^4-16*EX9*EX9*EX8+16*EX9*EX7+16*EX8*EX8-64*EX6, - -3*EX9*EX9+8*EX8, - 1), - EX10:SQRT(POP(EX1)), - EX6:SQRT(POP(EX1)), - BLOCK - WHEN EX10*EX6=0, EX8:SQRT(POP(EX1)) EXIT, - EX8:(-EX9^3+4*EX9*EX8-8*EX7)/(EX6*EX10), - ENDBLOCK, - LIST((-EX9+EX10+EX6+EX8)/4, - (-EX9+EX10-EX6-EX8)/4, - (-EX9-EX10+EX6-EX8)/4, - (-EX9-EX10-EX6+EX8)/4), -ENDFUN $ - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/TAYLOR.DIF b/software/CPM/CPM_MC_5/TAYLOR.DIF deleted file mode 100644 index 3bd2b57..0000000 --- a/software/CPM/CPM_MC_5/TAYLOR.DIF +++ /dev/null @@ -1,21 +0,0 @@ -% File: TAYLOR.DIF (c) 07/18/81 The Soft Warehouse % - - -FUNCTION TAYLOR (EXPN, X, A, N, - % Local % J, C, ANS, NUMNUM, DENNUM), - WHEN POSITIVE (N) OR ZERO (N), - NUMNUM: DENNUM: 30, - J: ANS: 0, - C: 1, - LOOP - ANS: ANS + C * EVSUB (EXPN, X, A), - WHEN J=N, ANS EXIT, - EXPN: DIF (EXPN, X), - J: J + 1, - C: C * (X-A) / J - ENDLOOP EXIT, - LIST ('TAYLOR, EXPN, X, A, N) -ENDFUN $ - -RDS () $ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/TAYLOR.MU b/software/CPM/CPM_MC_5/TAYLOR.MU deleted file mode 100644 index 729e52c..0000000 --- a/software/CPM/CPM_MC_5/TAYLOR.MU +++ /dev/null @@ -1,67 +0,0 @@ -% floating point Taylor series function % -% you must enter the expression and the % -% accuracy desired in number of digits % -% % -% NOTE: the float.mu package is required % -% The function must be one for which % -% muMath knows the value at point A % -% % -FUNCTION FLTTAY (EXPR,X,A,ACC,VAL,NUM,I,D,DONE,RES1,RES, - POINT,NUMNUM,DENNUM,DOT) - POINT:ACC, DOT:'., DONE:FALSE, - ACC: 1/RADIX()^ACC % accuracy of result % - NUMNUM:DENNUM:30, - RES:0, D:I:1, RES1: -(RADIX()^10), - PRINT("I'M THINKING ") - LOOP - PRINT(DOT) - RES: RES + EVSUB(EXPR,X,A) * D -% % -% now, test every so often, to see if % -% the series is converging or has met % -% the convergence criterion % -% % - BLOCK - WHEN I<3 EXIT - WHEN INTEGER(I/4), RES1:RES, EXIT - WHEN INTEGER(I/2), - WHEN ABS(RES-RES1) < ACC, NEWLINE(), - PRINT("ACCURACY REQUIRED "), PRTMATH(I), - PRINT("ITERATIONS"), NEWLINE(), - PRINT("ANSWER IS "), PRTMATH(RES), - DONE:TRUE, EXIT, - PRINT("ITERATION #"), PRINT(I) - PRINT(", CURRENT VALUE IS "), - PRTMATH(RES), NEWLINE(), EXIT - ENDBLOCK - WHEN DONE, NEWLINE(), PRTMATH(RES), "" EXIT -% % -% now, if after 500 terms, we haven't % -% gotten there yet, we probably never will % -% % - WHEN I>500, - NEWLINE(), - PRINT("DID NOT CONVERGE"), NEWLINE(), - PRINT("VALUE IS "), PRTMATH(RES), NEWLINE(), - PRINT("NUMBER OF ITERATIONS "), I EXIT, - EXPR: DIF(EXPR,X) - I: I+1 - D: D * EVSUB((X-A)/(I-1),X,VAL) - ENDLOOP -ENDFUN $ % END_FLTTAY % -% % -% Calling Sequence % -% FLTTAY(fun, var, exp pt, #_of_digits, eval pt) % -% where fun = the function to be evaluated % -% accuracy = the number of digits desired % -% variable = the variable of the function % -% expansion point = the point of expansion % -% evaluation point = the point of evaluation % -% of the Taylor series % -% for example: FLTTAY(SIN(X),X,0,10,5716/100) % -% (this particular example also requires % -% the trigonometric packages to be loaded) % -% % -STOP() $ -RDS () $ -curacy desired in number of digits \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/TRACE.MUS b/software/CPM/CPM_MC_5/TRACE.MUS deleted file mode 100644 index e313fa1..0000000 --- a/software/CPM/CPM_MC_5/TRACE.MUS +++ /dev/null @@ -1,161 +0,0 @@ -% File TRACE.MUS (c) 10/01/80 The Soft Warehouse % - - -MOVD (FIRST, #FIRST) $ -MOVD (SECOND, #SECOND) $ -MOVD (REST, #REST) $ -MOVD (ADJOIN, #ADJOIN) $ -MOVD (EMPTY, #EMPTY) $ -MOVD (ATOM, #ATOM) $ -MOVD (MEMBER, #MEMBER) $ -MOVD (EVAL, #EVAL) $ -MOVD (APPLY, #APPLY) $ -MOVD (PLUS, #PLUS) $ -MOVD (LIST, #LIST) $ - -FUNCTION TRACE LEX1, - LOOP - WHEN #ATOM (LEX1) EXIT, - TRACE1 (POP (LEX1)), - ENDLOOP, -ENDFUN $ - -FUNCTION TRACE1 (FUNC, - % Local: % BODY, FUNC#), - BODY: GETD (FUNC), - WHEN #EMPTY (BODY), - PRINT ("UNDEFINED FUNCTION: "), - PRINTLINE (FUNC) EXIT, - WHEN FUNC EQ ':, - PRINTLINE ("CANNOT TRACE ':'") EXIT, - FUNC#: COMPRESS (#LIST (FUNC, ##)), - MOVD (FUNC, FUNC#), - WHEN SUBR (FUNC), - PUTD (FUNC, #LIST ('FUNCTION, 'ARG1, - #LIST (TRACE#, FUNC, 'ARG1, FUNC#))) EXIT, - WHEN FSUBR (FUNC), - PUTD (FUNC, #LIST ('SUBROUTINE, 'ARG1, - #LIST (TRACE#, FUNC, 'ARG1, FUNC#))) EXIT, - WHEN #FIRST (BODY) = 'FUNCTION, - PUTD (FUNC, #LIST ('FUNCTION, #SECOND (BODY), - #LIST (TRACE#, FUNC, #SECOND (BODY), FUNC#))) EXIT, - WHEN #FIRST (BODY) = 'SUBROUTINE, - PUTD (FUNC, #LIST ('SUBROUTINE, #SECOND (BODY), - #LIST (TRACE#, FUNC, #SECOND (BODY), FUNC#))) EXIT, - PRINT ("UNDEFINED FUNCTION: "), - PRINTLINE (FUNC), -ENDFUN $ - -FUNCTION SUBR (FUNC), - WHEN INTEGER (GETD (FUNC)), - #EMPTY (FSUBR (FUNC)) EXIT, -ENDFUN $ - -FUNCTION FSUBR (FUNC), - #MEMBER (FUNC, '(LIST, COND, AND, OR, LOOP, PUSH, POP)), -ENDFUN $ - - -FUNCTION UNTRACE LEX1, - LOOP - WHEN #ATOM (LEX1) EXIT, - UNTRACE1 (POP (LEX1)), - ENDLOOP, -ENDFUN $ - -FUNCTION UNTRACE1 (FUNC, - % Local: % FUNC#), - FUNC#: COMPRESS (#LIST (FUNC, ##)), - WHEN GETD (FUNC#), - MOVD (FUNC#, FUNC), - MOVD (FALSE, FUNC#) EXIT, -ENDFUN $ - - -SUBROUTINE TRACE# (FUNC, ARGS, FUNC#, LEX#), - PRTARGS# (FUNC, ARGS), - PRTRSLT# (FUNC, #APPLY (FUNC#, MKARGS# (ARGS))), -ENDSUB $ - -FUNCTION MKARGS# (ARGS), - WHEN #EMPTY (ARGS), FALSE EXIT, - WHEN #ATOM (ARGS), #EVAL (ARGS) EXIT, - #ADJOIN (#EVAL (POP (ARGS)), MKARGS# (ARGS)), -ENDFUN $ - -FUNCTION PRTARGS# (FUNC, ARGS), - SPACES (INDENT), - INDENT: #PLUS (INDENT, 1), - PRINT (FUNC), - PRINT (" ["), - WHEN #EMPTY (ARGS), - PRINTLINE (']) EXIT, - WHEN #ATOM (ARGS), - ARGS: #EVAL (ARGS), - LOOP - BLOCK - WHEN NOT MATHTRACE, - PRINT (POP (ARGS)) EXIT, - PRTMATH (POP (ARGS), 0, 0), - ENDBLOCK, - WHEN #ATOM (ARGS) EXIT, - PRINT (", "), - ENDLOOP, - PRINTLINE (']) EXIT, - LOOP - BLOCK - WHEN NOT MATHTRACE, - PRINT (#EVAL (POP (ARGS))) EXIT, - WHEN EXARG (#FIRST (ARGS)), - PRTMATH (#EVAL (POP (ARGS)), 0, 0) EXIT, - WHEN LEXARG (#FIRST (ARGS)), - PRINT (LPAR), - LEX#: #EVAL (POP (ARGS)), - WHEN #EMPTY (LEX#), PRINT (RPAR) EXIT, - LOOP - PRTMATH (POP(LEX#), 0, 0), - WHEN #EMPTY (LEX#), PRINT (RPAR) EXIT, - PRINT (", "), - ENDLOOP EXIT, - PRINT (#EVAL (POP (ARGS))), - ENDBLOCK, - WHEN FALSLST (ARGS) EXIT, - PRINT (", "), - ENDLOOP, - PRINTLINE (']), -ENDFUN $ - -FUNCTION FALSLST (ARGS), - LOOP - WHEN #EMPTY (ARGS) EXIT, - WHEN #ATOM (ARGS), FALSE EXIT, - WHEN #EVAL (POP (ARGS)), FALSE EXIT, - ENDLOOP, -ENDFUN $ - -FUNCTION EXARG (ARGS), - #MEMBER (ARGS, '(EX1, EX2, EX3, EX4, EX5)), -ENDFUN $ - -FUNCTION LEXARG (ARGS), - #MEMBER (ARGS, '(LEX1, LEX2, LEX3, LEX4)), -ENDFUN $ - -FUNCTION PRTRSLT# (FUNC, RSLT), - INDENT: #PLUS (INDENT, -1), - SPACES (INDENT), - PRINT (FUNC), - PRINT (" = "), - WHEN NOT MATHTRACE, - PRINTLINE (RSLT) EXIT, - PRTMATH (RSLT, 0, 0, TRUE), - NEWLINE(), - RSLT, -ENDFUN $ - -INDENT: 0 $ -MATHTRACE: TRUE $ - -RDS () $ - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/TRGNEG%.ALG b/software/CPM/CPM_MC_5/TRGNEG%.ALG deleted file mode 100644 index a3c7b21..0000000 --- a/software/CPM/CPM_MC_5/TRGNEG%.ALG +++ /dev/null @@ -1,79 +0,0 @@ - file TRGNEG%.ALG GAE - Feb. 1982 - -Make a new version of file TRGNEG.ALG as follows: -(1) Begin with the original file TRGNEG.ALG. -(2) Delete everything from FOURONPI: 4 / #PI $ - up to (but not including) PROPERTY SIN, *, - (more than 50 lines). -(3) Replace the deleted material with this file starting - below this line: -------------------------------------------------------------- - -FUNCTION SIN (EX1, - % Local: % EX2), - WHEN NEGLT (EX1), -SIN(-EX1) EXIT, - WHEN NUMBER(EX2:EX1/#PI), - COSPI(HALF - EX2) EXIT, - WHEN POSMULT (TRGEXPD, 7), - #I * (1/(EX2:#E^(#I*EX1)) - EX2) * HALF EXIT, - SIMPU ('SIN, EX1), -ENDFUN $ - -FUNCTION COS (EX1, - % Local: % EX2), - WHEN NEGLT (EX1), COS(-EX1) EXIT, - WHEN NUMBER(EX2:EX1/#PI), - COSPI(EX2) EXIT, - WHEN POSMULT (TRGEXPD, 7), - (1/(EX2:#E^(#I*EX1)) + EX2) * HALF EXIT, - SIMPU ('COS, EX1), -ENDFUN $ - - -ROOT5: 5^HALF $ -SIXRT5: 6*ROOT5 $ - -COSPION5: ( 1+ROOT5)/4 $ -COS2PION5: (-1+ROOT5)/4 $ - -COSPION15: (-1+ROOT5+(30+SIXRT5)^HALF)/8 $ -COS2PION15: ( 1+ROOT5+(30-SIXRT5)^HALF)/8 $ -COS4PION15: ( 1-ROOT5+(30+SIXRT5)^HALF)/8 $ -COS7PION15: (-1-ROOT5+(30-SIXRT5)^HALF)/8 $ - - -FUNCTION COSPI(EX1, - % local : % EX2), - WHEN EX1 < 0, COSPI(-EX1) EXIT, - BLOCK - WHEN EX1 > 2, - EX1: EX1 - 2*QUOTIENT(NUM(EX1),2*DEN(EX1)) EXIT, - ENDBLOCK, - BLOCK - WHEN EX1 > 1, EX1: 2-EX1 EXIT, - ENDBLOCK, - WHEN MULTIPLE(DEN(EX1),2), - WHEN EX1 > HALF, -((1+COSPI(2*EX1))*HALF)^HALF EXIT, - ((1+COSPI(2*EX1))*HALF)^HALF EXIT, - EX1: DIVIDE(NUM(EX1), EX2: DEN(EX1)), - WHEN MOD(POP(EX1),2) = 1, -COSPI1(EX1,EX2) EXIT, - COSPI1(EX1,EX2), -ENDFUN $ - -FUNCTION COSPI1(EX1,EX2), - WHEN EX1 EQ 0, 1 EXIT, - WHEN LESSER (EX2, 2*EX1), -COSPI1(EX2-EX1,EX2) EXIT, - WHEN EX2 EQ 3, HALF EXIT, - WHEN EX2 EQ 5, - WHEN EX1 EQ 1, COSPION5 EXIT, - COS2PION5 EXIT, - WHEN EX2 EQ 15, - WHEN EX1 EQ 1, COSPION15 EXIT, - WHEN EX1 EQ 2, COS2PION15 EXIT, - WHEN EX1 EQ 4, COS4PION15 EXIT, - COS7PION15 EXIT, - LIST('COS,#PI*EX1/EX2), -ENDFUN $ - - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/TRGNEG.ALG b/software/CPM/CPM_MC_5/TRGNEG.ALG deleted file mode 100644 index 64c762a..0000000 --- a/software/CPM/CPM_MC_5/TRGNEG.ALG +++ /dev/null @@ -1,154 +0,0 @@ -% File TRGNEG.ALG (c) 08/05/81 The Soft Warehouse % - -HALF: 1/2 $ - -FUNCTION NEGLT (EX1), - WHEN SUM (EX1), - WHEN POSMULT (NUMNUM, 2), - NEGCOEF (SECOND(EX1)) EXIT EXIT, - NEGCOEF (EX1), -ENDFUN $ - -FUNCTION MULTANGLE (EX1, EX2, EX3, EX4), - WHEN ZERO(EX1), EX4 EXIT, - WHEN POSITIVE (EX1), MULTANGLE1 (EX1, EX3, EX4) EXIT, -ENDFUN $ - -FUNCTION MULTANGLE1 (EX1, EX3, EX4), - % Fluid var from MULTANGLE: EX2 % - WHEN EX1 EQ 1, EX3 EXIT, - MULTANGLE1 (EX1 - 1, EX2*EX3 - EX4, EX3), -ENDFUN $ - -FOURONPI: 4 / #PI $ - -FUNCTION SIN (EX1, - % Local: % EX2), - WHEN NEGLT (EX1), -SIN(-EX1) EXIT, - WHEN NUMBER(EX2:EX1*FOURONPI), - EX1: DIVIDE (NUM(EX2), EX2:DEN(EX2)), - SINCOS (MOD(POP(EX1),8), EX1/EX2) EXIT, - WHEN POSMULT (TRGEXPD, 7), - #I * (1/(EX2:#E^(#I*EX1)) - EX2) * HALF EXIT, - SIMPU ('SIN, EX1), -ENDFUN $ - -FUNCTION COS (EX1, - % Local: % EX2), - WHEN NEGLT (EX1), COS(-EX1) EXIT, - WHEN NUMBER(EX2:EX1*FOURONPI), - EX1: DIVIDE (NUM(EX2), EX2:DEN(EX2)), - SINCOS (MOD(2+POP(EX1),8), EX1/EX2) EXIT, - WHEN POSMULT (TRGEXPD, 7), - (1/(EX2:#E^(#I*EX1)) + EX2) * HALF EXIT, - SIMPU ('COS, EX1), -ENDFUN $ - -FUNCTION SINCOS (EX1, EX2), - WHEN LESSER(3,EX1), -SINCOS(EX1-4, EX2) EXIT, - WHEN ZERO(EX1), SIN1(EX2) EXIT, - WHEN EX1 EQ 1, COS1(1-EX2) EXIT, - WHEN EX1 EQ 2, COS1(EX2) EXIT, - SIN1(1-EX2), -ENDFUN $ - -PION4: 1/FOURONPI $ -ONRT2: 2^-HALF $ -TWO3RDS: 2/3 $ - -FUNCTION SIN1 (EX1), - WHEN ZERO(EX1), EX1 EXIT, - WHEN EX1 EQ 1, ONRT2 EXIT, - WHEN EX1 = TWO3RDS, HALF EXIT, - LIST ('SIN, EX1*PION4), -ENDFUN $ - -RT3ON2: 3^HALF * HALF $ - -FUNCTION COS1 (EX1), - WHEN ZERO(EX1), 1 EXIT, - WHEN EX1 EQ 1, ONRT2 EXIT, - WHEN EX1 = TWO3RDS, RT3ON2 EXIT, - LIST ('COS, EX1*PION4), -ENDFUN $ - -PROPERTY SIN, *, FUNCTION (EX1, EX2), - WHEN NEGMULT (TRGEXPD, 3), - MULTANGLE (EX1, 2*COS(EX2), SIN(EX2), 0) EXIT, -ENDFUN $ - -PROPERTY COS, *, FUNCTION (EX1, EX2), - WHEN NEGMULT (TRGEXPD, 3), - MULTANGLE (EX1, 2*COS(EX2), COS(EX2), 1) EXIT, -ENDFUN $ - -PROPERTY SIN, +, FUNCTION (EX1, EX2), - WHEN NEGMULT (TRGEXPD, 5), - SIN(EX1)*COS(EX2) + COS(EX1)*SIN(EX2) EXIT, -ENDFUN $ - -PROPERTY COS, +, FUNCTION (EX1, EX2), - WHEN NEGMULT (TRGEXPD, 5), - COS(EX1)*COS(EX2) - SIN(EX1)*SIN(EX2) EXIT, -ENDFUN $ - -PROPERTY BASE, TAN, FUNCTION (EX1, EX2), - WHEN EX1<0, - WHEN NEGMULT(TRGEXPD,2), COT(EX2) ^ -EX1 EXIT EXIT, -ENDFUN $ - -PROPERTY BASE, COT, FUNCTION (EX1, EX2), - WHEN EX1<0, - WHEN NEGMULT(TRGEXPD,2), TAN(EX2) ^ -EX1 EXIT EXIT, -ENDFUN $ - -PROPERTY BASE, SEC, FUNCTION (EX1, EX2), - WHEN EX1<0, - WHEN NEGMULT(TRGEXPD,2), COS(EX2) ^ -EX1 EXIT EXIT, -ENDFUN $ - -PROPERTY BASE, CSC, FUNCTION (EX1, EX2), - WHEN EX1<0, - WHEN NEGMULT(TRGEXPD,2), SIN(EX2) ^ -EX1 EXIT EXIT, -ENDFUN $ - -PROPERTY *, TAN, FUNCTION (EX1, EX2), - WHEN SECOND(EX1)=EX2, - WHEN FIRST(EX1) EQ 'COS, SIN(EX2) EXIT, - WHEN FIRST(EX1) EQ 'COT, 1 EXIT EXIT, -ENDFUN $ - -PROPERTY *, COT, FUNCTION (EX1, EX2), - WHEN FIRST(EX1) EQ 'SIN, - WHEN SECOND(EX1)=EX2, COS(EX2) EXIT EXIT, -ENDFUN $ - -PROPERTY *, SEC, FUNCTION (EX1, EX2), - WHEN NOT ATOM(EX1), - WHEN SECOND(EX1)=EX2, - WHEN (EX1:FIRST(EX1)) EQ 'COS, 1 EXIT, - WHEN EX1 EQ 'SIN, TAN(EX2) EXIT , - WHEN EX1 EQ 'COT, CSC(EX2) EXIT EXIT EXIT, -ENDFUN $ - -PROPERTY *, CSC, FUNCTION (EX1, EX2), - WHEN NOT ATOM(EX1), - WHEN SECOND(EX1)=EX2, - WHEN (EX1:FIRST(EX1)) EQ 'SIN, 1 EXIT, - WHEN EX1 EQ 'COS, COT(EX2) EXIT, - WHEN EX1 EQ 'TAN, SEC(EX2) EXIT EXIT EXIT, -ENDFUN $ - -PROPERTY TAN, ATAN, IDENTITY $ -PROPERTY SIN, ASIN, IDENTITY $ -PROPERTY COS, ACOS, IDENTITY $ -PROPERTY COT, ACOT, IDENTITY $ -PROPERTY CSC, ACSC, IDENTITY $ -PROPERTY SEC, ASEC, IDENTITY $ - -FUNCTION TRGEXPD (EX1, TRGEXPD), - EVAL (EX1), -ENDFUN $ - -RDS() $ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/TRGPOS.ALG b/software/CPM/CPM_MC_5/TRGPOS.ALG deleted file mode 100644 index 1514e80..0000000 --- a/software/CPM/CPM_MC_5/TRGPOS.ALG +++ /dev/null @@ -1,102 +0,0 @@ -% File TRGPOS.ALG (c) 8/29/80 The Soft Warehouse % - - -FUNCTION NEGLT(EX1), - WHEN SUM(EX1), - WHEN POSMULT(NUMNUM,2), NEGCOEF(SECOND(EX1)) EXIT EXIT, - NEGCOEF(EX1), -ENDFUN $ - -FUNCTION SIN (EX1), - WHEN ZERO(EX1), EX1 EXIT, - WHEN NEGLT (EX1), -SIN(-EX1) EXIT, - SIMPU ('SIN, EX1), -ENDFUN $ - -FUNCTION COS (EX1), - WHEN ZERO(EX1), 1 EXIT, - WHEN NEGLT (EX1), COS(-EX1) EXIT, - SIMPU ('COS, EX1), -ENDFUN $ - -FUNCTION TAN (EX1), - WHEN NEGLT(EX1), -TAN(-EX1) EXIT, - WHEN POSMULT(TRGEXPD,2), SIN(EX1)/COS(EX1) EXIT, - SIMPU('TAN, EX1), -ENDFUN $ - -FUNCTION COT (EX1), - WHEN NEGLT(EX1), -COT(-EX1) EXIT, - WHEN POSMULT(TRGEXPD,2), COS(EX1)/SIN(EX1) EXIT, - SIMPU('COT, EX1), -ENDFUN $ - -FUNCTION CSC (EX1), - WHEN POSMULT(TRGEXPD,2), SIN(EX1)^-1 EXIT, - SIMPU ('CSC, EX1), -ENDFUN $ - -FUNCTION SEC (EX1), - WHEN POSMULT(TRGEXPD,2), COS(EX1)^-1 EXIT, - SIMPU ('SEC, EX1), -ENDFUN $ - - -HALF: 1/2 $ - -TRGSQ: 0 $ - -PUSH ('TRGSQ, FLAGS) $ - -PROPERTY BASE, SIN, FUNCTION (EX1, EX2), - WHEN POSITIVE (EX1) AND POSMULT (TRGEXPD, 3), - SIN(EX2)^(EX1-2) * (HALF - COS(2*EX2)*HALF) EXIT, - WHEN LESSER (EX1, -1) AND POSMULT (TRGEXPD, 3), - (SIN(EX2)^-EX1) ^ -1 EXIT, - WHEN EX1 < 0 AND NEGMULT (TRGEXPD, 2), - CSC(EX2) ^ -EX1 EXIT, - WHEN POSITIVE (EX1) AND NEGATIVE (TRGSQ), - (1-COS(EX2)^2)^QUOTIENT(EX1,2) * SIN(EX2)^MOD(EX1,2) EXIT, - WHEN LESSER (EX1, -1) AND NEGATIVE (TRGSQ), - EX1: -EX1, - ((1-COS(EX2)^2)^QUOTIENT(EX1,2) * SIN(EX2)^MOD(EX1,2))^-1 - EXIT, -ENDFUN $ - -PROPERTY BASE, COS, FUNCTION (EX1, EX2), - WHEN POSITIVE (EX1) AND POSMULT (TRGEXPD, 3), - COS(EX2)^(EX1-2) * (HALF + COS(2*EX2)*HALF) EXIT, - WHEN LESSER (EX1, -1) AND POSMULT (TRGEXPD, 3), - (COS(EX2)^-EX1) ^ -1 EXIT, - WHEN EX1 < 0 AND NEGMULT (TRGEXPD, 2), - SEC(EX2) ^ -EX1 EXIT, - WHEN POSITIVE (EX1) AND POSITIVE (TRGSQ), - (1-SIN(EX2)^2)^QUOTIENT(EX1,2) * COS(EX2)^MOD(EX1,2) EXIT, - WHEN LESSER (EX1, -1) AND POSITIVE (TRGSQ), - EX1: -EX1, - ((1-SIN(EX2)^2)^QUOTIENT(EX1,2) * COS(EX2)^MOD(EX1,2))^-1, - EXIT, -ENDFUN $ - -PROPERTY *, SIN, FUNCTION (EX1, EX2), - WHEN POSMULT (TRGEXPD, 5), - WHEN FIRST(EX1) EQ 'SIN, - EX1: SECOND (EX1), - HALF*COS(EX1-EX2) - HALF*COS(EX1+EX2) EXIT, - WHEN FIRST(EX1) EQ 'COS, - EX1: SECOND (EX1), - HALF*SIN(EX1+EX2) - HALF*SIN(EX1-EX2) EXIT EXIT, -ENDFUN $ - -PROPERTY *, COS, FUNCTION (EX1, EX2), - WHEN POSMULT (TRGEXPD, 5), - WHEN FIRST(EX1) EQ 'SIN, - EX1: SECOND (EX1), - HALF*SIN(EX1+EX2) + HALF*SIN(EX1-EX2) EXIT, - WHEN FIRST(EX1) EQ 'COS, - EX1: SECOND (EX1), - HALF*COS(EX1-EX2) + HALF*COS(EX1+EX2) EXIT EXIT, -ENDFUN $ - -RDS() $ - \ No newline at end of file diff --git a/software/CPM/CPM_MC_5/UNPARSE.MUS b/software/CPM/CPM_MC_5/UNPARSE.MUS deleted file mode 100644 index 51d2558..0000000 --- a/software/CPM/CPM_MC_5/UNPARSE.MUS +++ /dev/null @@ -1,191 +0,0 @@ -FUNCTION DISPFUN (F#U#N#, LEX1), - NEWLINE(), NEWLINE(), - UNPARSE(0, FALSE, LIST(GETD(F#U#N#))), - PRINT(""), -ENDFUN $ -F#U#N#: ""$ -FUNCTION PRTARGS(IDENT, LEX1), - SPACES(1), - WHEN EMPTY(LEX1), PRINT("()") EXIT, - WHEN ATOM(LEX1), QUOTEPRINT(LEX1) EXIT, - WHEN DPAIR(LEX1), PRINTDPAIR(LEX1) EXIT - PRINT(LPAR), - LOOP - UNPARSE(IDENT, FALSE, LIST(FIRST(LEX1))), - WHEN EMPTY(LEX1:REST(LEX1)) EXIT - PRINT(COMMA), SPACES(1), - ENDLOOP, - PRINT(RPAR), -ENDFUN $ -PROPERTY UNPARSE, ', FUNCTION(IDENT,LEX1), - PRINT(''), - PRTARGS(IDENT, FIRST(LEX1)), - TRUE, -ENDFUN $ -PROPERTY UNPARSE, NOT, FUNCTION(IDENT,LEX1), - PRINT('NOT), SPACES(1), - UNPARSE(IDENT, FALSE, LEX1), - TRUE, -ENDFUN $ -PROPERTY UNPARSE, FUNCTION, FUNCTION(IDENT,LEX1), - PRINT('FUNCTION), SPACES(1), PRINT(F#U#N), F#U#N: "", - PRTARGS(IDENT, FIRST(LEX1)), - UNPARSE(IDENT+2, TRUE, REST(LEX1)), - PRNTLINE(IDENT), PRINT('ENDFUN), -ENDFUN $ -PROPERTY UNPARSE, SUBROUTINE, FUNCTION(IDENT,LEX1), - PRINT('SUBROUTINE), SPACES(1), PRINT(F#U#N), F#U#N: "", - PRTARGS(IDENT, FIRST(LEX1)), - UNPARSE(IDENT+2, TRUE, REST(LEX1)), - PRNTLINE(IDENT), PRINT('ENDSUB), -ENDFUN $ -PROPERTY UNPARSE, LOOP, FUNCTION(IDENT,LEX1), - PRINTLINE('LOOP), SPACES(IDENT+2), - UNPARSE(IDENT+2, FALSE, LEX1), - PRNTLINE(IDENT), PRINT('ENDLOOP), -ENDFUN $ -FUNCTION UNPARSE(IDENT, EOL, LEX1, LEX2), - WHEN EMPTY(LEX1) EXIT, - LEX2:FIRST(LEX1), - WHEN DPAIR(LEX2), PRINTDPAIR(LEX2) EXIT, - WHEN ATOM(LEX2), - BLOCK - WHEN EOL, PRNTLINE(IDENT) EXIT, - ENDBLOCK, - QUOTEPRINT(LEX2) EXIT, - BLOCK - WHEN EOL, PRNTLINE(IDENT) EXIT, - ENDBLOCK, - WHEN ATOM(FIRST(LEX2)), - UNPARSEFUN(IDENT,LEX2), - UNPARSE(IDENT, TRUE, REST(LEX1)) EXIT, - WHEN ATOM(FIRST(FIRST(LEX2))), - UNPARSEWHEN(IDENT,LEX2), - UNPARSE(IDENT, TRUE, REST(LEX1)) EXIT, - UNPARSEBLOCK(IDENT, LEX2), - UNPARSE(IDENT, TRUE, REST(LEX1)), -ENDFUN $ -FUNCTION UNPARSEFUN(IDENT, LEX1, LEX2), - LEX2:FIRST(LEX1), - WHEN INTEGER(LEX2), PRINT(''), - PRTARGS(IDENT,LEX1) EXIT, - WHEN APPLY(GET(UNPARSE, LEX2), LIST(IDENT,REST(LEX1))) EXIT, - WHEN GET('LBP, LEX2), - WHEN EMPTY(RREST(LEX1)), - PRINT(LEX2), - SPACES(1), - UNPARSE(IDENT, FALSE, REST(LEX1)) EXIT, - UNPARSE(IDENT, FALSE, LIST(SECOND(LEX1))), - SPACES(1), PRINT(LEX2), SPACES(1), - UNPARSE(IDENT, FALSE, RREST(LEX1)) EXIT, - PRINT(LEX2), - PRTARGS(IDENT, REST(LEX1)), -ENDFUN $ -FUNCTION UNPARSEWHEN (IDENT, LEX1), - PRINT ('WHEN), SPACES(1), - UNPARSE(IDENT+2, FALSE, LEX1), - SPACES(1), PRINT('EXIT), -ENDFUN $ -FUNCTION UNPARSEBLOCK (IDENT, LEX1), - PRINTLINE('BLOCK), SPACES(IDENT+2), - UNPARSE(IDENT+2, FALSE, LEX1), - PRNTLINE(IDENT), - PRINT('ENDBLOCK), -ENDFUN $ -FUNCTION DPAIR(LEX1), - WHEN ATOM(LEX1), FALSE EXIT, - WHEN EMPTY(REST(LEX1)), FALSE EXIT, - ATOM(FIRST(LEX1)) AND ATOM(REST(LEX1)), -ENDFUN $ -FUNCTION PRINTDPAIR(LEX1), - PRINT(LPAR), QUOTEPRINT(FIRST(LEX1)), - PRINT(". "), QUOTEPRINT(REST(LEX1)), - PRINT(RPAR), -ENDFUN $ -FUNCTION PRNTLINE(IDENT), - PRINTLINE(COMMA, SPACES(IDENT), -ENDFUN $ -MOVD(PRINT, QUOTEPRINT) $ -FUNCTION QUOTEPRINT(EX1,EX2,LEX1,LEX2), - WHEN INTEGER(EX1), PRINT(EX1) EXIT, - WHEN LENGTH(EX1)=0, PRINT("""""") EXIT, - LEX1:EXPLODE(EX1), - BLOCK - WHEN DIGIT(FIRST(LEX2)), - EX2:TRUE EXIT, - LEX2:LEX1, - LOOP - WHEN WILDCHAR(FIRST(LEX2)), - EX2:TRUE EXIT, - LEX2:REST(LEX2), - WHEN EMPTY(LEX2) EXIT, - ENDLOOP, - ENDBLOCK, - WHEN NOT EX2, PRINT(EX1) EXIT, - PRINT(""""), - LOOP - BLOCK - WHEN PRINT(FIRST(LEX1))="""", - PRINT("""") EXIT, - ENDBLOCK, - LEX1:REST(LEX1), - WHEN EMPTY(LEX1) EXIT, - ENDLOOP, - PRINT(""""), -ENDFUN $ -FUNCTION WILDCHAR(EX1), - MEMBER(EX1, LIST('" ", '!, '"""", '$, '"%", '&, '', LPAR, RPAR, '*, '+, -COMMA, '-, '., '/, ':, ';, '<, '>, '=, '?, '^)), -ENDFUN $ -FUNCTION DIGIT(EX1), - MEMBER(EX1, '("0","1","2","3","4","5","6","7","8","9")) -ENDFUN $ -SUBROUTINE WRITEFILE LEX1 - WRITEFILE1(FIRST(LEX1), REST(LEX1)), -ENDSUB $ -FUNCTION WRITEFILE1(LEX1, LEX2), - WRS(FIRST(LEX1), SECOND(LEX1), THIRD(LEX1)), - LOOP - WHEN EMPTY(LEX2) EXIT, - PRINTFUN(FIRST(LEX2)), - PRINTVAL(FIRST(LEX2)), - PRINTPROPS(FIRST(LEX2)), - LEX2:REST(LEX2), - ENDLOOP, - NEWLINE(), NEWLINE(), - PRINT("RDS () $"), - WRS(), - FIRST(LEX1), -ENDFUN $ -FUNCTION PRINTFUN(EX1), - WHEN ATOM(GETD(EX1)) EXIT, - DISPFUN(EX1), - PRINT('$), -ENDFUN $ -FUNCTION PRINTVAL(EX1), - WHEN FIRST(EX1)=EX1 EXIT, - NEWLINE(), NEWLINE(), - QUOTEPRINT(EX1), PRINT(" : "), - UNPARSE(2, FALSE, LIST(FIRST(EX1))), - PRINTLINE('$), -ENDFUN $ -FUNCTION PRINTPROPS(LEX1, LEX2), - WHEN ATOM(LEX2:REST(LEX1)) EXIT, - LOOP - WHEN EMPTY(LEX2) EXIT, - NEWLINE(), NEWLINE(), - PRINT('PROPERTY), - SPACES(1), QUOTEPRINT(LEX1), - PRINT(", "), PRINT(FIRST(FIRST(LEX2))), - UNPARSE(2, TRUE, LIST(REST(FIRST(LEX2)))), - PRINTLINE('$), - LEX2:REST(LEX2), - ENDLOOP -ENDFUN $ -STOP() $ -RDS () $ -TEPRINT(REST(LEX1)), - PRINT(RPAR), -ENDFUN $ -FUNCTION PRNTLINE(IDENT), - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C0/-(C)1988 b/software/CPM/CPM_MC_C0/-(C)1988 deleted file mode 100644 index e69de29..0000000 diff --git a/software/CPM/CPM_MC_C0/-BGII.134 b/software/CPM/CPM_MC_C0/-BGII.134 deleted file mode 100644 index e69de29..0000000 diff --git a/software/CPM/CPM_MC_C0/-PLUPERF.SYS b/software/CPM/CPM_MC_C0/-PLUPERF.SYS deleted file mode 100644 index e69de29..0000000 diff --git a/software/CPM/CPM_MC_C0/BG.HLP b/software/CPM/CPM_MC_C0/BG.HLP deleted file mode 100644 index 0af5892..0000000 --- a/software/CPM/CPM_MC_C0/BG.HLP +++ /dev/null @@ -1,495 +0,0 @@ -; -  BackGrounder ii commands -- Enter letter/number from this menu  - -F - features summary H - HELP -B - BG 1 - CALC -C - CUT, PASTE 2 - SCREEN -D - DIR, FIND, ERA 3 - SPOOL, FORMS, PRINTR -E - ECHO, FEED, CLS 4 - SHIFT -G - GET, GO, JUMP, SAVE -J - JOT -K - KEYS -L - LIST, TYPE -N - NDR, OCP -P - PEEK, POKE -R - RESET, ^C -S - SWAP, FLIP -T - TIME, DATE -W - WHL, WHLQ, NOTE - -:F :BGINFO.HLP -:H -  HELP - display/print indexed help file  - -HELP - - Display this file (BG.HLP). - -HELP [DU:]filename - - Display named help file. - - -Use these controls: - - M return to Menu - S return to Start (top-level menu) - N,, display Next screen - L display Last screen - exit from help - P Print screen - -:B -  BG - review commands, remove BackGrounder ii  - -BG - - Show active tasks and attached key-definitions. - If Quiet not set, list the available BackGrounder ii commands. - -BG OFF - - Remove BackGrounder ii from memory and warm boot. - -BG Q - Prompt Quietly, without listing commands. - -BG V - Prompt Verbosely, listing commands. - -BG Y - Yes, enable and keys. - -BG N - No, disable and keys. -:C -  CUT and PASTE  - (requires a loaded screendriver) - -CUT - - Copies rectangular region of screen to a buffer. - - Move the cursor to upper-left corner of region to be clipped. - Type 'X'. - Move the cursor to bottom-right corner of region. - Type 'X' or . - -PASTE - - Returns last-clipped region to current program, at the - current cursor. - - A is added to the end of each clipped row. -:D -  DIR - file directory  - -DIR - List all non-system files with sizes in current drive/user. - -DIR Du:filespec - - List all matching non-system files with sizes in specified drive/user. - -DIR /fas - - options are: F - filesizes (reverses configured setting) - A - all = both Directory and System files. - S - System files only - - -DIR Du:filespec /fas - - Specified files, with specified options - - -  FIND - find files, ERA - erase  - -FIND D:filespec - - Find all matching files on specified drive, in all user areas. - -ERA filespec [v] - - Erase specified files. Verify first if V. -:E -  Echo - display input on console or printer  - -ECHO string - - Display string (uppercase) on console - -ECHO $string - - Display string (uppercase) on printer. - -FEED - - Eject printer page (formfeed). - -CLS - - Clear the screen and home the cursor. -:G -  GET, JUMP, GO, SAVE - load, run, save file  - -GET addr [DU:]filename - - Load file at (hex) address. (foreground only) - -JUMP addr - - Run program starting at addr. (foreground only) - -GO - - Run program at normal start addr (100h). - GO will re-run the last program, provided - it is re-executable. (foreground only) - -SAVE nn[H] [DU:]filename [S] - - Save memory (starting at 100h) to file. - nn = decimal number of pages (100h each). - nnH = Hex number of pages - if 'S', nn = decimal number of Sectors (80h each). -:J -  JOT - take notes  - (requires a loaded screendriver) - -JOT - - Clear screen for taking notes. - - Use to delete a character, and other commands as listed. - will paste the last-clipped region at the cursor. - - To exit, type the character. - - The screen is appended to the JOTPAD file. - -JOT [DU:]filename - - Same, but append to the filename specified. -:K -  KEYS - Define, load, save, view, attach key strings  - -KEYS [Du:]filename - - Load definitions from filename.BG. - -KEYS - - Select from the menu: - D - Define a key - P - Paste last-cut region to key - R - begin Recording keystrokes - V - View current definitions - K - view single Key - S - Save current definitions to file - L - Load (previously-saved) key definitions - A - Attach definitions to program for auto-loading - - - Defining a key. - -To define a numeric keypad key, first press that key, -then enter keystrokes and terminate with the key. - -To define a main keyboard key, first press the key, followed -by the key to be defined, e.g. "\a". - -To erase a character, type , or control-X to start over. - -To enter hex characters, first type the '#' key. - -To enter a special character literally (Quote it), first type control-Q. - -If there is no screendriver, define the "r" key to be a screen-redraw -string appropriate to the running task. - - - Pasting to a key. - (requires a loaded screendriver) - -The Paste option uses the last-cut region to define a key. A -carriage-return (^M) is added to the end of each row. Edit as desired, -and terminate with . - - Viewing definitions. - -Use the View option to inspect the currently defined keys. The display -starts and ends with a colon ':' in order to indicate any spaces -included in the definition. - -To view a single defined key, use the K option. - - Keystroke Recording. - -Use the Record option to begin recording each keystroke. - -Recording is terminated by typing the previously-defined -key, or the key. Up to 255 keystrokes may be recorded. - - Saving definitions. - -Definitions may be saved for re-use when re-running a program. The Save -option requests a short descriptive label and a filename. Usually, it's -convenient to use the name of the current program. The filetype is -automatically set to ".BG ". - - - Loading definitions. - -Definitions may be (manually) loaded by selecting the Load option and -entering the filename of the definitions to use. The newly- loaded -definitions replace any previously loaded or defined strings. - -Definitions can be automatically loaded whenever a particular program is -run. To use this feature, Save the desired definitions to a suitable -filename. Then select the Attach option, give the name of the program, -and the name of the definitions file. The next time the program is run -these definitions will automatically be installed. - - Global and user-task definitions - -When BGii is first loaded, it contains a short list of global -definitions, which you can inspect by typing KEYS and then V. GLOBAL -definitions are available everywhere -- in Foreground and Background -CP/M and in either user task. You can add new definitions, save them, -load others, etc. by using the KEYS command at Foreground CP/M level. - -USER-TASK definitions are reserved for an active user task. To define -keys for a particular program, once it is running, type , KEYS -and D. These definitions are in effect only while this task is active, -not in Background CP/M and not in another task. They expire when the -program is exited, so if you want to preserve them you should , -use KEYS and the Save command. To cause them to be automatically loaded -with the next use of that program, use the Attach command also. - -If you use the same key for a user-task definition and a global -definition, the user-task definition takes precedence while the task is -active. The global definition remains in hiding and takes effect -everywhere else. -:L -  LIST and TYPE - print or display a file  - -LIST [DU:]filename - - Print file on printer. Expands tabs to 8 spaces. - -TYPE [DU:]filename - - Display file. The menu on the top line summarizes the keys: - - . = down 1 line , = up 1 line - > = down 1 page < = up 1 page - B = beginning E = end of file - R = scroll right L = scroll left - G = goto = enter string to search for - 1...9 = move that many pages in current direction - - Automatically unSQueezes a compressed file (forward only). - -:N -  NDR (Named DiRectory) and OCP (Overlay Command Processor)  - -NDR [DU:]filename - - Load filename.NDR as the Named DiRectory. - -OCP [DU:]filename - - Load filename.OCP as the Overlay Command Processor. - -:P -  PEEK and POKE - examine and change memory  - -PEEK addr1 [addr2] - - Display memory in hex and ascii from addr1 to addr2. - If no addr2, display approx. 256 bytes. - -PEEK - - Resume memory display from last address. - -POKE addr byte1 byte2 ... - - Change memory at addr to (hex) byte1 ... - -POKE addr $string - - Change memory at addr to (ascii) string. -:R -  RESET or CNTL-C - reset disk system  - -RESET or - - Close modified files, reset disk system, and - log in drive A: and current drive. - - Use this command to change disks. Be sure the running - program has completed writing any open files. - -:S -  SWAP and FLIP - switch to/view alternate task  - -SWAP - - Switch to the alternate task. If no alternate is active, - switch to alternate CP/M. - -FLIP - (requires a loaded screendriver) - - Display screen of the alternate task. - The next keypress restores the active screen. - -:T -  TIME and DATE - display time and date  (requires DateStamper) - -TIME TIME ALL - - Display current time. Display time and date. - -TIME ON - - Turn on time display for CP/M prompts. Example: 10:24 A0> - -TIME ON S - - Turn on time display with seconds for CP/M prompts: 10:24:03 A0> - -TIME OFF - - Turn off time display in prompts. - -DATE - - Display current date. - -:W -  WHL and WHLQ - wheel byte, NOTE - command comment  - -WHL - - Turn off "wheel byte." When the wheel byte is off, - only non-private programs can be run. - -WHL password - - Turn on "wheel byte". - -WHLQ - - Report "wheel byte" status - ON or OFF. - -NOTE comment - - Treat following text up to ';' or as a comment for the command. - -:1 -  CALC - decimal/hex calculator  -CALC - -Enter digits (with optional decimal point in decimal mode) -Enter operator: - + add - - subtract - X or * multiply - / divide - M or % modulus (remainder), hex mode only - N negate (change sign) - = final result -Enter: - SA, SB or SC to Store Entry in register A, B, or C. - RA, RB or RC to Recall register value to Entry register. - Q to Quit. - H toggle between Hex and Decimal modes. - -The final result (Entry register) can be recalled with -the calc key definition (initially a). - -Register values are preserved from the previous use of CALC. -:2 -  SCREEN - dump screen to printer or file  - (requires a loaded screendriver) - -SCREEN - - List the current (user-program) screen on the printer. - Command is disabled if spooling is active. - -SCREEN [DU:]filename - - Append the current (user-program) screen to the specified file. -:3 -  SPOOL, FORMS and PRINTR  - -To load the Spooler, run SPOOLER. To queue files for printing, run Q. - -SPOOL -SPOOL ON - - Activate Spooler and send current list device output - to SPOOL.$PL file on swap drive, user 0. - -SPOOL [DU:]filename - - Send list output to named file. - -SPOOL OFF - - Deactivate Spooler and optionally rename output file. - List output now goes to list device. - - -FORMS - - Show current forms setting for each list device. - If a form is set, the Spooler will only print files with - that form setting. No setting is displayed as "-". - -FORMS

- - Set the to use , reactivate Spooler. - - = C for CRT: - L for LPT: (parallel printer) - T for TTY: (serial printer) - U for UL1: (serial printer) - - = a single character (e.g. 'L' for letterhead) - -FORMS - - Clear form setting for to allow printing - all types of files. Reactivate Spooler. - -PRINTR - - Show current printer device, reactivate Spooler. - -PRINTR - - Set printer device ("iobyte"), reactivate Spooler. - - = C for CRT: - L for LPT: (parallel printer) - T for TTY: (serial printer) - U for UL1: (serial printer) - -:4 -  SHIFT - toggle numeric keypad  - (requires a loaded functionkey driver) - -SHIFT ON - - Shift keypad to accept and use BackGrounder ii definitions. - -SHIFT OFF - - Put keypad in numeric mode. -or each list device. - If a f \ No newline at end of file diff --git a/software/CPM/CPM_MC_C0/BG.REL b/software/CPM/CPM_MC_C0/BG.REL deleted file mode 100644 index 053d00e..0000000 Binary files a/software/CPM/CPM_MC_C0/BG.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/BG134.DOC b/software/CPM/CPM_MC_C0/BG134.DOC deleted file mode 100644 index 4a5a2e0..0000000 --- a/software/CPM/CPM_MC_C0/BG134.DOC +++ /dev/null @@ -1,311 +0,0 @@ - BackGrounder ii -- Additional Documentation for version 1.34 - - -Release: version 1.34 -From: Plu*Perfect Systems - 410 23rd St. << -- Note new address - Santa Monica CA 90402 -Date: October 28, 1989 - -Previous release: version: 1.13 - - - -- READ THIS !! -- - -You MUST replace earlier versions of BG.REL, LOADBG.COM and -SETBG.COM with the new files! The new ones incompatible with -earlier versions. - -Other new files are: - - BGHIST07.OCP Z-System command history shell and error-handler - Also included CP (file copy) command. - BGHIST.HLP help file for BGHIST - K8384FNK.DRV functionkey driver for Kaypros - ON!TVI.DRV screendriver for Oneac ON! - -BackGrounder ii has been significantly enhanced. This file -contains notes on the most important changes. You may wish to -print it out and insert into your user's manual, or otherwise -mark points of change in the manual. - - - -- Capsule Summary -- - -The BGii command processor is functionally almost identical to -ZCPR version 3.4. Users running a "Z34" system can run commands -under BGii just as they do under their Z System. - -BGii loads (with no patching required) into the following systems: - CP/M 2.2, ZSDOS 1.0, ZDDOS 1.0, ZRDOS 1.7 - -CALC now shows values in both decimal and hex, and a number can -be entered in either radix without changing mode. - -SETBG allows you to rename the BG commands. - -In a Z System, the BG OFF command now restores the RCP and IOP -addresses and sizes in the Z3 environment. - -ECHO allows display of lower-case characters. - -Executable (.COM) files that do not use key definitions can now -be loaded slightly faster, by setting the "noLoad" attribute bit -(f1) of the filename. - -The BGii command processor will only access the specific drives -that are available on your system. On a Z System these drives -are specified in the Z3 environment. On other systems use SETBG -to specify the available drives. - -The command-search hierarchy has been changed so that OCP and RCP -commands can override built-in BGii commands of the same name. - - - -- version 1.34 -- - -ERA command will skip read-only and system files now. - -When used in the background with ZSDOS and BDOS error trapping -enabled, HELP, TYPE and other commands that search a file path -will now be able to find a file in a user number that is not the -default user number. - -The screendriver is now correctly called with the upper/lower task -flag byte. - - -- More Details on version 1.30 -- - - BG OFF will now restore the RCP and IOP addresses and sizes in -the z3 environment. If the RCP space was used by BGii, the first -byte of the first rcp command (rcp+6) is set to 0. To restore -the CONTENTS of the rcp you should run JetLDR with the RCP's -name, probably as the first command after BG OFF. This can be -handled by an alias, say "BGOFF." - - -For upper and lower foreground tasks, BGii now copies the command -processor's current drive and current user into the message -buffer in a Z-System. These are read-only bytes -- if an -application changes them the actual logged DU: remains the same. -The BACKGROUND current DU: is not recorded in the message buffer; -as the FCP and RCP are disabled in background, this should have -no material effect. A background PEEK at those bytes, after a -background DU: command would show that they are not changed in -background. - - -ECHO supports: - - %> shift to lower case - %< shift to upper case - %% print a '%' - -If the noLoad bit (f1) is set in a COM file, loading is a bit faster -- -the check for an attached ".BG" key definitions file is skipped. If -you set this attribute bit for non-interactive programs and those -for which you don't expect to use a redraw string or key macros you -will get highest performance. - -The "BG" command now reports commands in search-order hierarchy: - OCP, if any - RCP, if any - CPR - -LOADBG now gets BDOS address from the extended environment, if -one. This should enable us to use BGii with non-standard DOS -locations and lengths, with a suitable BDOS id patch and a bdos -that conforms to BGii's patch and re-entry requirements. -Obviously something not yet tested, but a nice hook for an -eventual banked BDOS. - - -The command search hierarchy (p. 123) is: - 1. flow-control package (in a Z-system) - 2. overlay-command processor commands - 3. resident-command-package (in a Z-System) - 4. BGii command processor commands - 5. drive-user (DU:) or named-directory (DIR:) commands - 6. transient commands (COM files) - 7. extended command processor (CMDRUN.COM) - -The extended command processor can be invoked immediately by -preceeding a command with: - a SPACE - a '/' - -A transient command (COM file) can be invoked immediately by -preceeding the command with: - '.', or - ':', for a file in the path - DU: prefix, for a file in the specified DU: directory, then the path - - -Here's an example, assuming command-run is set: - - A0>WS will search the path for WS.COM - A0> WS will load CMDRUN (or other-named external command - processor and pass the command line "WS" to it. - -Another example: - - A0>PEEK peeks at memory with BGii's built-in command - A0> PEEK invokes the external command processor (e.g. to - process the alias "PEEK") - A0>:PEEK searches the path for PEEK.COM; if not found, - invokes the external command processor - A0:.PEEK does the same as ":PEEK" - A0>B12:PEEK searches B12:, then the path, then invokes - the external command processor - - -When run on a Z-System, BGii: - -- Loads both "type-4" and "type-3" environment files that run in high memory. - (p. 121) - -- Reports error codes to the Z-System message buffer for processing by an - external error handler. - -- BGii automatically detects a Z-System tool (one with "Z3ENV" - at offset 3 in the file) and installs the Z-System external - environment address. This is now also done for the GET command. - -- BGii is not identifiable as a ZCPR v 3.3 or v 3.4 command processor, - it does not support their "reparse" and "scan" entry points. - - -Functionkey drivers and screendrivers that depend on addresses in the -host computer's original BIOS (the "CBIOS") will now run under the -NZ-COM system. To do so, they must be modified to reference those -addresses indirectly, through a pointer to the CBIOS warmboot entry. -The following data structure must appear somewhere in the driver: - - db 'CBIOS' ; signature for LOADBG -cbios: dw 0000 ; pointer to cbios warmboot entry - - -DosDisk should normally not be run with BGii. To use DosDisk, -remove BGii with the command "BG OFF", load DosDisk and use the -MS-DOS disk, then remove DosDisk and re-install BGii. - - -The following z3 message buffer variables are not maintained -in the z3 environment area: - - subflag ; submit-running - - -The xsubflag is not supported. XSUB will not run with BGii -anyway; I believe it crashes the system, probably because of -failure to test for the presence of an rsx. - - - -- Notes from version 1.13 -- - - NEW AND CHANGED FEATURES - -1. BGii loads a bit faster than versions 1.0x. - -3. In a ZCPR3 system with a multiple-command line, LOADBG executes any - commands remaining on the command line. For example, if you load BGii - by typing the ZCPR3 command line: - - LOADBG;DIR A0:*.COM - - LOADBG will load BGii, run any pre-configured auto-command line, - and then run the DIR command. - -5. Information messages are now displayed by the "//" parameter - on a command line of most BGii utilities -- PUTBG, SPOOLER, Q - LOADBG, SECURE. - -6. PUTBG and LOADBG -- now support oddball disk drivers that use only 8 - of the 16 single-byte group numbers in each directory entry - (e.g. certain SWP co-power ramdisks and TVI computers). - - - BUGS CORRECTED: - -1. Submit files now execute correctly when using named-directories -or a TIME prompt. - -2. The background drive/user prompt is now correct when first -SUSPENDing from a program. - -3. The REName command now reports an error if the file cannot be found. - -4. The BG command now omits displaying RCP commands in Background -CP/M; (RCP commands can be run only from Foreground CP/M). - - - - ADDITIONS AND CHANGES TO USER'S MANUAL: - -1. p. 5. BackGrounder ii requires that DateStamper, if used, be loaded - "above the bios". See the DateStamper manual for instructions. - -2. p. 124. In the final line in the "State Determination" - section, change "1602h" to "15A8h". - -3. The CUT command, in most screendrivers, has a Cancel command. Type - Control-C to cancel the cutting operation. Some screendrivers allow - the cursor to be moved up and to the left after the first mark is set; - others, for lack of space, do not. - -4. p. 54, p. 118. No patches are required to add a redraw-screen - command to the NewWord editor. Its built-in command is ESC. - -5. pp 105 ff. Additional programmer's notes for coding a screendriver - are found in BGSCREEN.DOC. - -6. DIR Command (p. 67, 89) - - When displaying filesizes, DIR stutters a bit for large files. - This is normal, and unavoidable. The command must calculate the - size of a multi-extent file by reading the directory several - times; there is not enough memory available to store the directory - in memory. - - You can eliminate the jerkiness, and the filesizes, - by making "no filesize" the default configuration with SETBG, or - by using the "/F" flag, e.g. DIR *.DOC /F. - -7. CUT Command (pp. 36,66). When marking a region to be cut, typing - a Control-C will cancel the command. - - - OTHER NOTES - - -A number of users have requested additional features and also -pointed out a few anomolies. We're grateful for the suggestions, -have given consideration to each, and have been able to make a -number of enhancements. Unfortunately, BGii does have limits, -and several worthwhile ideas simply haven't been possible. - - Internals - -BGii corresponds most closely to these ZCPR34 options: - -fullget NO -duenv YES -aduenv YES -drvprefix YES -scancur NO -accptdu YES controlled by duok -accptdir YES -dufirst YES -pwcheck YES -wpass YES -skippath YES -fastecp YES -altspace YES char = '/' -altcolon YES char = '.' -rootonly controlled by SETBG parameter -badduecp YES -badcmdecp YES - -See the SETBG menus for user-settable variations. -the filesizes, - by making "no filesi \ No newline at end of file diff --git a/software/CPM/CPM_MC_C0/BGHIST.HLP b/software/CPM/CPM_MC_C0/BGHIST.HLP deleted file mode 100644 index 1d87770..0000000 --- a/software/CPM/CPM_MC_C0/BGHIST.HLP +++ /dev/null @@ -1,124 +0,0 @@ -: - BGii HISTORY and ERROR line editor controls - - back fwd delete delete delete - left right all - -Char ^S ^D BS,DEL ^G - -Word ^A ^F ^W ^T - -Cmd ^Q ^R ^Z - -Line ^E ^X ^Y ^U - -toggle: -ESC: command history recording (single token commands skipped) -^B: recall of Both tasks' commands -^V: insert/oVerwrite mode - -^L: Look (search) backward for matching partial command -^J: this help (LINEFEED) - - - -Prompt is: - = uppercase DU if upper-task, lower if lower task - / -[!+^] hr:mi Duu> -/ | \ -| | = ^ if INSERT active -| | -| = + if upper-task, - if lower-task and recall BOTH active -| -= ! if LOG active - -TIME ON/OFF controls hr:mi display in prompt. - - - - CP command - - CP [DU:|DIR:]destination=[DU:|DIR:]source (CP/M form) - -or, CP [DU:|DIR:]source [DU:|DIR:]destination (MS-DOS form) - - unambiguous name only. - -If DateStamper is active, destination file's DateStamp = source's DateStamp. - - - REGister command - - REG D or REG <-- Display Register Value - - REG Mreg <-- Decrement Register Value - REG -reg - - REG Preg <-- Increment Register Value - REG +reg - - REG Sreg value <-- Set Register Value - - where: reg = 0 ... 9 - value = 0 ... 255 - - -These are technical DOC-notes: April 13, 1987 - -They are provided in hopes that someone will be inspired to write -an editor to manipulate the history file! - -BGHIST.VAR is in user 0 on swap drive. - -BGHIST [n] invokes BGHIST as the history shell for currently-active -task. - n = size of swap file x 2K, default is n=1. - -On first task switch, run BGHIST again to install as alternate-task -shell. - - -BGERRH invokes the error-handler. It has the same editing controls -as BGHIST. - - -Data Structure for BGHIST.VAR - -Sector 0: -recorq: ds 1 ;NZ if record-line flag is on -insert: ds 1 ;NZ if insert-mode is on -skipq: ds 1 ;NZ if search/dispay only current task - ;i.e. Both is false -maxrec: ds 1 ;max. record number for VAR file size -newptr: ds 2 ;ptr to for next command line -topptr: ds 2 ;ptr to last-recorded history - ... - ds 2 -; -Sector 1...maxrec - command-line 1,NUL, command-line 2, NUL, ... - -The first byte of the command line has bit 7 set if the command -was entered in the LOWER task. - -Each recorded command line has a 2-byte pointer: - - ds 1 ;offset (0...7Fh) - ds 1 ;file record number (1...maxrec) - -The pointer list is terminated by a NUL record number. -E.g.: - -newptr: dw 0248 ;record 2, offset 48 will begin next line -topptr: dw 0204 ;most recently recorded command at rec2,off 4 - dw 0170 - dw 0112 - dw 0100 ;first line at rec. 1, offset 0 - dw 00xx ;no more - -Note that the pointers will wrap around when/if the file fills up, -beginning again with record 1 (not 0, which holds the pointers). - - - i \ No newline at end of file diff --git a/software/CPM/CPM_MC_C0/BGHIST07.OCP b/software/CPM/CPM_MC_C0/BGHIST07.OCP deleted file mode 100644 index 4b0957a..0000000 Binary files a/software/CPM/CPM_MC_C0/BGHIST07.OCP and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/BGINFO.HLP b/software/CPM/CPM_MC_C0/BGINFO.HLP deleted file mode 100644 index d393e81..0000000 --- a/software/CPM/CPM_MC_C0/BGINFO.HLP +++ /dev/null @@ -1,287 +0,0 @@ -HOW TO ORDER BackGrounder ii -BGii COMMANDS -FOREGROUND and BACKGROUND -TASK SWITCHING -TRANSFERRING DATA BETWEEN PROGRAMS -KEYBOARD EXTENSION FUNCTIONS -PRINT SPOOLING and BACKGROUND PRINTING -DIAGRAM OF BGii LEVELS -: - HOW TO ORDER BackGrounder ii - -You can obtain a serialized copy of BackGrounder ii from -Plu*Perfect Systems or an authorized distributor. The complete -version runs on all drives and loads more rapidly than the -demonstration version. It includes a printed and indexed user's -manual, as well as the Spooler and other BGii utilities. - -If you aren't yet using DateStamper to automatically time- and -date-stamp your files, consider adding this fundamental feature -to your system too. - - - BackGrounder ii $75 Please specify - DateStamper $45 preferred disk format - 6% sales tax in California ... with your order. - shipping & handling, each order $ 3 - -Plu*Perfect Systems Sage Microsystems East -Box 1494 1435 Centre St. -Idyllwild CA 92349 Newton Centre MA 02159 - -N. A. One-Eighty Group Echelon, Inc -P. O. Box 2781 885 N. San Antonio Rd. -Warminster PA 18974 Los Altos CA 94022 -: - BGii COMMANDS - -Type CP/M commands and parameters at the usual CP/M prompt. - -Multiple commands may be entered on a single line, separated by -the command separator (by default, a semicolon), for example: - - A0>dir a:*.com ; dir b: - -If a Named DiRectory file is loaded, Backgrounder will show the -current directory with both the DU and named forms, for example: - - A0:BASE:> - -You may use the convenient "DU" (drive-user) form or a named-directory -to specify a program: - - A0>b12:myprog or A0>PROGS:myprog - -Both forms will look on drive B, user number 12 for MYPROG.COM, -(assuming the B12: directory is named PROGS). -: - FOREGROUND and BACKGROUND - -BGii operates at three levels, shown in the diagram screen. - - -1. FOREGROUND CP/M - -This is the familiar "A0>" or "A prompt" level. - -You type in a command and CP/M either executes it from its -repertoire of built-in commands (DIR, ERA,...) or loads the .COM -file of that name and starts executing it. - - -2. USER/APPLICATIONS TASK - -This is the running COM program such as a text editor or -spreadsheet. The program needn't be on the currently-logged drive -(which is displayed by the Foreground CP/M prompt, e.g. "B4>"). - -BGii will look for the named COM program along the BGii "search path" -(which is configurable with SETBG). The default path searchs in -this order: - - 1) the logged drive and user number - 2) user number 0 of the logged drive - 3) user number 0 of the A: drive - -This means you can put commonly-used programs in A0: and BGii will -automatically find them, regardless of the drive/user you are -logged into. - - -3. BACKGROUND CP/M -WITHOUT EXITING from an applications program, you can put it "on -hold" to run the built-in BGii commands. - -To do this, press the key (default is CNTL-^), and you -will see the BACKGROUND CP/M prompt with the logged drive and -user number followed by a right-brace prompt character "}" -instead of the default prompt character ">", e.g. "A2}". - -In Background CP/M you can use the usual built-in commands, -such as DIR. In addition, special commands are available -to dump the screen, jot a note to a notepad file, and more. - -To return to your applications program, press again. -BGii will restore the screen and the computer memory to exactly -what it was when you interrupted your program, and you can -resume just where you left off. - -When you exit from your applications program you will, as usual, -return to the Foreground CP/M level and again see the familiar -prompt, e.g. "A2>". -: - TASK SWITCHING - -BGii lets you run a SECOND program while the original one is -still active. This feature is called "task switching" and is -activated by the special SWAP command. - -Suppose that you have started running a program, perhaps a -spreadsheet calculation, and need to interrupt it to write a -memorandum. When the spreadsheet is running you are at level 2 -in a user/application task (see diagram). Press to get -to the Background CP/M (level 3). - -Now, type the BGii command "SWAP". BGii will save the complete -spreadsheet program in its swap file and in a moment prompt you -with a new LOWER FOREGROUND CP/M prompt: "a2>". - - -It's just like Foreground CP/M, except that the drive is shown -with a lower-case letter. So you can start up your second -program (perhaps a text editor, such as WS) by typing in its -name. - -BGii will now be at the LOWER USER TASK level. It works just like -the normal user/applications level; behind the scenes BGii has -hidden away the first program for safekeeping. - -Eventually, you will want to resume the spreadsheet. If you've -finished the memo, you can exit from your editor to LOWER -FOREGROUND CP/M and the "a2>" prompt again. - - -But if you haven't finished -- perhaps you need some additional -data from the spreadsheet -- you can the editor to -reach Background CP/M and the prompt: "a2}". (The lower-case -drive letter indicates the lower task; the right-brace indicates -Background CP/M). - -From either Foreground or Background CP/M, you can now use the -SWAP command again to put the current program (the editor) on -hold and resume the spreadsheet, exactly where you left off! - -And you can repeatedly swap back and forth, each time by typing - and then SWAP. -: - TRANSFERRING DATA BETWEEN PROGRAMS - -Suppose you need a whole column of figures from the spreadsheet for -your memo. BGii gives you several ways of moving data shown on the -screen of one program into another. - -1. SCREEN - -First, you can use the background SCREEN command to write a copy of the -screen to a file. The file will capture the complete (24-line) screen, -except for any graphics characters. To do this, press at the -appropriate point in your program, then type: - - SCREEN filename - -using some appropriate filename. If your alternate program is a text -editor you can then SWAP to it, read in the screen-file, and add it to -your memo. - - - 2. CUT and PASTE -Second, you can use the background CUT command to mark a rectangular -region on the screen and have BGii save it for later use. To do this, -press and type CUT. The screen will be restored. - -Now you should use the cursor keys to move to the upper-left corner of -the region you want to "cut". When you get to the right point, type an -"X". Then move the cursor (to the right, or down, or both) to trace out -the rectangle you need. When you reach the bottom right corner, again -type "X" (or ). The region is now fully marked, automatically cut -and saved, and the screen restored. - -Next, type SWAP to switch to your editor, which is the alternate task. -Move the cursor to the point at which you want to put the just-cut -information. Then type and this time type PASTE. BGii will -now send each row of the cut region to your editor, followed by a -character. If your cursor was at the left margin, the information will -look just like what you cut out; if it's indented, the extra rows will -be on the left, and you can move them as necessary. - -3. JOT - -And there's a third way to move information between programs. -BGii includes a built-in note-taking command. To use it, type: - - JOT or JOT filename - -If you don't type a filename, BGii adds the notes to a running JOTPAD -file. The JOT function opens a blank screen-pad (with reminders of -commands at the top). Type in your notes, moving around with the cursor -keys and using the insert and delete functions of your terminal. - -You can use a version of the PASTE command to put the previously- cut -region into your jotpad, at any position on the screen. To do so, just -type . You can repeat this for multiple copies. - -When you're finished, type to close the jotpad and -automatically write it to the file. -: - KEYBOARD EXTENSION FUNCTIONS - -BGii has a comprehensive "keyboard macro" capability, a means of -extending regular and numeric-keypad keys to include strings of -characters, text, and commands. The KEYS command will show a menu of -Keys functions. - -In response to the KEYS menu, type "D" to "Define" a key. -BGii will ask which key is to be defined; if it's a numeric keypad -key, just press it. If it's on the main keyboard, press the - key (initially set to "\", the backslash character) and -then the desired key. BGii will show an equals sign ("=") and wait -for your definition. Type in the characters you want to have -this key stand for, and terminate your definition by typing -. - -Now type a "V" to View this new definition, as well as any other -keys already defined. - -You can change a definition by re-defining it; edit any mistakes -using DEL and Control-X while typing it in. - -To exit from the KEYS menu back to a CP/M level, type "X". - -The key you defined is now available for use. Test it out by -pressing the (numeric-keypad) key or followed by the main -keyboard key. - -Information about saving and loading definitions, special characters -for time, date, printer control, etc. is found in the user's manual. -: - PRINT SPOOLING and BACKGROUND PRINTING - -The BGii Print Spooler module takes output that normally goes to the -printer and "spools" (redirects) it into a disk file. The file can be -printed later, or kept for a permanent disk record of a program's -printed output. - -Files can also be "unspooled" and printed automatically from a -queue while other applications programs are running. For -example, in addition to running the spreadsheet and text editor -as alternate tasks, you can be printing selected files. - -The Q program maintains the queue of files to be unspooled. -Use it to add files to the queue, set format options, and -show files yet to be printed. - -: - Figure 1 -- Three BGii Levels and Two Tasks. - - - >>>> ACTIVE TASK <<<< - | - | - V - - LEVEL PROMPT LEVEL PROMPT - -1. Upper A0> Lower a0> - Foreground CP/M Foreground CP/M - -2. Upper user (1st Lower user (2nd - task program) task program) - -3. Upper A0} Lower a0} - Background CP/M Background CP/M - - -NG - -The BGii Print Spooler module takes output that normally goes to the -printer and "spools" (r \ No newline at end of file diff --git a/software/CPM/CPM_MC_C0/EX.COM b/software/CPM/CPM_MC_C0/EX.COM deleted file mode 100644 index 95f9d4d..0000000 Binary files a/software/CPM/CPM_MC_C0/EX.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/FILES.TXT b/software/CPM/CPM_MC_C0/FILES.TXT deleted file mode 100644 index 346e271..0000000 --- a/software/CPM/CPM_MC_C0/FILES.TXT +++ /dev/null @@ -1,11 +0,0 @@ -A: B: C: D: ----------------------------------------------------------------- -0 0_GAMES 0_OLDUTILS 0_NEWUTILS -1_BDS_TINY_C 1_MUMATHSIMP 1_F80M80BASIC 1_ROMS -2_APL 2_CROSSTALK 2_AZTEC_C_106D 2_ZSYSTEM -3_JANUS_ADA15 3_QTERM43 3_TPASCAL3 3_MICROPRO -4_MS_COBOL 4_CLINK 4_DXFORTH401 4_MULTIPLAN -5_PILOT 5_SUPERSFTUTIL 5_PLI14 5_DBASEII -6_SYSLIB 6_RCPM 6_ALGOLM 6_DWG_APPS -7_BBC BASIC 7_DDTZ SOURCES 7_SUPERCALC 8_MICROSHELL ----------------------------------------------------------------- diff --git a/software/CPM/CPM_MC_C0/H19SCRN.DRV b/software/CPM/CPM_MC_C0/H19SCRN.DRV deleted file mode 100644 index 576d844..0000000 Binary files a/software/CPM/CPM_MC_C0/H19SCRN.DRV and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/K8384FNK.FNK b/software/CPM/CPM_MC_C0/K8384FNK.FNK deleted file mode 100644 index c595b6c..0000000 Binary files a/software/CPM/CPM_MC_C0/K8384FNK.FNK and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/K83SCRN.DRV b/software/CPM/CPM_MC_C0/K83SCRN.DRV deleted file mode 100644 index 2381756..0000000 Binary files a/software/CPM/CPM_MC_C0/K83SCRN.DRV and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/K84SCRN.DRV b/software/CPM/CPM_MC_C0/K84SCRN.DRV deleted file mode 100644 index 3544492..0000000 Binary files a/software/CPM/CPM_MC_C0/K84SCRN.DRV and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/KAYPRO.BG b/software/CPM/CPM_MC_C0/KAYPRO.BG deleted file mode 100644 index 6d17b17..0000000 Binary files a/software/CPM/CPM_MC_C0/KAYPRO.BG and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/MAKENDR.COM b/software/CPM/CPM_MC_C0/MAKENDR.COM deleted file mode 100644 index f9b48ec..0000000 Binary files a/software/CPM/CPM_MC_C0/MAKENDR.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/ON!TVI.DRV b/software/CPM/CPM_MC_C0/ON!TVI.DRV deleted file mode 100644 index 32084b1..0000000 Binary files a/software/CPM/CPM_MC_C0/ON!TVI.DRV and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/PUTBG.COM b/software/CPM/CPM_MC_C0/PUTBG.COM deleted file mode 100644 index 970e2d8..0000000 Binary files a/software/CPM/CPM_MC_C0/PUTBG.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/Q.COM b/software/CPM/CPM_MC_C0/Q.COM deleted file mode 100644 index f29ab33..0000000 Binary files a/software/CPM/CPM_MC_C0/Q.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/RELEASE.NOT b/software/CPM/CPM_MC_C0/RELEASE.NOT deleted file mode 100644 index f42ea1a..0000000 --- a/software/CPM/CPM_MC_C0/RELEASE.NOT +++ /dev/null @@ -1,343 +0,0 @@ - RELEASE NOTE - -Release: version 1.33 -From: Plu*Perfect Systems - 410 23rd St. << -- Note new address - Santa Monica CA 90402 - 213-393-6105 (eves.) -Date: September 29, 1989 - -Previous release: version: 1.30 - - - -- READ THIS !! -- - -You MUST replace earlier versions of BG.REL, LOADBG.COM and -SETBG.COM with the new files! The new ones incompatible with -earlier versions. - -Other new or updated files are: - - PUTBG.COM version 1.4 - BGHIST07.OCP Z-System command history shell and error-handler - Also included CP (file copy) command. - BGHIST.HLP help file for BGHIST - K8384FNK.DRV functionkey driver for Kaypros - ON!TVI.DRV screendriver for Oneac ON! - -BackGrounder ii has been significantly enhanced. This file -contains notes on the most important changes. You may wish to -print it out and insert into your user's manual, or otherwise -mark points of change in the manual. - -Plu*Perfect Systems can be contacted via the Ladera Z-Node, -(213)-670-9465 (300,1200,2400 baud). - - - -- Version 1.33 update -- - -1. Fixed access to password-protected named directories. -2. Fixed upper/lower task byte supplied when calling a screendriver. -3. Fixed background access to files not in current directory when - running under ZSDOS/ZDDOS and error reporting has been activated - by the application (e.g. ZDE). - - - -- Capsule Summary, version BGii 1.30 -- - -The BGii command processor is functionally almost identical to -ZCPR version 3.4. Users running a "Z34" system can run commands -under BGii just as they do under their Z System. - -BGii loads (with no patching required) into the following systems: - CP/M 2.2, ZSDOS 1.0, ZDDOS 1.0, ZRDOS 1.7 - -CALC now shows values in both decimal and hex, and a number can -be entered in either radix without changing mode. - -SETBG allows you to rename the BG commands. - -In a Z System, the BG OFF command now restores the RCP and IOP -addresses and sizes in the Z3 environment. - -ECHO allows display of lower-case characters. - -Executable (.COM) files that do not use key definitions can now -be loaded slightly faster, by setting the "noLoad" attribute bit -(f1) of the filename. - -The BGii command processor will only access the specific drives -that are available on your system. On a Z System these drives -are specified in the Z3 environment. On other systems use SETBG -to specify the available drives. - -The command-search hierarchy has been changed so that OCP and RCP -commands can override built-in BGii commands of the same name. - - - - -- More Details on version 1.30 -- - - BG OFF will now restore the RCP and IOP addresses and sizes in -the z3 environment. If the RCP space was used by BGii, the first -byte of the first rcp command (rcp+6) is set to 0. To restore -the CONTENTS of the rcp you should run JetLDR with the RCP's -name, probably as the first command after BG OFF. This can be -handled by an alias, say "BGOFF." - - -For upper and lower foreground tasks, BGii now copies the command -processor's current drive and current user into the message -buffer in a Z-System. These are read-only bytes -- if an -application changes them the actual logged DU: remains the same. -The BACKGROUND current DU: is not recorded in the message buffer; -as the FCP and RCP are disabled in background, this should have -no material effect. A background PEEK at those bytes, after a -background DU: command would show that they are not changed in -background. - - -ECHO supports: - - %> shift to lower case - %< shift to upper case - %% print a '%' - -If the noLoad bit (f1) is set in a COM file, loading is a bit faster -- -the check for an attached ".BG" key definitions file is skipped. If -you set this attribute bit for non-interactive programs and those -for which you don't expect to use a redraw string or key macros you -will get highest performance. - -The "BG" command now reports commands in search-order hierarchy: - OCP, if any - RCP, if any - CPR - -LOADBG now gets BDOS address from the extended environment, if -one. This should enable us to use BGii with non-standard DOS -locations and lengths, with a suitable BDOS id patch and a bdos -that conforms to BGii's patch and re-entry requirements. -Obviously something not yet tested, but a nice hook for an -eventual banked BDOS. - - -The command search hierarchy (p. 123) is: - 1. flow-control package (in a Z-system) - 2. overlay-command processor commands - 3. resident-command-package (in a Z-System) - 4. BGii command processor commands - 5. drive-user (DU:) or named-directory (DIR:) commands - 6. transient commands (COM files) - 7. extended command processor (CMDRUN.COM) - -The extended command processor can be invoked immediately by -preceeding a command with: - a SPACE - a '/' - -A transient command (COM file) can be invoked immediately by -preceeding the command with: - '.', or - ':', for a file in the path - DU: prefix, for a file in the specified DU: directory, then the path - - -Here's an example, assuming command-run is set: - - A0>WS will search the path for WS.COM - A0> WS will load CMDRUN (or other-named external command - processor and pass the command line "WS" to it. - -Another example: - - A0>PEEK peeks at memory with BGii's built-in command - A0> PEEK invokes the external command processor (e.g. to - process the alias "PEEK") - A0>:PEEK searches the path for PEEK.COM; if not found, - invokes the external command processor - A0:.PEEK does the same as ":PEEK" - A0>B12:PEEK searches B12:, then the path, then invokes - the external command processor - - -When run on a Z-System, BGii: - -- Loads both "type-4" and "type-3" environment files that run in high memory. - (p. 121) - -- Reports error codes to the Z-System message buffer for processing by an - external error handler. - -- BGii automatically detects a Z-System tool (one with "Z3ENV" - at offset 3 in the file) and installs the Z-System external - environment address. This is now also done for the GET command. - -- BGii is not identifiable as a ZCPR v 3.3 or v 3.4 command processor, - it does not support their "reparse" and "scan" entry points. - - -Functionkey drivers and screendrivers that depend on addresses in the -host computer's original BIOS (the "CBIOS") will now run under the -NZ-COM system. To do so, they must be modified to reference those -addresses indirectly, through a pointer to the CBIOS warmboot entry. -The following data structure must appear somewhere in the driver: - - db 'CBIOS' ; signature for LOADBG -cbios: dw 0000 ; pointer to cbios warmboot entry - - -DosDisk should normally not be run with BGii. To use DosDisk, -remove BGii with the command "BG OFF", load DosDisk and use the -MS-DOS disk, then remove DosDisk and re-install BGii. - - -The following z3 message buffer variables are not maintained -in the z3 environment area: - - subflag ; submit-running - - -The xsubflag is not supported. XSUB will not run with BGii -anyway; I believe it crashes the system, probably because of -failure to test for the presence of an rsx. - - - -The screen drivers currently available are: - -K83SCRN.DRV - for 1983 Kaypro (one serial port) -K84SCRN.DRV - for 1984 Kaypro (two serial ports) -H19SCRN.DRV - for H/Z-19/89/90, this works with either the - Heath ROM or the Super-19. It does not work with the - Ultra-ROM which has a bug in its transmit screen function. - -TVI.DRV - for Televideo 950, 955 terminals -ON!TVI.DRV - for Oneac ON! computer with Televideo 955 terminal - - -K8384FNK.FNK - function key driver for non U-ROM Kaypros. The - source code (available separately) has stub - drivers for the U-ROM. - -S19FNK.FNK - function key driver for H/Z-19/89/90 with the - Super-19 video ROM which allows the function keys - to be defined. - - - - - - - - - - - - - - - - - - - - - - - -- Notes from version 1.13 -- - - NEW AND CHANGED FEATURES - -1. BGii loads a bit faster than versions 1.0x. - -3. In a ZCPR3 system with a multiple-command line, LOADBG executes any - commands remaining on the command line. For example, if you load BGii - by typing the ZCPR3 command line: - - LOADBG;DIR A0:*.COM - - LOADBG will load BGii, run any pre-configured auto-command line, - and then run the DIR command. - -5. Information messages are now displayed by the "//" parameter - on a command line of most BGii utilities -- PUTBG, SPOOLER, Q - LOADBG, SECURE. - -6. PUTBG and LOADBG -- now support oddball disk drivers that use only 8 - of the 16 single-byte group numbers in each directory entry - (e.g. certain SWP co-power ramdisks and TVI computers). - - - BUGS CORRECTED: - -1. Submit files now execute correctly when using named-directories -or a TIME prompt. - -2. The background drive/user prompt is now correct when first -SUSPENDing from a program. - -3. The REName command now reports an error if the file cannot be found. - -4. The BG command now omits displaying RCP commands in Background -CP/M; (RCP commands can be run only from Foreground CP/M). - - - - ADDITIONS AND CHANGES TO USER'S MANUAL: - -1. p. 5. BackGrounder ii requires that DateStamper, if used, be loaded - "above the bios". See the DateStamper manual for instructions. - -2. p. 124. In the final line in the "State Determination" - section, change "1602h" to "15A8h". - -3. The CUT command, in most screendrivers, has a Cancel command. Type - Control-C to cancel the cutting operation. Some screendrivers allow - the cursor to be moved up and to the left after the first mark is set; - others, for lack of space, do not. - -4. p. 54, p. 118. No patches are required to add a redraw-screen - command to the NewWord editor. Its built-in command is ESC. - -5. pp 105 ff. Additional programmer's notes for coding a screendriver - are found in BGSCREEN.DOC. - -6. DIR Command (p. 67, 89) - - When displaying filesizes, DIR stutters a bit for large files. - This is normal, and unavoidable. The command must calculate the - size of a multi-extent file by reading the directory several - times; there is not enough memory available to store the directory - in memory. - - You can eliminate the jerkiness, and the filesizes, - by making "no filesize" the default configuration with SETBG, or - by using the "/F" flag, e.g. DIR *.DOC /F. - -7. CUT Command (pp. 36,66). When marking a region to be cut, typing - a Control-C will cancel the command. - - -8. Chapter 9: Two options have been added to SETBG. The first - allows the suppression of the "password" from the sign-on - screen. The second allows the "DU:" form of logging in to be - locked out so that access to certain named directories can have - password security. - - - - OTHER NOTES - - -A number of users have requested additional features and also -pointed out a few anomolies. We're grateful for the suggestions, -have given consideration to each, and have been able to make a -number of enhancements. Unfortunately, BGii does have limits, -and several worthwhile ideas simply haven't been possible. - - Internals - -BGii corresponds most closely to these ZCPR34 options: - -fullget NO -duenv YES -aduenv YES -drvprefix YES -scancur NO -accptdu YES controlled by duok -accptdir YES -dufirst YES -pwcheck YES -wpass YES -skippath YES -fastecp YES -altspace YES char = '/' -altcolon YES char = '.' -rootonly controlled by SETBG parameter -badduecp YES -badcmdecp YES - -See the SETBG menus for user-settable variations. - to SETBG. The first - allows the suppression of th \ No newline at end of file diff --git a/software/CPM/CPM_MC_C0/REMOVE.COM b/software/CPM/CPM_MC_C0/REMOVE.COM deleted file mode 100644 index 4f2bc23..0000000 Binary files a/software/CPM/CPM_MC_C0/REMOVE.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/S19FNK.FNK b/software/CPM/CPM_MC_C0/S19FNK.FNK deleted file mode 100644 index 9646989..0000000 Binary files a/software/CPM/CPM_MC_C0/S19FNK.FNK and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/SECURE.COM b/software/CPM/CPM_MC_C0/SECURE.COM deleted file mode 100644 index 612e121..0000000 Binary files a/software/CPM/CPM_MC_C0/SECURE.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/SETBG.COM b/software/CPM/CPM_MC_C0/SETBG.COM deleted file mode 100644 index a342288..0000000 Binary files a/software/CPM/CPM_MC_C0/SETBG.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/SETTERM.COM b/software/CPM/CPM_MC_C0/SETTERM.COM deleted file mode 100644 index aeaabda..0000000 Binary files a/software/CPM/CPM_MC_C0/SETTERM.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/SPOOLER.COM b/software/CPM/CPM_MC_C0/SPOOLER.COM deleted file mode 100644 index b0f5540..0000000 Binary files a/software/CPM/CPM_MC_C0/SPOOLER.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/SYNONYM.COM b/software/CPM/CPM_MC_C0/SYNONYM.COM deleted file mode 100644 index 9033075..0000000 Binary files a/software/CPM/CPM_MC_C0/SYNONYM.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/TERMBASE.DAT b/software/CPM/CPM_MC_C0/TERMBASE.DAT deleted file mode 100644 index 0fee9ba..0000000 Binary files a/software/CPM/CPM_MC_C0/TERMBASE.DAT and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/TVI.DRV b/software/CPM/CPM_MC_C0/TVI.DRV deleted file mode 100644 index 00d63fa..0000000 Binary files a/software/CPM/CPM_MC_C0/TVI.DRV and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/WS30RDRW.HEX b/software/CPM/CPM_MC_C0/WS30RDRW.HEX deleted file mode 100644 index 377e933..0000000 Binary files a/software/CPM/CPM_MC_C0/WS30RDRW.HEX and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/WS33RDRW.HEX b/software/CPM/CPM_MC_C0/WS33RDRW.HEX deleted file mode 100644 index 58db4c7..0000000 Binary files a/software/CPM/CPM_MC_C0/WS33RDRW.HEX and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/WSKAYPRO.BG b/software/CPM/CPM_MC_C0/WSKAYPRO.BG deleted file mode 100644 index ef86425..0000000 Binary files a/software/CPM/CPM_MC_C0/WSKAYPRO.BG and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/WYSE50.DRV b/software/CPM/CPM_MC_C0/WYSE50.DRV deleted file mode 100644 index 7ea48c4..0000000 Binary files a/software/CPM/CPM_MC_C0/WYSE50.DRV and /dev/null differ diff --git a/software/CPM/CPM_MC_C0/ZEX31A.COM b/software/CPM/CPM_MC_C0/ZEX31A.COM deleted file mode 100644 index 8345299..0000000 Binary files a/software/CPM/CPM_MC_C0/ZEX31A.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C1/-TINY#C.254 b/software/CPM/CPM_MC_C1/-TINY#C.254 deleted file mode 100644 index e69de29..0000000 diff --git a/software/CPM/CPM_MC_C1/-TINY#C.265 b/software/CPM/CPM_MC_C1/-TINY#C.265 deleted file mode 100644 index e69de29..0000000 diff --git a/software/CPM/CPM_MC_C1/BDSCIO.H b/software/CPM/CPM_MC_C1/BDSCIO.H deleted file mode 100644 index 1478390..0000000 --- a/software/CPM/CPM_MC_C1/BDSCIO.H +++ /dev/null @@ -1,179 +0,0 @@ -/* - The BDS C Standard I/O header file v1.4 July 18, 1980 - - This file contains global definitions, for use in all C programs - in PLACE of (yechhh) CONSTANTS. Characteristics of your system such - as video screen size, interface port numbers and masks, buffered I/O - allocations, etc., should all be configured just once within this - file. Any program which needs them should contain the preprocessor - directive: - - #include "bdscio.h" - - near the beginning. - Go through and set all this stuff as soon as you get the package, - and most terminal-dependent sample programs should run much better. - Some games (such as STONE.C and RALLY.C), which were contributed and - beyond the scope of my ablity (or patience) to generalize, may not - bother to use the globals from this file, alas. - -*/ - - -/******* Some console (video) terminal characteristics: *******/ - -#define TWIDTH 80 /* # of columns */ - -#define TLENGTH 24 /* # of lines */ - -#define CSTAT 0 /* Console status port */ - -#define CDATA 1 /* Console data port */ - -#define CIMASK 0x40 /* Console input data ready mask */ - -#define COMASK 0x80 /* Console output data ready mask */ - -#define CAHI 1 /* True if console status active high */ - -#define CRESET 0 /* True if status port needs to be reset */ - -#define CRESETVAL 0 /* If CRESET is true, this is the value to send */ - -#define CLEARS "\033E" /* String to clear screen on console */ - -#define INTOREV "\033p" /* String to switch console into reverse video */ - -#define OUTAREV "\033q" /* String to switch console OUT of reverse video */ - -#define CURSOROFF "\033x5" /* String to turn cursor off */ - -#define CURSORON "\033y5" /* String to turn cursor on */ - -#define ESC '\033' /* Standard ASCII 'escape' character */ - - - -/***** Modem characteristics: *****/ - -#define MSTAT 2 /* Modem status port */ - -#define MDATA 3 /* Modem data port */ - -#define MIMASK 0x40 /* Modem input data ready mask */ - -#define MOMASK 0x80 /* Modem ready to send a character mask */ - -#define MAHI 1 /* True if modem status logic active high */ - -#define MRESET 0 /* True if modem status port needs to be reset */ - -#define MRESETVAL 0 /* If MRESET true, this is the byte to send */ - - - -/********************************************************************** - General purpose Symbolic constants: -***********************************************************************/ - -#define BASE 0 /* Base of CP/M system RAM (0 or 0x4200) */ - -#define NULL 0 /* Used by some functions to indicate zilch */ - -#define EOF -1 /* Physical EOF returned by low level I/O functions */ - -#define ERROR -1 /* General "on error" return value */ - -#define OK 0 /* General purpose "no error" return value */ - -#define CPMEOF 0x1a /* CP/M End-of-text-file marker (sometimes!) */ - -#define SECSIZ 128 /* Physical sector size for CP/M r/w calls */ - -#define MAXLINE 132 /* Longest line of input expected from the console */ - -/******* Number of sectors to use for buffered I/O: *********** - * The NSECTS symbol controls the compilation of the buffered * - * I/O routines within STDLIB2.C, allowing each user to set the * - * buffer size most convenient for his system, while keeping * - * the numbers totally invisible to the C source programs using * - * buffered I/O (via the BUFSIZ defined symbol.) For larger * - * NSECTS, the disk I/O is faster...but more ram is taken up. * - * Note that prior (pre 1.4) versions of the library functions * - * were not set up to support this customizable buffer size, * - * and always compiled as if NSECTS was 1 in this version. To * - * change the buffer size allocation, follow these steps: * - * * - * 1) Alter NSECTS to the desired value here in bdscio.h * - * 2) Re-compile STDLIB1.C and STDLIB2.C * - * 3) Use CLIB to combine STDLIB1.CRL and STDLIB2.CRL to make * - * a new DEFF.CRL. * - * * - * Make sure you use declare all your I/O buffers with the a * - * statement such as: * - * char buf_name[BUFSIZ]; * - * instead of the older and now obsolete: * - * char buf_name[134]; * - * (and always #include "bdscio.h" in your programs!) * - ****************************************************************/ - -#define NSECTS 8 /* Number of sectors to buffer up in ram */ - -#define BUFSIZ (NSECTS * SECSIZ + 6 ) /* Don't touch this */ - -struct _buf { /* Or this... */ - int _fd; - int _nleft; - char *_nextp; - char _buff[NSECTS * SECSIZ]; -}; - - - -/**************************************************************************** - If you plan to use the high-level storage allocation functions - from the library ("alloc" and "free") then: - - 1) Uncomment (enable) the "ALLOC_ON" definition, and comment out the - "ALLOC_OFF" definition from this file. - - 2) Re-compile STDLIB1.C, and use CLIB to transfer "alloc" - and "free" into the DEFF.CRL library file. - - 3) THIS IS IMPORTANT!!! Include the statement: - - _allocp = NULL; /* initialize allocation pointer */ - - somewhere in your "main" function PRIOR to the first use - of the "alloc" function. DON'T FORGET THIS INITIALIZATION!! - - Remember to include bdscio.h in ALL files of your C program. - - The lack of static variables is the reason for all this messiness. - ****************************************************************************/ - -#define ALLOC_OFF 1 /* disables storage allocation if uncommented */ - - /* only ONE of these two lines should be uncommented */ -/* -#define ALLOC_ON 1 /* enables storgage allocation if uncommented */ -*/ - - -#ifdef ALLOC_ON /* if storage allocation enabled, */ - -struct _header { - struct _header *_ptr; - unsigned _size; - }; - -struct _header _base; /* declare this external data to */ -struct _header *_allocp; /* be used by alloc() and free() */ - -#endif - -/******************************************************************* - This is the end of the header file. Happy hacking. - *******************************************************************/ - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/BUGS.C b/software/CPM/CPM_MC_C1/BUGS.C deleted file mode 100644 index 29d1707..0000000 --- a/software/CPM/CPM_MC_C1/BUGS.C +++ /dev/null @@ -1,340 +0,0 @@ - -/* - "Bugs" - written by Steve Ward for the H19/H89 display terminal - BD says..."This one is WIERD!!!" -*/ - -#define BUGS 25 -#define BOT 0 -#define LEFT 0 -#define RADIUS2 21 - -int Top, /* Pagesize-1 */ - Right; /* Linelength-2 */ - -struct bug { - int X,Y; - int Dir; /* 0-down, 1-left, 2-up, 3-right. */ - int State; } bugs[BUGS]; -char Wflg, Cflg; -int CurX, CurY; -int Bugs; -int XMotion[20], YMotion[20]; - -rand() -{ - return nrand(2); -} - -step(bb) - struct bug *bb; - { switch ((*bb).State) { - case 0: r(bb,1,0,' '); - r(bb,1,-1,'\\'); (*bb).State++; break; - case 1: r(bb,-1,0,' '); - r(bb,-1,-1,'/'); - (*bb).State++; break; - case 2: r(bb,1,1,' '); - r(bb,1,0,'\\'); - (*bb).State++; break; - case 3: r(bb,-1,1,' '); - r(bb,-1,0,'/'); - (*bb).State++; break; - case 4: r(bb,0,-1,'0'); - r(bb,0,0,'O'); - r(bb,1,-1,'/'); - r(bb,-1,-1,'\\'); - r(bb,1,0,'/'); - r(bb,-1,0,'\\'); - (*bb).State++; break; - case 5: r(bb,1,2,' '); - r(bb,1,1,'\\'); - (*bb).State++; break; - case 6: r(bb,-1,2,' '); - r(bb,-1,1,'/'); - (*bb).State++; break; - case 7: r(bb,1,1,'/'); - r(bb,0,1,' '); - r(bb,-1,1,'\\'); - switch (((*bb).Dir) & 03) { - case 0: (*bb).Y--; break; - case 2: (*bb).Y++; break; - case 1: (*bb).X++; break; - case 3: (*bb).X--; break; } - (*bb).State = 0; break; -/* Diagonal movement: */ - - case 20: r(bb,1,1,' '); - r(bb,1,0,'-'); - (*bb).State++; break; - case 21: r(bb,-1,-1,' '); - r(bb,0,-1,'|'); - (*bb).State++; break; - case 22: r(bb,0,1,' '); - r(bb,1,1,'/'); - (*bb).State++; break; - case 23: r(bb,-1,0,' '); - r(bb,-1,-1,'/'); - (*bb).State++; break; - case 24: r(bb,1,-1,'0'); - r(bb,0,0,'O'); - r(bb,1,1,' '); - r(bb,0,1,'|'); - r(bb,-1,-1,' '); - r(bb,-1,0,'-'); - r(bb,1,0,'|'); - r(bb,0,-1,'-'); - (*bb).State++; break; - case 25: r(bb,-1,2,' '); - r(bb,0,2,'/'); - (*bb).State++; break; - case 26: r(bb,-2,1,' '); - r(bb,-2,0,'/'); - (*bb).State++; break; - case 27: r(bb,-1,1,' '); - r(bb,0,2,' '); - r(bb,-2,0,' '); - r(bb,1,0,'|'); - r(bb,0,-1,'-'); - switch (((*bb).Dir)& 03) { - case 0: (*bb).X++; (*bb).Y--; break; - case 1: (*bb).X++; (*bb).Y++; break; - case 2: (*bb).X--; (*bb).Y++; break; - case 3: (*bb).X--; (*bb).Y--; break; } - (*bb).State = 20; break; - -/* turn from diag to orthogonal (45 deg CCW) */ - - case 40: r(bb,-1,0,' '); - r(bb,-2,0,'/'); - (*bb).State++; break; - case 41: r(bb,-1,0,'O'); - r(bb,-1,2,' '); - r(bb,-1,1,'|'); - r(bb,-2,0,'\\'); - r(bb,-2,1,'\\'); - (*bb).State++; break; - case 42: r(bb,1,1,' '); - r(bb,0,1,'\\'); - r(bb,-1,1,'\\'); - r(bb,-2,0,' '); - r(bb,-2,-1,'/'); - r(bb,0,-1,'/'); - (*bb).Dir = (((*bb).Dir)+1) & 03; - (*bb).State = 0; break; - -/* Turn from ortho to diagonal: */ - - case 50: r(bb,-1,0,' '); - r(bb,-1,-1,'/'); - (*bb).State++; break; - case 51: r(bb,-1,1,' '); - r(bb,-1,0,'/'); - (*bb).State++; break; - case 52: r(bb,1,2,' '); - r(bb,0,1,'|'); - r(bb,-1,1,'O'); - r(bb,1,0,' '); - r(bb,-1,2,' '); - r(bb,0,2,'/'); - r(bb,-1,0,' '); - r(bb,-2,0,'/'); - r(bb,-2,1,'-'); - (*bb).State++; break; - case 53: r(bb,0,2,' '); - r(bb,-1,2,'|'); - r(bb,-2,0,' '); - r(bb,-1,0,'-'); - (*bb).Dir = (((*bb).Dir) | 04); - (*bb).State = 20; break; } - } - - -mkbug(bb,x,y,dir) - struct bug (*bb); - { (*bb).X = x; - (*bb).Y = y; - (*bb).State = 0; - (*bb).Dir = dir; - - if (dir<4) { - r(bb,0,0,'0'); - r(bb,0,1,'O'); - r(bb,1,0,'/'); - r(bb,1,1,'/'); - r(bb,1,2,'/'); - r(bb,-1,2,'\\'); - r(bb,-1,1,'\\'); - r(bb,-1,0,'\\'); } - else { - (*bb).State = 20; - r(bb,0,0,'0'); - r(bb,1,1,'/'); - r(bb,-1,-1,'/'); - r(bb,0,1,'|'); - r(bb,-1,0,'-'); - r(bb,-1,1,'O'); - r(bb,-1,2,'|'); - r(bb,-2,1,'-'); } - } - - -r(bb,dx,dy,ch) - struct bug (*bb); - char ch; - { int tx,ty,dir,xdist,ydist; - char buf[4]; - dir = ((*bb).Dir) & 03; - - if ((dir == 1) || (dir == 3)) - { switch (ch) { - case '/': ch = '\\'; break; - case '\\': ch = '/'; break; - case '|': ch = '-'; break; - case '-': ch = '|'; break; - default: break; }} - - switch (dir) { - case 0: tx = dx+(*bb).X; ty = dy+(*bb).Y; break; - case 2: tx = (*bb).X-dx; ty = (*bb).Y-dy; break; - case 1: tx = (*bb).X-dy; ty = (*bb).Y+dx; break; - case 3: tx = (*bb).X+dy; ty = (*bb).Y-dx; break; } - placech(ch,tx,ty); } - - -placech(ch,tx,ty) - char ch; - { int xdist,ydist; - - if ((txRight) || (tyTop)) return; - - xdist = CurX-tx; ydist = CurY-ty; - if (xdist<0) xdist = -xdist; - if (ydist<0) ydist = -ydist; - if ((ydist+xdist)>2) - { putchar('\033'); - putchar('Y'); - putchar(040 + Top - ty); - putchar(040 + tx); - CurX=tx; CurY=ty; } - - while (CurX=BOT-4); - case 1: return(x<=Right+6); - case 2: return(y<=Top+4); - case 3: return(x>=LEFT-4); }} - -turn(bb) - struct bug *bb; - { switch ((*bb).State) { - case 0: (*bb).State = 50; return; - case 20: (*bb).State = 40; return; - default: return; }} - - -main(argc,argv) - char **argv; - { int i,j,xdist,ydist,xmot,ymot; - char *arg; - - initw(XMotion, "0,1,0,-1,1,1,-1,-1"); - initw(YMotion, "-1,0,1,0,-1,1,1,-1"); - CurX = 1000; CurY = 1000; - Wflg = 0; Cflg = 0; - Bugs = 5; - Top = 23; Right = 78; - - nrand(0,"Are you ready to be driven buggy? "); - getchar(); - - for (i=1; iBUGS) Bugs=BUGS; - - if (Wflg) - { for (i=LEFT; iBOT; i--) placech('|',Right,i); - for (i=LEFT; iBOT; i--) placech('|',LEFT,i); - } - - for (i=0; i0) && (ydist<0) && (ydist*ydist < RADIUS2)) - turn(&bugs[i]); - ydist = xdist-LEFT; - if ((xmot<0)&&(ydist>0) && (ydist*ydist < RADIUS2)) - turn(&bugs[i]); - xdist = (bugs[i]).Y; - ydist = xdist-Top; - if ((ymot>0)&&(ydist<0) && (ydist*ydist < RADIUS2)) - turn(&bugs[i]); - ydist = xdist-BOT; - if ((ymot<0)&&(ydist>0) && (ydist*ydist < RADIUS2)) - turn(&bugs[i]); }} - - if ((j == 0) || (j == 20)) - { for (j=0;jcc1 foobar.c -s6 - supresses errors for undefined variables and sets - symbol table size to 6K bytes; - A>cc1 zot.c -e - sets symbol table size to 14K bytes. - Note that the option list must contain no blanks. - A>cc1 b:td.c - takes the source file from disk B and writes the .CCI - file to disk B (regardless of what the currently logged - disk is.) - - On an 8080, processing time is ~ 12 lines source/sec. - - - -CC2: This is the second half of the compiler. CC2 accepts - a ".CCI" file as input, and writes out a ".CRL" file - if no errors are detected. (CRL is mnemonic for - 'C ReLocatable') - - If all goes well, writing out of the CRL file is - followed by deletion of the "CCI" file, and - compilation is complete. - - As for CC1, if a disk is specified explicitly as in - A>cc2 c:yahoo - then the .CCI file is loaded from the specified disk - and the .CRL file is written to that same disk. - - On an 8080, execution time = ~ 35 lines/sec. - - -CLINK: This program links a "main" function from some - CRL file together with C.CCC (for common system - subroutines) and any subordinate functions which - "main" may require (from perhaps many CRL files). - - A successful linkage causes a ".COM" file to be - generated. At this point, the 8080 absolute - machine code file is ready to be executed (for - better or worse) as a trancient command by CP/M. - - The first argument on the command line must be the - name of a CRL file containing a "main" function. If - the name is specified with an extension, then that - extension is interpreted specially as indicating - which disks are to be involved in the operation (this - is akin to the mechanism ASM uses to determine source - and destination disks.) - For example, if the first argument to CLINK were - given as: - A>clink foo.bc - then CLINK would interpret the "b" in ".bc" as - specifying the disk on which "DEFF.CRL" and "C.CCC" are - to be found, and the "c" in ".bc" as specifying which - disk the .COM file is to be written to. Both of these - values, if omitted, default to the currently logged in - disk. - The first argument may also be preceded by a disk - designation, to specify where all .CRL files are to be - searched for (by default). For example, the command - A>clink b:zot.ac - tells CLINK to get C.CCC and DEFF.CRL from disk A; to - write the ouput file to disk C; and to find ZOT.CRL on - disk B. - - Any other CRL files to search may also be specified - on the command line (WITHOUT their .CRL suffixes), - causing those to be searched in the order specified. - The default disk to search will be the same disk from - which the original CRL file was taken; this default - can be overridden by specifying an explicit disk - designation for any appropriate CRL file name needing - it. For example, - A>clink c:foo.bb bar a:zot fraz - causes disk C to be searched for the files FOO.CRL, - BAR.CRL and FRAZ.CRL, while disk A would be searched - to find ZOT.CRL. Disk B is where CLINK would expect - DEFF.CRL and C.CCC to reside, and the output would go - to disk B also. - - When all given CRL files have been searched, CLINK - will automatically search DEFF.CRL. - - If there are still some unresolved references, then - CLINK will ask for input from the keyboard to try - resolving them. - - There are also several options which may be - specified on the command line. Each option must - be preceded by a dash (-); the space between - options and their argument (if needed) is optional. - The presently supported options are: - - -s Prints out load statistics; - -t nnnn Reserves location nnnn (hex) and - above for user; default is to - reserve no space. What this really - does is to cause the first op in - the object file to be - lxi sp,nnnn - instead of - lxi sp,bdos. - -o name Causes the .COM file generated to - have the given name. Default is - the name of the first .CRL file - given (the one with the "main" - function.) - - - - Examples: - A>clink foo bar - gets "main" from the file FOO.CRL, searches for - needed functions first in FOO.CRL and then, if needed, - in BAR.CRL and DEFF.CRL. All files are assumed to - reside on the currently logged in disk. - - A>clink b:ihtfp belle -s - searches for IHTFP.CRL and BELLE.CRL on disk B; prints - a statistics summary when linkage is complete. The - files DEFF.CRL and C.CCC are assumed to reside on the - currently logged in disk; output also goes to the - currently logged in disk. - - A>clink b:ihtfp.aa -s belle -o zot - is the same as the last example except: the output - file is called ZOT.COM, DEFF.CRL and C.CCC are assumed - to reside on A, and output goes to A. - - A>clink stoned -t7000 -s - sets top of memory to 7000h and prints out load - statistics. Current disk used for everything. - - Note that if the load statistics tell you that - the "LAST ADDRESS" is greater than the "TOP OF - MEMORY", the program hasn't got the chance of a - snowball in hell of running correctly. - -CLIB: This program maintains .CRL files, allows transfer - of functions from one CRL file to another, etc. To - invoke CLIB, just type - A>clib - Clib will print a line such as - FUNCTION BUFFER SIZE = nnnnn - specifying the largest function size that can be - handled. Attempting to "transfer" or "extract" a - function larger than this size could be destructive. - - Next CLIB will prompt with a "*". Typing "h" at - this point will give you a command summary. - - Basically, you work CLIB by opening one to six - CRL files (which then become associated with - "file numbers"), diddling the files to your hearts - content, closing all files which you altered, and - typing control-C. - - The old version of any CRL file you change with CLIB - is renamed to name.BRL (for Backup ReLative). - - A sample session of CLIB to, say, transfer the - functions named "FOO", "BAR", and "ZOT" from - a .CRL file named "DSSR" to one named "RTS" would - go as follows: - - A>clib - - BD SOFTWARE C LIBRARIAN VERSION x.x - FUNCTION BUFFER SIZE = xxxx BYTES - - * open 0 dssr - * open 1 rts - * t 0 1 foo - * t 0 1 bar - * t 0 1 zot - * c 1 - * ^C - - A> ... - - The "open" commands prepare to do work on a .CRL file, - and associate each .CRL file opened with a digit (0-5). - The "transfer" commands tell CLIB to transfer the - named function from the first file (named by file #) - to the second file (also named by number). - The "close" command need only be given for files - which have been altered; since DSSR wasn't written - to in the above example, it didn't need to be closed, - but RTS did need to be closed. - -DEFF.CRL: This file contains the standard function library... - all 58+ functions worth. See the BDS C User's Guide - for documentation on these functions. - - - -C.CCC: The run-time skeleton file, containing code for - processing the command line (generating argc and - argv, for you UNIX lovers), room for file I/O - buffers, some math subroutines, etc. - - - OTHER THINGS YOU GET WITH THE PACKAGE: - - Sample source files: - OTHELLO.C A game playing program - LIST.C A program to list out any ascii file - on the CP/M list device, waiting - between pages and putting in margins. - Not very sophisticated, but shows how - to use simple file I/O. - STDLIB.C Source for all DEFF.CRL functions - which were written in C. - LINES.C A visual freak-out for use with - Processor Tech's VDM-1 board. - (Not included with versions x.xT) - DIVINE.C Simple recursion example. - STONE.C Better recursion example! - PRESSUP.C Best recursion example!!! - TELNET.C Program to let a system be used - as a terminal, optionally routing - stuff from the modem onto disk during - operation as a modem. - LIFE.C Yet another game program. - CONVERT.C Converts unprintable characters (for systems - having upper case only) into special sequences - beginning with the character "#". See also CC0T.C. - CC0T.C Converts C source files containing special sequences - using "#" back into regular form, so that they can - be compiled. - - Other stuff: - C.DOC You seem to have found this one. - - - Note on the BDS C compiler: - - THIS IS NOT AN INTERPRETER. - - Some hacks, such as BASIC-E, are billed as compilers - but actually just do some preprocessing and then - interpret the program. BD C is a true compiler, - generating not-too-optimal but nevertheless quick - 8080 code. - - For the gory details on the BD C implementation, see - my notes to APPENDIX A of the EXCELLANT book - "The C Programming Language." - - Variable types supported: - int char unsigned struct union - arrays (of one or two dimensions) - pointers - simple combinations of the above - - For example, - char *foo[10][15]; - declares foo to be a two dimensional array of - pointers to characters; - - char (*foo)(); - declares foo to be a pointer to a function returning - a character; - - char *foo, bar, zot[10]; - declares foo to be a pointer to characters, bar to - be a single char variable, ant zot to be an array - of 10 characters. - - If your keyboard doesn't support the '{' and '}' - characters (open and close brace, for those of - you whose printer doesn't know about ascii 7B and - 7D), the symbols 'begin' and 'end' may be - substituted. Don't unless you have to; '{' and '}' - take up less memory. - The CONVERT program will perform this conversion, - if necessary. - - Since all functions in C may be used recursively, all - variable accessing is done relative to a base-of- - stack-frame pointer, kept in the BC register pair - during execution. Note that it takes 8 bytes of code - to transfer a simple local variable whose address is - (Base of stack pointer) + foo - to the HL register pair; The code appears as: - - lxi h,foo - dad b - mov a,m - inx h - mov h,m - mov m,a . - To get an array element or structure element is even - more hairy. Facts like this are enough to make me - REALLY wish Intel had bothered to implement a double - byte indirect load instruction. Oh well. - - Test Run - ==== === - - To see if everything is OK, try compiling the - sample program STONE.C. The sequence should look - like this: - - A>cc1 stone.c - BD SOFTWARE C COMPILER V1.0 (PART I) - - A>cc2 stone - BD SOFTWARE C COMPILER V1.0 (PART II) - - A>clink stone - BD SOFTWARE C LINKER V1.0 - - A>stone - Difficulty (1-50): - - - - - - Good luck. You're about to embark on an exciting - voyage into the land of straightforward structured - programming: "C". Enjoy. - - --- - - Now for all you UPPER-CASE-ONLY people: - - The C compiler itself doesn't know the difference between - a printable and a non-printable character (as far as your upper- - case-only terminal is concerned.) In order for a source file to - compile properly, characters such as "left bracket" must appear - as their ASCII value indicates. Since your terminal cannot print - these special characters (there are about 9 of them that C uses), - when you type out a source file (say, LIFE.C), you'll see all kinds of - strange symbols instead of the characters that are really there. - - Thus, the two programs CONVERT.C and CC0T.C have been provided to - translate back and forth between an intermediate form of source code - in which all of these unprintable characters are represented in - terms of printable characters; i.e., the character "#" (which has - no special meaning to the BDS C compiler unless it is part of the - string "#define") followed by one of the special characters - B, L, R, C, V, U, or H. - The meaning of each of these is covered in the comments within the - file CONVERT.C. - - So... the CONVERT program takes source files in the natural form - and converts them to "#" notation (lets call it ".CT" format.) - The form of the CONVERT command is: - A>convert foo.c bar.ct - where foo.c is the existing file, and bar.ct is the new file created. - You may then edit the .ct file, using the "#" convention to represent - all those unprintable characters. - When you're ready to compile the file, the CC0T program must be - run first to convert the .CT format back into the natural format. - To reverse the example above, the command would be: - A>cc0t bar.ct zot.c - leaving zot.c as the file ready for compilation by BDS C. - - If you don't have an upper-case-only terminal, you'll never need - to bother with CONVERT.C or CC0T.C. Otherwise...I suggest you - upgrade as soon as possible to a full ASCII terminal, so you won't - have to bother with CONVERT.C and CC0T.C !!!!!! - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/CC0T.C b/software/CPM/CPM_MC_C1/CC0T.C deleted file mode 100644 index 3aab704..0000000 --- a/software/CPM/CPM_MC_C1/CC0T.C +++ /dev/null @@ -1,94 +0,0 @@ - -/* - CC0T.C -- TRS-80 C PREPROCESSOR - WRITTEN BY LEOR ZOLMAN - - THIS PROGRAM TAKES, AS INPUT, A C SOURCE FILE WRITTEN - USING THE SPECIAL "POUND SIGN" ENCODING FOR CHARACTERS - WHICH ARE UNPRINTABLE (AND UNENTERABLE) ON THE EARLY - MODEL TRS-80 COMPUTERS. WHEREVER CC0T FINDS A SEQUENCE - #X - IN THE INPUT FILE, WHERE "X" IS ONE OF THE SPECIAL - CHARACTERS AS OUTLINED IN THE SOURCE FOR CONVERT.C, - THEN THE TWO-CHARACTER SEQUENCE IS CONVERTED TO A - SINGLE CHARACTER AS REQUIRED BY THE BDS C COMPILER. - THE RESULTANT FILE MAY THEN BE COMPILED WITH CC1, CC2, - ETC. - -*/ - -#INCLUDE "BDSCIO.H" - -#DEFINE POUND 0X23 -#DEFINE LEFTBRACK 0X5B -#DEFINE BACKSLASH 0X5C -#DEFINE RIGHTBRACK 0X5D -#DEFINE CIRCUM 0X7E -#DEFINE VERTIBAR 0X7C -#DEFINE UNDERSCORE 0X5F -#DEFINE UPARROW 0X5E - -CHAR IBUF[BUFSIZ], OBUF[BUFSIZ]; - -MAIN(ARGC,ARGV) -INT ARGC; -CHAR *ARGV[]; -BEGIN - INT FD1, FD2; - CHAR C; - IF (ARGC != 3) BEGIN - PRINTF("USAGE: CC0T OLD NEW \N"); - EXIT(); - END - FD1 = FOPEN(ARGV[1],IBUF); - IF (FD1 == ERROR) BEGIN - PRINTF("CANNOT OPEN INPUT FILE.\N"); - EXIT(); - END - FD2 = FCREAT(ARGV[2],OBUF); - IF (FD2 == ERROR) BEGIN - PRINTF("CANNOT OPEN OUTPUT FILE.\N"); - EXIT(); - END - WHILE ((( C = GETC(IBUF)) != CPMEOF) && C != 255) - BEGIN - IF (C != POUND) PUTC2(C); - ELSE SWITCH(C = GETC(IBUF)) - BEGIN - CASE 'B': PUTC2(BACKSLASH); - BREAK; - CASE 'L': PUTC2(LEFTBRACK); - BREAK; - CASE 'R': PUTC2(RIGHTBRACK); - BREAK; - CASE 'C': PUTC2(CIRCUM); - BREAK; - CASE 'V': PUTC2(VERTIBAR); - BREAK; - CASE 'U': PUTC2(UNDERSCORE); - BREAK; - CASE 'H': PUTC2(UPARROW); - BREAK; - DEFAULT: PUTC2(POUND); - PUTC2(C); - END - END - - IF (C == 255) C = CPMEOF; - PUTC2(C); - FFLUSH(OBUF); - FCLOSE(OBUF); - FCLOSE(IBUF); -END - - -PUTC2(C) -CHAR C; -BEGIN - IF (PUTC(C,OBUF) < 0) BEGIN - PRINTF("OUTPUT WRITE ERROR (DISK FULL?)\N"); - EXIT(); - END -END - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/CC1.COM b/software/CPM/CPM_MC_C1/CC1.COM deleted file mode 100644 index e57700f..0000000 Binary files a/software/CPM/CPM_MC_C1/CC1.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C1/CC2.COM b/software/CPM/CPM_MC_C1/CC2.COM deleted file mode 100644 index 2a2ad01..0000000 Binary files a/software/CPM/CPM_MC_C1/CC2.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C1/CHARLIST.C b/software/CPM/CPM_MC_C1/CHARLIST.C deleted file mode 100644 index 71674b3..0000000 --- a/software/CPM/CPM_MC_C1/CHARLIST.C +++ /dev/null @@ -1,177 +0,0 @@ -#include "bdscio.h" - -#define BELL "\007" -#define EOL "\033K" -#define FF '\014' - -struct character { - char cname[30]; - char str[10]; - char intel[10]; - char wis[10]; - char con[10]; - char dex[10]; - char chr[10]; - char hpoints[10]; - char level[7]; - char class[15]; - char aclass[7]; - char align[15]; - char specials[50]; - }; - -struct player { - char name[15]; - int nchars; - struct character owned[5]; - }gamers[10]; - -main() -{ - char inp[5]; - int players,i,j; - - puts(CLEARS); - gotoxy(7,4);puts("\007Enter number of players: "); - players = atoi(gets(inp)); - if((players<=0)||(players>=11)){ - gotoxy(7,4);puts("\033\007KUnable to handle that number"); - gotoxy(8,4);puts("of players. Current limit is 10 people."); - gotoxy(9,4);puts("Talk to Dann about changing me!!!!"); - exit(); - } - for(i=0;i=6)){ - gotoxy(3,4);puts("\033K\007Illegal value; please re-enter."); - gotoxy(4,34);puts(EOL); - goto l1; - } - gamers[num].nchars = limit; - puts(CLEARS); - gotoxy(3,5);puts("Player's name: "); puts(gamers[num].name); - gotoxy(5,5);puts("Character #"); - gotoxy(7,9);puts("Character name: "); - gotoxy(8,9);puts("Strength: "); - gotoxy(9,9);puts("Intelligence: "); - gotoxy(10,9);puts("Wisdom: "); - gotoxy(11,9);puts("Constitution: "); - gotoxy(12,9);puts("Dexterity: "); - gotoxy(13,9);puts("Charisma: "); - gotoxy(15,9);puts("Level: "); - gotoxy(16,9);puts("Hit points: "); - gotoxy(17,9);puts("Class: "); - gotoxy(18,9);puts("Armor class: "); - gotoxy(19,9);puts("Alignment: "); - gotoxy(21,9);puts("Specials: "); - - - for(i=0;icname); - lputs(linebuf); - setmem(linebuf,80,' '); linebuf[80] = '\0'; - lputs(" STR INT WIS CON"); - lputs(" DEX CHR HIT POINTS\n"); - sprintf(linebuf+9,"%6s %6s",a->str,a->intel); - sprintf(linebuf+24," %6s %6s",a->wis,a->con); - sprintf(linebuf+42," %6s %6s",a->dex,a->chr); - sprintf(linebuf+60," %-6s\n",a->hpoints); - lputs(linebuf); - setmem(linebuf,80,' '); linebuf[80] = '\0'; - lputs(" LEVEL CLASS ARMOR CLASS ALIGNMENT\n"); - sprintf(linebuf+10,"%3s %10s %3s %3s\n",a->level,a->class,a->aclass,a->align); - lputs(linebuf); - setmem(linebuf,80,' '); linebuf[80] = '\0'; - sprintf(linebuf+6,"SPECIALS: %-50s\n\n",a->specials); - lputs(linebuf); - } - } -} - -putlpr(c) - char c; -{ - if(c=='\n')bios(LIST,'\r'); - bios(LIST,c); -} - -lputs(s) - char *s; -{ - while(*s)putlpr(*s++); -} - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/CLIB.COM b/software/CPM/CPM_MC_C1/CLIB.COM deleted file mode 100644 index 5c93fa9..0000000 Binary files a/software/CPM/CPM_MC_C1/CLIB.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C1/CLINKC.COM b/software/CPM/CPM_MC_C1/CLINKC.COM deleted file mode 100644 index 8e8f874..0000000 Binary files a/software/CPM/CPM_MC_C1/CLINKC.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C1/CONVERT.C b/software/CPM/CPM_MC_C1/CONVERT.C deleted file mode 100644 index 09317b9..0000000 --- a/software/CPM/CPM_MC_C1/CONVERT.C +++ /dev/null @@ -1,138 +0,0 @@ - -/* - "CONVERT" - WRITTEN BY LEOR ZOLMAN - - THIS PROGRAM CONVERTS REGULAR C SOURCE FILES INTO A - FORMAT SUITABLE FOR EDITING ON THE TRS-80 (OR ANY - UPPER-CASE-ONLY SYSTEM.) SINCE THERE ARE QUITE A FEW - ASCII CHARACTERS THAT NEED TO BE REPRESENTED EVEN - THOUGH THEY DON'T SHOW UP ON UPPER-CASE-ONLY SYSTEMS, - A SPECIAL NOTATION HAS BEEN CREATED FOR REPRESENTING - THESE CHARACTERS. THE POUND SIGN IS USED AS A - SORT OF 'SHIFT' KEY, WITH THE LETTER FOLLOWING THE - POUND SIGN DENOTING THE SPECIAL CHARACTER NEEDED. - NOTE THAT THE C COMPILER DOES NOT RECOGNIZE THIS - SPECIAL SCHEME, AND BEFORE YOU CAN COMPILE A SOURCE - FILE CONTAINING THE SPECIAL CODES YOU MUST PREPROCESS - THE FILE USING THE "CC0T" COMMAND. - - THE SPECIAL CODES AND THE CHARACTERS THEY REPRESENT ARE: - #L LEFT BRACKET (FOR SUBSCRIPTING) (5B HEX) - #R RIGHT BRACKET (5D HEX) - #C CIRCUMFLEX (BITWISE "NOT") (7E HEX) - #H UP-ARROW (EXCLUSIVE "OR" OPERATOR) - (5E HEX) - #V VERTICAL VAR (LOGICAL AND BITWISE "OR") - (7C HEX) - #B BACKSLASH (FOR ESCAPE SEQUENCES)(5C HEX) - #U UNDERSCORE (5F HEX) - - FOR EXAMPLE, THE COMMAND - A>CONVERT FOO.C BAR.CT - - WILL EXPECT FOO.C TO BE A NORMAL C SOURCE FILE ON - DISK, AND WILL CONVERT IT INTO A FILE NAMED BAR.CT. - THE FILE BAR.CT MAY THEN BE EDITED TO YOUR TASTE, - BUT REMEMBER TO PREPROCESS IT WITH "CC0T" BEFORE - APPLYING THE C COMPILER. - - AS YOU MAY HAVE GATHERED FROM ALL THIS, THE LANGUAGE - "C" WAS NEVER INTENDED TO BE IMPLEMENTED ON A SYSTEM - HAVING UPPER-CASE ONLY; NEVERTHELESS, HERE IS A WAY - FOR IT TO BE DONE. - - THIS PROGRAM IS RATHER SIMPLE, AND THUS IT WILL NOT - RECOGNIZE THAT SPECIAL CHARACTERS IN QUOTES ARE NOT - SUPPOSED TO BE CONVERTED. -*/ - -#INCLUDE "BDSCIO.H" - -#DEFINE LEFTCURLY 0X7B -#DEFINE RIGHTCURLY 0X7D -#DEFINE LEFTBRACK 0X5B -#DEFINE RIGHTBRACK 0X5D -#DEFINE CIRCUM 0X7E -#DEFINE UPARROW 0X5E -#DEFINE VERTIBAR 0X7C -#DEFINE BACKSLASH 0X5C -#DEFINE UNDERSCORE 0X5F - -CHAR IBUF[BUFSIZ], OBUF[BUFSIZ]; - -MAIN(ARGC,ARGV) -INT ARGC; -CHAR *ARGV[]; -BEGIN - INT FD1, FD2; - CHAR C; - IF (ARGC != 3) BEGIN - PRINTF("USAGE: CONVERT OLD NEW \N"); - EXIT(); - END - - FD1 = FOPEN(ARGV[1],IBUF); - IF (FD1 == ERROR) BEGIN - PRINTF("NO SOURCE FILE.\N"); - EXIT(); - END - FD2 = FCREAT(ARGV[2],OBUF); - IF (FD2 == ERROR) BEGIN - PRINTF("CAN'T OPEN OUTPUT FILE.\N"); - EXIT(); - END - - WHILE ((( C = GETC(IBUF)) != CPMEOF) && C != 255) BEGIN - SWITCH (C) BEGIN - CASE LEFTCURLY: PUTST(" BEGIN "); - BREAK; - CASE RIGHTCURLY: PUTST(" END "); - BREAK; - CASE LEFTBRACK: PUTSPEC('L'); - BREAK; - CASE RIGHTBRACK: PUTSPEC('R'); - BREAK; - CASE CIRCUM: PUTSPEC('C'); - BREAK; - CASE UPARROW: PUTSPEC('U'); - BREAK; - CASE VERTIBAR: PUTSPEC('V'); - BREAK; - CASE BACKSLASH: PUTSPEC('B'); - BREAK; - CASE UNDERSCORE: PUTSPEC('U'); - BREAK; - DEFAULT: PUTC2(TOUPPER(C)); - END - END - - IF (C==255) C = CPMEOF; /* DIGITAL RESEARCH....WOW. */ - PUTC2(C); - FFLUSH(OBUF); - FCLOSE(OBUF); - FCLOSE(IBUF); -END - -PUTST(STRING) -CHAR *STRING; -BEGIN - WHILE (*STRING) PUTC2(*STRING++); -END - -PUTSPEC(C) -CHAR C; -BEGIN - PUTC2('#'); - PUTC2(C); -END - -PUTC2(C) -CHAR C; -BEGIN - IF (PUTC(C,OBUF) < 0) BEGIN - PRINTF("OUTPUT WRITE ERROR (DISK FULL?)\N"); - EXIT(); - END -END - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/CTC.ASM b/software/CPM/CPM_MC_C1/CTC.ASM deleted file mode 100644 index d9b517f..0000000 --- a/software/CPM/CPM_MC_C1/CTC.ASM +++ /dev/null @@ -1,634 +0,0 @@ -p equ psw -entry equ 05h -rdcon equ 1 -wrcon equ 2 -prbuff equ 9 -chcon equ 11 -seldsk equ 14 -openf equ 15 -closef equ 16 -deletf equ 19 -rdrec equ 20 -wrrec equ 21 -creatf equ 22 -inqdsk equ 25 -setdma equ 26 -; -reof equ 1 ;read end-of-file signal -; -fn equ 1 ;EFCB layout -ft equ 9 -ex equ 12 -rct equ 15 -nr equ 32 -status equ 33 -driveno equ 34 -nxbyte equ 35 -buffer equ 36 -; -;used by start: -tcorg equ 600h -mstack equ tcorg+46h -bpr equ tcorg+42h -inst equ tcorg+0d08h -move equ tcorg+0c4bh -hlneg equ tcorg+0dc0h -progend equ tcorg+060h -tfcb equ 05ch -tbuff equ 080h -; -;used by USERMC -mceset equ tcorg+2bh -toptoi equ tcorg+2eh -pushk equ tcorg+31h -pzero equ tcorg+1c5h -; -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -;::::::::::: tiny - c ::::::::::::::::::::::::::::::::::: -;::::::::::: cp/m installation :::::::::::::::::::::::: -;::::::::::: by t. a. gibson, 1978 :::::::::::::::::: -;::::::::::: copyright, 1978, tiny-c associates ::: -;::::::::::: all rights reserved :::::::::::::::: -;:::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -; - org 100h - jmp start - jmp inch - jmp aout - jmp chrdy - jmp fopen - jmp rdblok - jmp wrblok - jmp fclose - jmp usermc -; -; -;transforms unit in BC to efcb in DE -unit mov d,b ;DE <- BC - mov e,c - mov a,e ;test for unit 1 - dcr a - ora d - rnz - lxi d,efcb ;use built in efcb - ret -; -;restores BC, DE, HL and returns -bdhret pop b -dhret pop d - pop h - ret -; -;assures proper disk is logged on. (DE) is efcb. -asudsk push h!push d!push b - lxi h,driveno ;retrieve needed drive - dad d - mov a,m - push p - mvi c,inqdsk - call fdos - mov b,a ;current drive -> B - - pop p ;needed drive -> A - cmp b ;if same do nothing - jz bdhret - mov e,a ;logon device (A) - mvi d,0 - mvi c,seldsk - call fdos - jmp bdhret -; -;assure correct DMA for buffer at (DE)+buffer. -asudma push h!push d!push b - xchg - mvi c,setdma - call fdos - jmp bdhret -; -;restore default DMA buffer -cpmbuff push h! push d! push b - lxi d,80h - mvi c,setdma - call fdos - jmp bdhret -; -;load buffer, (DE) is EFCB -ldbuff push h! push d ! push b - call asudsk - call asudma - mvi c,rdrec - call fdos - jmp bdhret -; -;write the buffer. (DE) is EFCB -wrbuff push h! push d! push b - call asudma ;must send it out - call asudsk - mvi c,wrrec - call fdos - jmp bdhret -; -;examines 1st 2 bytes of a drive:fn.ft string. -;(HL) points to the string. If a drive is specified, the -;drive is set up in the EFCB pointed to by (DE). -;Otherwise drive a is set up. -drive push h! push d! push b - inx h ;is there a colon in 2nd byte. - mov a,m - cpi ':' - jnz dr2 - dcx h ;get drive byte. Must be A,B,C or D, - mov a,m - sui 'A' - jm dr99 - cpi 4 - jm dr3 - sui 20h ; or a,b,c or d. - jm dr3 - cpi 4 - jm dr3 -dr99 mvi a,254 ;illegal drive signal - ora a - jmp bdhret -dr2 mvi c,inqdsk ;default is current drive - call fdos - lxi h,driveno - dad d - mov m,a - jmp bdhret -dr3 lxi h,driveno ;driveno in A into EFCB. - dad d - mov m,a - xra a ;success signal - pop b! pop d! pop h ;restore environment. - inx h! inx h ;bump string pointer past colon. - ret -; -;safe entry into CP/M. -fdos push h! push d! push b - call entry - jmp bdhret -; -;puts fn.ft into EFCB. (HL) points to string ended with -;null byte. (DE) points to EFCB. -fnft push h! push d! push b - xra a ;0 into ET field - stax d - inx d - mvi b,8 ;length of FN field - call fomov ;fn into FN - jz ftdflt ;if 0 then end of string was reached. -fdot mov a,m ;scan for . or null - inx h - cpi '.' - jz ftype - ora a - jnz fdot -ftdflt lxi h,dft -ftype mvi b,3 ;mov ft into FT - call fomov -fex xra a ;0 EX thru RC - stax d! inx d - stax d! inx d - stax d! inx d - stax d! inx d - jmp bdhret -dft db 'TC ' -; -;moves a string to a field. (HL) points to string. (DE) -;points to field of length (B). Stops on . or null or -;field full. Pads field with blanks if needed. Returns -;last byte examined in A and Z set iff its null. -fomov mov a,m - ora a - jz fpad - cpi '.' - jz fpad - cpi '*' ;* => pad with ?'s - jz qpad - cpi 61h ;test for lower case alpha - jc fm2 - cpi 7bh ; 'z'+1 - jnc fm2 - ani 0dfh ;force upper case -fm2 stax d - inx d - inx h - dcr b - jnz fomov - ora a ;set or reset Z - ret ;DE points past moved field - ;HL points to next byte to examine. -fpad push p ;save char that caused stop - mvi a,' ' ;blanks into remainder of field -fp2 stax d - inx d - dcr b - jnz fp2 - pop p ;restore character that caused stop - ora a - ret -qpad push p - mvi a,'?' - jmp fp2 -; -;prints (A) in hex, and EFCB -prefcb push psw - push h! push d! push b - call ahexout - mvi a,' ' - call aout - lxi h,driveno ;drive letter into A - dad d - mov a,m - adi 'A' - call aout ;send drive letter - mvi a,':' - call aout ;send colon - mvi c,8 ;length of filename - lxi h,fn ;send filename - dad d - call prntnch - mvi a,'.' ;send period - call aout - mvi c,3 ;send filetype - lxi h,ft - dad d - call prntnch - mvi a,' ' ;send blank - call aout - lxi h,ex ;send extent number - dad d - mov a,m - call ahexout - mvi a,' ' ;send blank - call aout - lxi h,rc ;send record count - dad d - mov a,m - call ahexout - mvi a,' ' - call aout - lxi h,nr ;send next record number - dad d - mov a,m - call ahexout - mvi a,' ' - call aout - lxi h,status ;send status - dad d - mov a,m - call ahexout - mvi a,' ' - call aout - lxi h,nxbyte ;send next byte of buffer - dad d - mov a,m - call ahexout - mvi a,' ' - call aout ;send blank at end - pop psw - jmp bdhret -; -;opens a file for tiny-c, as specified in the -;Owner's Manual 6.1.2. DE (filesize) is ignored. -;All other parameters are used. -fopen push p ;r/w flag - call cpmbuff ;assure default buffer - call unit ;set up pointer to EFCB in DE. - call drive ;drive into EFCB - jz f2 - pop p ;improper drive. Clear stack. - call ps ;print filename and bad drive message. - lxi d,baddr -ferr call pcs ;bad drive message - xra a ;signal an error - inr a - ret -baddr db 'improper drive$' -f2 call fnft ;fn.ft into EFCB - jz f3 - pop p ;bad filename - call ps ;clear stack, print filename and bad - lxi d,badname ; filename message. - jmp ferr -badname db 'bad filename$' -f3 lxi h,nr ;0 into NR and NXBYTE - dad d - xra a - mov m,a - lxi h,nxbyte - dad d - mov m,a - pop p ;restore r/w flag, and put - lxi h,status ; into status - dad d - mov m,a - cpi 1 ;what kind of open - jz ropen - cpi 2 - jz wopen - call prefcb ;bad r/w flag, print EFCB and message - lxi d,badrw - jmp ferr -badrw db 'rw must be 1 or 2$' -ropen call asudsk ;assure correct disk - mvi c,openf ;do a cpm open - call fdos - cpi 255 ;test for no file - jnz openok - call prefcb ;print EFCB and no-file message - lxi d,nofile - jmp ferr -nofile db 'cant find file$' -openok xra a ;signal open ok - ret -wopen call asudsk ;assure correct disk - mvi c,deletf ;delete old file, if any - call fdos - mvi c,creatf - call fdos - cpi 255 ;test if disk is full - jnz openok - call prefcb ;print EFCB and full message - lxi d,dirful - jmp ferr -dirful db 'directory full$' -; -;reads a block. HL points to memory area to read into. -; BC is a unit. If status of EFCB is not 1, returns an -; eof signal, and does not read. Otherwise reads one block -; into memory. If physical eof was reached, an eof signal is -; returned. Otherwise scans the read block for ^Z, and -; returns length of block in DE. Returns 0 in A for ok, -; -1 for eof, 1 for error. Leaves BC, HL unchanged. -rdblok push b - push h - call unit ;efcb into DE - lxi h,status ;test status - dad d - mov a,m - cpi 1 - jnz rdeof - pop h - push h - call ldbuff ;read the record - ora a - jnz rdpeof ;possible eof - lxi d,0 ;scan for ^Z - mvi b,1ah ;^Z into A - mvi c,128 ;scan limit -rdscan mov a,m ;get byte - cmp b ;is it ^Z - jz rdout - inr e ;add to length - inx h ;to get next byte - dcr c - jnz rdscan -rdout pop h ;restore B and H - pop b - xra a ;signal ok - ret -rdpeof cpi reof ;didn't read, see why. - jnz rderr -rdeof pop h ;eof exit, restore B and H - pop b - xra a ;signal eof - dcr a - ret -rderr call prefcb ;print error code and efcb - lxi d,rermsg - jmp ferr -rermsg db 'read error$' -; -;write a block. Unit in BC. HL..DE bracket a block of -; memory <= 128 bytes. If status in EFCB is not 2, signal -; an error. If block < 128 put an ^Z at (DE)+1. Then -; write the block. Return 0 in A for ok, 1 otherwise. -wrblok mov a,e ;check length - sub l - cpi 127 ;E-L==127 implies 128 bytes in block - jz wr2 - xchg ;short block, put ^Z at (DE)+1 - inx h - mvi m,1ah - xchg -wr2 call unit ;efcb into DE - push h ;save write address - lxi h,status - dad d ;test status - mov a,m - cpi 2 - pop h ;restore write address - jnz wrerr ;error if status not 2 - call wrbuff ;write the block - ora a ;zero signals no problem - rz -wrerr call prefcb ;print error code and efcb - lxi d,wermsg - jmp ferr -wermsg db 'write error$' -;close a file, BC is the unit. -fclose call unit ;EFCB into DE - call cpmbuff ;assure default buffer - lxi h,status ;status into A - dad d - mov a,m ;test status - cpi 2 - jnz zstat - mvi c,closef ;writing, must close the file - call fdos - cpi 255 - jz fcerr -zstat xra a ;0 into status - mov m,a - ret -fcerr call prefcb - lxi d,fermsg - jmp ferr -fermsg db 'close error$' -; -;prints (A) restoring all registers -aout push h! push d! push b! push p - mvi c,wrcon - mov e,a - cpi 0DH - jnz aout2 - call fdos ;after also send - mvi e,0AH - mvi c,wrcon -aout2 call fdos - pop p - jmp bdhret -; -;prints (A) in hex -ahexout push p - rrc! rrc! rrc! rrc - call hexout - pop p ;and fall into hexout -;prints one hex digit from (A) -hexout push p - ani 15 - adi 90h - daa - aci 40h - daa - call aout - pop p - ret -; -;prints tiny-c string (null terminated) -ps mov a,m - ora a - rz - call aout - inx h - jmp ps -; -;prints (C) chars starting at (HL) -prntnch mov a,m - call aout - dcr c - inx h - jnz prntnch - ret -; -;prints cp/m style string, ($ terminated) -pcs mvi c,prbuff - jmp fdos -; -;Tests for char ready from the terminal, as specified -;in the Owner's Manual, Sec. 6.1.1. HOLD is a software -;buffer shared by chardy and inch, and HOLDF is a flag -;indicating whether or not a char is in HOLD. -chrdy mvi c,chcon ;check the console status - call fdos - ani 1 ;mask of least signif bit - jz tryhold - mvi c,rdcon ;read from the console - call fdos - ani 07fh ;mask out hi bit - sta hold - xra a ;set holdf to -1 - dcr a - sta holdf -tryhold lda holdf ;test hold flag - ora a - rz ;no char ready - lda hold ;got one in hold - ora a - rnz - mvi a,1 ;null byte, return a 1 - ora a - ret -; -inch lda holdf ;try hold first - ora a - jz tryport - xra a ;have one in hold - sta holdf ;zero the flag - lda hold ;return the held char - cpi 0DH - rnz - mvi a,0AH ;echo a line feed when read - call aout - mvi a,0DH - ret -tryport call chrdy ;hold is empty, so wait for human - jz tryport ; to type something. - jmp inch ;He did it, so use inch to read the character. -holdf db 0 -hold db 0 -; -;It all starts here. Cold start if no filename given. -; Otherwise load the named file, and hot start it. A -; default filetype TC is provided. -start lda tfcb+1 - cpi ' ' - jz tcorg ;cold start - lhld mstack ;set SP - sphl - lxi b,-10 ;initialize tiny-c - lhld bpr - xchg - lxi h,inst - call move - lhld bpr - lxi d,9 - dad d - call hlneg - shld progend - lxi h,tbuff ;put null at end of string. - mov a,m ;get length - inx h ;beginning of string - push h - add l - mov l,a ;hl -> end of string - mvi m,0 - pop h ;begin of string - inx h ;skip over single blank - lxi b,1 ;unit 1 - mvi a,1 ;rw set to read - call fopen - jnz tcorg ;cold start on error - lhld progend ;where to read -st2 call hlneg - lxi b,1 - call rdblok - jnz stout - dad d - mvi m,0 - call hlneg - shld progend - jmp st2 -stout push p ;save last read result - lxi b,1 - call fclose - pop p - cpi 0ffh ;test for end of file - jnz tcorg ;if not end of file, then error, hence cold start - jmp tcorg+6 ;hot start -; -efcb ds 36 ;for unit 1 -; -;User Machine Calls -- defined in CP/M supplement. -usermc mov a,l - cpi 1 - jz mc1001 - cpi 2 - jz mc1002 - cpi 3 - jz mc1003 - jmp mceset -; -mc1001 call toptoi ; FDOS ( fnum, arg ) - push d ;arg -> stack - call toptoi ;fnum -> C - mov c,e - pop d ;arg -> DE - push b ;save fnum for later - call entry - mov e,a ;result -> DE - mvi d,0 - pop h ;fnum -> L - mov a,l - cpi 27 ;only function 27 returns 2 bytes - jnz pushk - mov d,b ;hi byte for 27 - jmp pushk -; -mc1002 call toptoi ;sefcb(string,efcb) - push d - call toptoi - xchg ;string -> HL - pop d ;efcb -> DE - call drive - jnz pushk ;illegal drive pushed addr of efcb - call fnft - jmp pzero -; -mc1003 call toptoi ;efcb -> DE - xra a - call prefcb - jmp pzero - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/DISK.C b/software/CPM/CPM_MC_C1/DISK.C deleted file mode 100644 index fe48da8..0000000 --- a/software/CPM/CPM_MC_C1/DISK.C +++ /dev/null @@ -1,286 +0,0 @@ -/* - DISK UTILITY PROGRAM - - Written by Richard Damon - Version 1.0 May 1980 - - This program allows the operator to examine and modify -a CPM diskette. - - The commands available in this package are : - -Tn set current track to n (0-76) -Sn set current sector to n (1-26) -Dn set current disk number to n (0-3) -Bn set current track and sector to point to block n (0-F2) -N set current track and sector to next sector/block - next sector if last set command was for track or sector - next block if last set command was for block -I increment sector, if sector>26 set to 1 and increment track -R read sector/block into buffer -W write sector/block from buffer -P print out contents of buffer, allong with track/sector/block information -Ea n n n n - edit buffer starting from location a filling with values n n n. -Fn Fill buffer with value n -X exit program -M print disk allocation map - -Notes: - 1) Multiple commands may be specified on a line except for X -which must be the only command on the line followed by return. - 2) Commands may be in upper or lower case letters - 3) Spaces are ignored except in the E command where they are used - as separaters for the numbers - -Typical commands: -d0t0s1rp read in the track 0 sector 1 of disk 0 (Drive A) and print it -e1A 4F 20 11 set buffer location 1A to 4F, 1B to 20, and 1C to 11. -e0a 00w set buffer location 0a to 0 and write buffer - Note no space after last data byte -nrp get next buffer and print it - -Disk Allocation Map - The M command is designed to allow the directory blocks (blocks 0 and 1) -to be printed out in a convient format. The directory is print out in the -following format: - - Section 1: - The top half of the directory listing is a listing of the name - inforamtion of the directory entries. Each line corresponds to 1 sector - of the directory. A typical entry would be f=DISKTESTCOM/1 4c - The first letter is a code letter used to referance into section 2. - The equal sign indicats that the file exists, a star here indicates - that this entry is a deleted file. - Next comes the filename and extension. - The following /n is printed if this is other then the first extent - (extent 0) of a file where n is the extent number of this entry. - The following number is the hex record count for this extent. - - Section 2: - The bottom half of the directory listing is a disk allocation map - showing which blocks are in use and by which file. Free blocks are - indicated by a dot while used blocks are marked by the file control - letter asigned to a file in section 1. This listing has been blocked off - in groups of 8 and 16 to ease reading. - -CPM FILE STRUCTURE - - To help the user of this program the following is a brief description -of the format used in CPM. The first 2 tracks of a disk are reserved -for the bootstrap and the copy of the CPM operating system. Tracks 2 -through 76 store the data. To speed up disk access CPM does not store -consecutive data in consecutive sectors. Insteed it uses every 6th sector -for data. Thus to read logical consecutive sectors you must read the -sectors in the following order: - 1 7 13 19 25 5 11 17 23 3 9 15 21 2 8 14 20 26 6 12 18 24 4 10 16 22 -This interleaving is taken care of when reading in multiple sectors -or when incrementing the disk address with the N command. To simplify -the disk allocation scheme the sectors are the collected into groups of -8 sectors forming a 1k block. These blocks are numbered from 0 starting -at the begining of the dirctory. (track 2 sector 1). Block numbers range -from 0 to F2. - The directory is organized to use 2 block of storage (16 sectors) to -store information on 64 file extensions. A file extension is a part of a -file up to 16k bytes long. The directory entry for a file extension is -as follows: - -byte 0 : file code : 0 if file exists, E5 if file is deleted -byte 1- 8: file name : ascii representation of file name -byte 9-11: file type : ascii representation of file type -byte 12 : file ext : binary number for extent number -byte 13,14: unused -byte 15 : rec count : count of number of sectors in extent -byte 16-31: map : list of block numbers used by this extent -*/ - -#include "bdscio.h" - -main(){ - int track,sector,disk,nsect,t,s,i,j,k,block; - char buffer[1024],buff[80],*bufp,c,d,mc,dir[2048],map[256]; - disk=0; - track=0; - sector=1; - nsect=1; - while(tolower(*(bufp=gets(buff))) != 'x' || *(bufp+1) != '\0'){ - while((c=*bufp++) != '\0') - switch(toupper(c)){ - case 'T' : track=getnum(&bufp,0,76,10); - nsect=1; - break; - case 'S' : sector=getnum(&bufp,1,26,10); - nsect=1; - break; - case 'D' : disk=getnum(&bufp,0,1,10); - break; - case 'B' : block=getnum(&bufp,0,0xf2,16); - nsect=8; - track=2+block*8/26; - s=block*8%26; - sector=s*6%26+1; - if(s>12)sector++; - break; - case 'N' : for(i=0;i26)sector-=26; - if(sector==2){ - sector=1; - track++; - } - else if(sector==1) sector=2; - } - break; - case 'I' : sector+=nsect; - if(sector>26){ - sector-=26; - track++; - } - break; - case 'R' : bios(SELECT_DISK,disk); - t=track; - s=sector; - for(i=0;i26) s-=26; - if(s==2){ - s=1; - t++; - } - else if(s==1) s=2; - } - break; - case 'W' : bios(SELECT_DISK,disk); - t=track; - s=sector; - for(i=0;i26) s-=26; - if(s==2){ - s=1; - t++; - } - else if(s==1) s=2; - } - break; - case 'P' : switch (sector%6){ - case 0: block=17+sector/6; break; - case 1: block= 0+sector/6; break; - case 2: block=13+sector/6; break; - case 3: block= 9+sector/6; break; - case 4: block=22+sector/6; break; - case 5: block= 5+sector/6; break; - } - block=block+26*(track-2); - printf("track %d sector %d ",track,sector); - printf(" block %x.%d ",block/8,block%8); - for(i=0;i<128*nsect;i+=16){ - printf("\n %4x ",i); - for(j=0;j<16;j++){ - printf("%2x ",buffer[i+j]); - if(j%4 == 3) printf(" "); - } - for(j=0;j<16;j++){ - c=buffer[i+j]&0x7f; - if(c<' '||c==0x7f)c='.'; - /* BUG in compiler!!!! - c=c<' '||c==0x7f ? '.' : c; - */ - putch(c); - } - if(kbhit()) break; - } - putch('\n'); - break; - case 'E' : i=getnum(&bufp,0,nsect*128-1,16); - while(*bufp==' '){ - buffer[i++]=getnum(&bufp,0,255,16); - if(i>=nsect*128) break; - } - break; - case 'F' : i=getnum(&bufp,0,255,16); - for(j=0;j26)s-=26; - if(s==1)s=2; - } - setmem(map,256,0); - for(i=0;i<64;i++){ - if(i%4==0) putch('\n'); - j=32*i; - c=(dir[j]==0) ? '=' : '*'; - d=dir[j+12]; - mc=mapchar(i); - if(d==0xe5){ - printf("%c%19s",mc,""); - continue; - } - dir[j+12]=0; - printf("%c%c%s",mc,c,&dir[j+1]); - if(d != 0) printf("/%x",d%0x10); - else printf(" "); - printf(" %2x ",dir[j+15]); - if(c=='*')mc+=128; - for(k=16;k<32 && dir[j+k];k++){ - d=dir[j+k]; - if(mc<128) map[d]=mc; - } - } - for(i=0;i<0xf3;i++){ - if(i%64==0) putch('\n'); - else if(i%16==0) printf(" "); - else if(i%8==0) printf(" "); - putch(map[i] ? map[i] : '.'); - } - putch('\n'); - break; - case ' ' : break; - default : printf("%c ??????\n",c); - *bufp='\0'; - break; - } - if(kbhit()) getchar(); - } -} -getnum(pntr,low,high,base) -int low,high,base; -char **pntr; -{ - int number; - char c,buffer[50],*bp; - number=0; - while( **pntr== ' ') (*pntr)++ ; - while( (c=toupper(*(*pntr)++))>='0' && c<= '9' || - base==16 && (c-=7) > '9' && c <= ('F'-7) ) - number=base*number+c-'0'; - (*pntr)--; - if (numberhigh){ - printf("bad number %d ",number); - bp=gets(buffer); - number=getnum(&bp,low,high,base); - } - return (number); -} -mapchar(i) -char i; -{ if(i<10) return(i+'0'); - if(i<36) return(i-10+'a'); - return(i-36+'A'); -} - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/DISKTRAN.C b/software/CPM/CPM_MC_C1/DISKTRAN.C deleted file mode 100644 index 1593a77..0000000 --- a/software/CPM/CPM_MC_C1/DISKTRAN.C +++ /dev/null @@ -1,81 +0,0 @@ -/* - DISKTRAN - - This is a utility to convert nonstandard disk sector -interleave patterns to the standard (i.e., CP/M 1-to-6 weave) -or vice versa. The first two tracks are not included in the -copy. - -*/ - -#include "bdscio.h" - -#define MCOS 4 /* MCOS skew factor */ -#define CPM 6 /* Standard CP/M skew factor */ - -main() -{ - char buffer[26*SECSIZ]; /* Track buffer */ - - int toskew,fromskew; - int track,sector; - int index; - - char answer; - - puts("\t\tDISKTRAN\n\n"); - puts("A: Convert MCOS to CP/M\n\n"); - puts("B: Convert CP/M to MCOS\n"); - puts("\nEnter choice: "); - while((answer=toupper(getchar()))!='A'&&answer!='B'){ - puts("\nPlease enter A or B\n"); - puts("Enter choice: "); - } - if(answer=='A'){ - toskew=CPM; - fromskew=MCOS; - } - else{ - toskew=MCOS; - fromskew=CPM; - } - - puts("\n\nInsert source disk in drive A\n"); - puts("and destination disk in drive B, then hit a key\n"); - - while(!kbhit()); - getchar(); - - for(track=2;track<77;track++) - { - printf("Track %d\n",track); - bios(SELECT_DISK,0); - bios(SET_TRACK,track); - sector=1; - for(index=0;index<26;index++) - { - bios(SET_SECTOR,sector); - bios(SET_DMA,&buffer[SECSIZ*index]); - bios(READ_SECTOR); - sector+=fromskew; - if(sector>26)sector-=26; - if(sector==1)sector=2; - } - bios(SELECT_DISK,1); - sector=1; - for(index=0;index<26;index++){ - bios(SET_SECTOR,sector); - bios(SET_DMA,&buffer[SECSIZ*index]); - bios(WRITE_SECTOR); - sector+=toskew; - if(sector>26)sector-=26; - if(sector==1)sector=2; - } - } - - puts("Translation done\n"); - puts("Place system disk in drive A, and hit any key\n"); - while(!kbhit()); - getchar(); -} - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/DIVINE.C b/software/CPM/CPM_MC_C1/DIVINE.C deleted file mode 100644 index 80f279d..0000000 --- a/software/CPM/CPM_MC_C1/DIVINE.C +++ /dev/null @@ -1,49 +0,0 @@ - -/* - - This is a simple example of recursion in C. - Both the "fibo" and "fact" functions call - themselves (recurse). - Note that the results of the computations become - meaningless above certain values of n due to the - 16-bit value limit. Oh well. - -*/ - - -main() -{ - int n; - printf("\n\n \"To iterate is human;\n"); - printf(" to recurse is divine.\"\n\n"); - printf("At the question mark, enter an integer n.\n"); - printf("If n is positive, n! will be printed;\n"); - printf("If n is negative, the |n|th fibonacci number\n"); - printf("will be printed. \n"); - printf("Enter a null line or 0 to quit.\n\n"); - while (n = getnum()) - if (n>0) - printf("Factorial %d = %u\n",n,fact(n)); - else printf("Fibonacci number #%1d = %u\n",-n,fibo(-n)); -} - -fact(n) -int n; -{ - return n>2 ? n * fact(n-1) : n; -} - -fibo(n) -{ - return n<3 ? 1 : fibo(n-1)+fibo(n-2); -} - - -getnum() -{ - char input[100]; - printf("? "); - return atoi(gets(input)); -} - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/EL2.TC b/software/CPM/CPM_MC_C1/EL2.TC deleted file mode 100644 index e69de29..0000000 diff --git a/software/CPM/CPM_MC_C1/EL2LF.TC b/software/CPM/CPM_MC_C1/EL2LF.TC deleted file mode 100644 index 5ea6f8c..0000000 --- a/software/CPM/CPM_MC_C1/EL2LF.TC +++ /dev/null @@ -1,59 +0,0 @@ -getbyte char unit(163) -[ - char nb - int signal - nb=unit(35) - if(nb<=0)[ - signal=fread(unit+36,unit) - if(signal== -1)return 26 /* ^Z returned. - if(signal< -1)[ - ps"read error"; return 26 - ] - nb=0 - ] - unit(35)=nb+1 - return unit(nb+36) -] -putbyte char c,unit(163) -[ - char nb - int signal - nb=unit(35) - if(nb<0)[ - signal=fwrite(unit+36, unit+163, unit) - nb=0 - ] - unit(36+nb)=c - if(c==26) if(nb>0)[ - signal=fwrite(unit+36, unit+163, unit) - nb=0 - ] - unit(35)=nb+1 - return signal -] -eline char in(0), out(0) - int lf -[ - char unit(163, tounit(163, c, LF, CR - int signal - if(fopen(1,in,0,unit))return - if(fopen(2,out,0,tounit))return -/* this loop processes each character of the file - LF = 10 - CR = 13 - while(signal==0)[ - c=getbyte unit - if (c==CR) [ if (lf==1) [ - signal=putbyte CR,tounit - if (signal==0) signal=putbyte LF,tounit ]] - else if ((c!=LF)+(lf!=0)) signal=putbyte c,tounit - if (c==26) [ - signal=putbyte 26,tounit - signal=signal+1 - ] - ] - fclose(tounit) - fclose(unit) -] -main [endline "from" , "to" , 1] - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/ELINE.TC b/software/CPM/CPM_MC_C1/ELINE.TC deleted file mode 100644 index b700f52..0000000 --- a/software/CPM/CPM_MC_C1/ELINE.TC +++ /dev/null @@ -1 +0,0 @@ -getbyte char unit(163) [ char nb int signal nb=unit(35) if(nb<=0)[ signal=fread(unit+36,unit) if(signal== -1)return 26 /* ^Z returned. if(signal< -1)[ ps"read error"; return 26 ] nb=0 ] unit(35)=nb+1 return unit(nb+36) ] putbyte char c,unit(163) [ char nb int signal nb=unit(35) if(nb<0)[ signal=fwrite(unit+36, unit+163, unit) nb=0 ] unit(36+nb)=c if(c==26) if(nb>0)[ signal=fwrite(unit+36, unit+163, unit) nb=0 ] unit(35)=nb+1 return signal ] eline char in(0), out(0) int lf [ char unit(163, tounit(163, c, LF, CR int signal if(fopen(1,in,0,unit))return if(fopen(2,out,0,tounit))return /* this loop processes each character of the file LF = 10 CR = 13 while(signal==0)[ c=getbyte unit if (c==CR) [ signal=putbyte CR,tounit if (signal==0) if (lf==1) signal=putbyte LF,tounit ] else if ((c!=LF)+(lf!=0)) signal=putbyte c,tounit if (c==26) [ signal=putbyte 26,tounit signal=signal+1 ] ] fclose(tounit) fclose(unit) ] main [endline "from" , "to" , 1]  \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/ELINELF.TC b/software/CPM/CPM_MC_C1/ELINELF.TC deleted file mode 100644 index 65eaec3..0000000 --- a/software/CPM/CPM_MC_C1/ELINELF.TC +++ /dev/null @@ -1,53 +0,0 @@ -getbyte char unit(163) -[ - char nb - int signal - nb=unit(35) - if(nb<=0)[ - signal=fread(unit+36,unit) - if(signal== -1)return 26 /* ^Z returned. - if(signal< -1)[ - ps"read error"; return 26 - ] - nb=0 - ] - unit(35)=nb+1 - return unit(nb+36) -] -putbyte char c,unit(163) -[ - char nb - int signal - nb=unit(35) - if(nb<0)[ - signal=fwrite(unit+36, unit+163, unit) - nb=0 - ] - unit(36+nb)=c - if(c==26) if(nb>0)[ - signal=fwrite(unit+36, unit+163, unit) - nb=0 - ] - unit(35)=nb+1 - return signal -] -endline char in(0), out(0) - int lf -[ - char unit(163, tounit(163, c - int signal - if(fopen(1,in,0,unit))return - if(fopen(2,out,0,tounit))return -/* this loop processes each character of the file - while(signal==0)[ - c=getchar(unit) - if (c==13) if (lf==1) [ - signal=putchar 13,tounit - if (signal==0) signal=putchar 10,tounit ] - else if ((c!=10)+lf!=0) signal=putchar c,tounit - if (c==26) signal=signal+1 ] - fclose(tounit) - fclose(unit) -] -main [endline "from" , "to" , 1] - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/ENDLINE.TC b/software/CPM/CPM_MC_C1/ENDLINE.TC deleted file mode 100644 index 7ad5003..0000000 Binary files a/software/CPM/CPM_MC_C1/ENDLINE.TC and /dev/null differ diff --git a/software/CPM/CPM_MC_C1/FACT.TC b/software/CPM/CPM_MC_C1/FACT.TC deleted file mode 100644 index 78efdc2..0000000 Binary files a/software/CPM/CPM_MC_C1/FACT.TC and /dev/null differ diff --git a/software/CPM/CPM_MC_C1/FALLOUT.C b/software/CPM/CPM_MC_C1/FALLOUT.C deleted file mode 100644 index 541eca7..0000000 --- a/software/CPM/CPM_MC_C1/FALLOUT.C +++ /dev/null @@ -1,173 +0,0 @@ -/* - FALLOUT for the H19 - - This is a logical extension of "flyby.c" - - written by Leor Zolman - July 18, 1980 (I promise to stop playing with the H19 - and put more work into the v1.4 code - optimizer...tomorrow!) -*/ - -#include "bdscio.h" - -#define MAXTHINGS 50 /* Maximum # of objects on the screen - at once */ -#define INACTIVE 0 - -struct thing { - char what; /* Either an Ascii value, or INACTIVE */ - char rev; /* True if character to be displayed in reverse */ - int rowp; /* Row position of thing */ - int colp; /* Column position of thing */ - int speedd; /* Down speed */ - int speeda; /* Across speed (signed to indeciate left or right) */ - char trail; /* True if displaying trail */ - char zigzag; /* True if zigzag-ing */ - int zigmag; /* if zigzag-ing, magnitude of zig and zag */ - int zigpos; /* Count of how many zigs or zags have been done */ -}; - -char halt; /* goes true when user aborts */ - -main(argc,argv) -char **argv; -{ - struct thing thingtab[MAXTHINGS], *thingie; - int dspeedt[20], aspeedt[20]; /* Tables of possible speeds */ - int i,nthings; /* loop variable, and # of active things */ - char inrev; /* true if in reverse video */ - char trails; /* true if displaying all trails */ - char point_source; /* true if all things coming from one point */ - int source_point; /* if point_source true, the horiz pos */ - - printf("Welcome to H19 Fallout!\r\nWritten by Leor Zolman 7/80"); - initw(dspeedt,"1,1,1,1,1,1,1,1,1,1,2,2,2,2,3,3,3,4,4,5"); - initw(aspeedt,"0,0,0,1,1,1,2,2,2,3,3,3,4,4,4,5,5,5,6,7"); - point_source = trails = FALSE; - -start: do { - puts(CLEARS); puts(INTOREV); - puts("\33y5"); /* cursor on */ - printf(" How many things should I display (1-%d,", - MAXTHINGS); - srand1(" or q to quit) ? \b\b"); - if (!scanf("%d",&nthings)) { - puts(OUTAREV); - exit(); - } - } while (nthings < 1 || nthings > MAXTHINGS); - - puts(CLEARS); puts(OUTAREV); - halt = inrev = FALSE; - puts("\33x5"); /* cursor off */ - for (i=0; i what) { /* if it is inactive, create it: */ - thingie -> what = rand() % 96 + ' '; - thingie -> rev = rand() % 2; - thingie -> trail = rand() % 30 ? trails : !trails; - - thingie -> speedd = dspeedt[rand() % 20]; - thingie -> speeda = aspeedt[rand() % 20] * - ((rand() % 2) * 2 - 1); - if (thingie -> zigzag = !(rand() % 5)) { - thingie -> zigmag = - (rand() % 25 + 2) / abs(thingie -> speeda); - thingie -> zigpos = thingie -> zigmag / 2; - } - thingie -> rowp = 0; - - if (!point_source) - thingie -> colp = thingie -> zigzag ? - thingie->zigzag / 2 + 1 + - rand() % (TWIDTH - thingie -> zigmag) : - rand() % TWIDTH; - else - thingie -> colp = source_point; - } - - else { /* else move it down one iteration */ - if (!thingie -> trail) { /* if don't need trails, */ - if (inrev) { /* erase last position. */ - puts(OUTAREV); /* no reverse video */ - inrev--; - } - gotoxy(thingie -> rowp, thingie -> colp,' '); - } - if (thingie -> zigzag && /* if in zigzag mode */ - ++thingie -> zigpos > thingie -> zigmag) { - thingie -> zigpos = 0; /* then reverse dir */ - thingie -> speeda = -thingie -> speeda; - } - thingie -> rowp += thingie -> speedd; - thingie -> colp += thingie -> speeda; - if ( thingie -> rowp > (TLENGTH-1) /* if outa range */ - || thingie -> colp < 0 - || thingie -> colp > (TWIDTH-1) ) - thingie -> what = INACTIVE; /* then turn off */ - else { - if (thingie -> rev) { /* not out of range; */ - if (!inrev) { /* if a reverse char, */ - puts(INTOREV); /* make sure we're in */ - inrev = TRUE; /* reverse video mode */ - } - } - else if (inrev) { /* if not a rev char */ - puts(OUTAREV); /* make sure we're in */ - inrev--; /* normal video mode */ - } - gotoxy(thingie -> rowp, thingie -> colp, - thingie -> what); - } - } - - } - } - goto start; -} - -putchar(c) -{ - bios(4,c); -} - -gotoxy(x,y,c) -{ - char c2; - if (y <= 78 || x != 23) { - putchar (ESC); - putchar ('Y'); - putchar (x + ' '); - putchar (y + ' '); - putchar (c); - } - if (!bios(2)) return; - if ((c2 = bios(3)) != 0x13) halt = 1; - if (c2 == 0x13) - while (1) { - while (!bios(2)) rand(); - if (bios(3) == 0x11) break; - } -} - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/FILECOMP.C b/software/CPM/CPM_MC_C1/FILECOMP.C deleted file mode 100644 index 4fc109e..0000000 --- a/software/CPM/CPM_MC_C1/FILECOMP.C +++ /dev/null @@ -1,275 +0,0 @@ -#include -/* : : : : : : : : : : : : : : : : : : : : : : : : : : : : : : - Program to compare (byte for byte) - two files and print differences - - H.Moran 10/27/79 - slight mod 2/13/80 - : : : : : : : : : : : : : : : : : : : : : : : : : : : : : : */ - -/* : : : : : : : : : : : : : : : : : : : : : : : : : : : : : : - Macros for constant definitions - : : : : : : : : : : : : : : : : : : : : : : : : : : : : : : */ - -#define NOFILE -1 /* no such file indication given by fopen() */ - - -/* ------------------------------------------------------- - - Name: main(argc,argv) - Result: --- - Errors: invocation syntax error or no such file - Globals: --- - Macros: TRUE,FALSE,NOFILE - Procedures: fopen(),tolower(),bummer(),htoi(),fcompare() - - Action: Byte by byte compare of 2 files and - print their differences on console - - ------------------------------------------------------- */ - - -main(argc,argv) - int argc; - char *argv[]; - { - int fdin,fdout,ascii; - unsigned start_adrs,htoi(); - char *ptr; - char mstbuf[BUFSIZ],chkbuf[BUFSIZ]; - - ascii = FALSE; /* assign the defaults */ - start_adrs = 0; - if( argc < 3 || argc > 5 ) - bummer(); - else if( (fdin = fopen(argv[1],mstbuf)) == NOFILE ) - printf("No such file %s\n",argv[1]); - else if( (fdout = fopen(argv[2],chkbuf)) == NOFILE) - printf("No such file %s\n",argv[2]); - else { - while( argc > 3 ) { - ptr = argv[--argc]; - if( *ptr++ != '-' ) - bummer(); - switch ( tolower(*ptr++) ) { - - case 'a': ascii = TRUE; - break; - - case 'b': start_adrs = htoi(ptr); - break; - - default: puts("Unrecognized option. Aborted\n\n"); - bummer(); - } /* end switch */ - } /* end while */ - fcompare(mstbuf,chkbuf,start_adrs,ascii); - } /* end else */ - exit(); - } - - -/* ------------------------------------------------------- - - Name: fcompare(mfile,cfile,adrs,ascii) - Result: --- - Errors: --- - Globals: --- - Macros: EOF,CPMEOF - Procedures: getc(),puts(),strcpy(),printf() - - Action: compare 2 files and print their differences - on the console - - ------------------------------------------------------- */ - - - -fcompare(mfile,cfile,adrs,ascii) - char mfile[]; /* the input file buffer */ - char cfile[]; /* the output file buffer */ - unsigned adrs; /* the address of begin of file */ - int ascii; /* flag of whether these are ascii files */ - { - int mc,cc; /* 1 char buffers */ - char erflg; /* flag that an error has occurred */ - char *xl(); /* function to translate control chars */ - char str1[6],str2[6]; /* temporaries for strings */ - char xlate[10]; /* string used in ascii control char translation */ - - - erflg = 0; - while( ! ( (mc = getc(mfile)) == EOF || (ascii && mc == CPMEOF)) ) { - if( (cc =getc(cfile)) == EOF || ( ascii && cc == CPMEOF )) { - puts("Checkfile shorter than Master file\n"); - return; - } - else if( mc != cc ) { - if( ! erflg ) { - erflg = 1; - puts("\nRelative Master Check"); - puts("\nAddress File File Mismatch"); - puts("\n------- ---- ---- --------\n"); - } /* end if */ - if( ascii ) { - strcpy(str1,xl(mc,xlate)); /* fudge because parameters are */ - strcpy(str2,xl(cc,xlate)); /* evaluated before being passed */ - printf("%4x %-4s %-4s %8b\n",adrs,str1,str2,mc^cc); - } - else - printf("%4x %2x %2x %8b\n",adrs,mc,cc,mc ^ cc); - } /* end else if */ - else - ; - adrs++; - } /* end while */ - if(! ( (cc = getc(cfile)) == EOF || (ascii && cc == CPMEOF) ) ) - puts("Masterfile shorter than checkfile\n"); - return; - } /* end fcompare() */ - -/* ------------------------------------------------------- - - Name: err_exit(msg) - Result: --- - Errors: --- - Globals: --- - Macros: --- - Procedures: printf(),exit() - - Action: Print a message then exit to CP/M - - ------------------------------------------------------- */ - - -err_exit(msg) - char *msg; - { - exit(puts(msg)); - } - -/* ------------------------------------------------------- - - Name: htoi(string) - Result: unsigned integer value of ascii hex string - Errors: --- - Globals: --- - Macros: --- - Procedures: tolower(),isalpha(),isdigit() - - Action: --- - - ------------------------------------------------------- */ - - -unsigned htoi(string) - char *string; - { - unsigned number; - char c; - - number = 0; - c = tolower(*string++); - while( isalpha(c) || isdigit(c) ) { - if( c > 'f' ) - return number; - number *= 16; - if( isdigit(c) ) - number += c -'0'; - else - number += c - 'a' + 10; - c = tolower(*string++); - } - return number; - } -/* ------------------------------------------------------- - - Name: bummer() - Result: --- - Errors: --- - Globals: --- - Macros: --- - Procedures: puts(),exit() - - Action: Print the invocation syntax error message - and exit to CP/M - - ------------------------------------------------------- */ - - -bummer() - { - puts("Correct invocation form is:\n"); - puts(" FILECOMP {-a -b}\n\n"); - puts("Where optional arguments are:\n\n"); - puts("-a => these are ascii files (terminate on 1AH )\n"); - puts("-b => begin of file is address "); - puts("default is 0\n"); - exit(); - } - - -/* ------------------------------------------------------- - - Name: xl(c) - Result: pointer to xlate[] - Errors: --- - Globals: - Macros: --- - Procedures: strcpy() - - Action: Translate the char argument c into a - 4 char string in xlate[] - If c is a printable ascii char its - translation is itself right blank padded - Else if c is a standard control char its - translation is a string identifying that - control char - Else its translation is "????" - - ------------------------------------------------------- */ - - -char *xl(c,xlate) - int c; - char *xlate; - { - if( c > 0x7f || c < 0 ) - strcpy(xlate,"????"); - else if( c == 0x7f ) - strcpy(xlate,"del "); - else if( c > 0x1f ) { /* then it is printable */ - xlate[0] = c; - strcpy(xlate+1," "); - } - else - switch (c) { - case 0x7: strcpy(xlate,"bel"); - break; - - case 0x8: strcpy(xlate,"bs"); - break; - - case 0x9: strcpy(xlate,"tab"); - break; - - case 0xa: strcpy(xlate,"lf"); - break; - - case 0xc: strcpy(xlate,"ff"); - break; - - case 0xd: strcpy(xlate,"cr"); - break; - - case 0x1b: strcpy(xlate,"esc"); - break; - - default: xlate[0] = '^'; /* show control chars as */ - xlate[1] = c + 0x40; /* ^ e.g. ^A is */ - xlate[2] = '\0'; /* control A */ - break; - } - return xlate; - } - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/FLOAT.C b/software/CPM/CPM_MC_C1/FLOAT.C deleted file mode 100644 index d722375..0000000 --- a/software/CPM/CPM_MC_C1/FLOAT.C +++ /dev/null @@ -1,315 +0,0 @@ - - -/* - Floating point package support routines - - Note the "fp" library function, available in DEFF2.CRL, - is used extensively by all the floating point number - crunching functions. - - (see FLOAT.DOC for details...) - - NEW FEATURE: a special "printf" function has been included - in this source file for use with floating point - operands, in addition to the normal types. The - printf presented here will take precedence over - the DEFF.CRL version when "float" is specified - on the CLINK command line at linkage time. - Note that the "fp" function, needed by most of - the functions in this file, resides in DEFF2.CRL - and will be automatically collected by CLINK. - - All functions here written by Bob Mathias, except printf and - _spr (written by Leor Zolman.) -*/ - -#include "bdscio.h" - -#define NORM_CODE 0 -#define ADD_CODE 1 -#define SUB_CODE 2 -#define MULT_CODE 3 -#define DIV_CODE 4 -#define FTOA_CODE 5 - -fpcomp(op1,op2) - char *op1,*op2; -{ - char work[5]; - fpsub(work,op1,op2); - if (work[3] > 127) return (-1); - if (work[0]+work[1]+work[2]+work[3]) return (1); - return (0); -} - -fpnorm(op1) char *op1; -{ fp(NORM_CODE,op1,op1);return(op1);} - -fpadd(result,op1,op2) - char *result,*op1,*op2; -{ fp(ADD_CODE,result,op1,op2);return(result);} - -fpsub(result,op2,op1) - char *result,*op1,*op2; - {fp(SUB_CODE,result,op1,op2);return(result);} - -fpmult(result,op1,op2) - char *result,*op1,*op2; -{ fp(MULT_CODE,result,op1,op2);return(result);} - -fpdiv(result,op1,op2) - char *result,*op1,*op2; -{ fp(DIV_CODE,result,op1,op2);return(result);} - -atof(fpno,s) - char fpno[5],*s; -{ - char *fpnorm(),work[5],ZERO[5],FP_10[5]; - int sign_boolean,power; - - initb(FP_10,"0,0,0,80,4"); - setmem(fpno,5,0); - sign_boolean=power=0; - - while (*s==' ' || *s=='\t') ++s; - if (*s=='-'){sign_boolean=1;++s;} - for (;isdigit(*s);++s){ - fpmult(fpno,fpno,FP_10); - work[0]=*s-'0'; - work[1]=work[2]=work[3]=0;work[4]=31; - fpadd(fpno,fpno,fpnorm(work)); - } - if (*s=='.'){ - ++s; - for (;isdigit(*s);--power,++s){ - fpmult(fpno,fpno,FP_10); - work[0]=*s-'0'; - work[1]=work[2]=work[3]=0;work[4]=31; - fpadd(fpno,fpno,fpnorm(work)); - } - } - if (toupper(*s) == 'E') {++s; power += atoi(s); } - if (power>0) - for (;power!=0;--power) fpmult(fpno,fpno,FP_10); - else - if (power<0) - for (;power!=0;++power) fpdiv(fpno,fpno,FP_10); - if (sign_boolean){ - setmem(ZERO,5,0); - fpsub(fpno,ZERO,fpno); - } - return(fpno); -} -ftoa(result,op1) - char *result,*op1; -{ fp(FTOA_CODE,result,op1);return(result);} - -itof(op1,n) -char *op1; -int n; -{ - char temp[20]; - return atof(op1, itoa(temp,n)); -} - -itoa(str,n) -char *str; -{ - char *sptr; - sptr = str; - if (n<0) { *sptr++ = '-'; n = -n; } - _uspr(&sptr, n, 10); - *sptr = '\0'; - return str; -} - - -/* - The short "printf" function given here is exactly the - same as the one in the library, but it needs to be placed - here so that the special "_spr" is used instead of the - normal one in DEFF.CRL. The way the linker works is that - a function is not linked in UNTIL IT IS REFERENCED...so - if the definition of "printf" were not placed here in this - file, "_spr" would not be referenced at all - until the "printf" from DEFF.CRL got yanked in, at which time - "_spr" would ALSO be taken from DEFF.CRL and cause the - floating point "_spr" options to not be recognized. - - In other words, if "printf" were not given explicitly here, - the WRONG _spr would end up being used. -*/ - - -printf(format) -char *format; -{ - char line[MAXLINE]; - _spr(line,&format); /* use "_spr" to form the output */ - puts(line); /* and print out the line */ -} - - -/* - This is the special formatting function, which supports the - "e" and "f" conversions as well as the normal "d", "s", etc. - When using "e" or "f" format, the corresponding argument in - the argument list should be a pointer to one of the five-byte - strings used as floating point numbers by the floating point - functions. Note that you don't need to ever use the "ftoa" - function when using this special printf/sprintf combination; - to achieve the same result as ftoa, a simple "%e" format - conversion will do the trick. "%f" is used to eliminate the - scientific notation and set the precision. The only [known] - difference between the "e" and "f" conversions as used here - and the ones described in the Kernighan & Ritchie book is that - ROUNDING does not take place in this version...e.g., printing - a floating point number which happens to equal exactly 3.999 - using a "%5.2f" format conversion will produce " 3.99" instead - of " 4.00". -*/ - - -_spr(line,fmt) -char *line, **fmt; -{ - char _uspr(), c, base, *sptr, *format; - char wbuf[80], *wptr, pf, ljflag; - int width, precision, exp, *args; - - format = *fmt++; /* fmt first points to the format string */ - args = fmt; /* now fmt points to the first arg value */ - while (c = *format++) - if (c == '%') { - wptr = wbuf; - precision = 6; - ljflag = pf = 0; - - if (*format == '-') { - format++; - ljflag++; - } - - if ( !(width = _gv2(&format))) width++; - - if ((c = *format++) == '.') { - precision = _gv2(&format); - pf++; - c = *format++; - } - - switch(toupper(c)) { - case 'E': if (precision>7) precision = 7; - ftoa(wbuf,*args++); - strcpy(wbuf+precision+3, wbuf+10); - width -= strlen(wbuf); - goto pad2; - - case 'F': ftoa(&wbuf[60],*args++); - sptr = &wbuf[60]; - while ( *sptr++ != 'E') - ; - exp = atoi(sptr); - sptr = &wbuf[60]; - if (*sptr == ' ') sptr++; - if (*sptr == '-') { - *wptr++ = '-'; - sptr++; - width--; - } - sptr += 2; - - if (exp < 1) { - *wptr++ = '0'; - width--; - } - - pf = 7; - while (exp > 0 && pf) { - *wptr++ = *sptr++; - pf--; - exp--; - width--; - } - - while (exp > 0) { - *wptr++ = '0'; - exp--; - width--; - } - - *wptr++ = '.'; - width--; - - while (exp < 0 && precision) { - *wptr++ = '0'; - exp++; - precision--; - width--; - } - - while (precision && pf) { - *wptr++ = *sptr++; - pf--; - precision--; - width--; - } - - while (precision>0) { - *wptr++ = '0'; - precision--; - width--; - } - - goto pad; - - - case 'D': if (*args < 0) { - *wptr++ = '-'; - *args = -*args; - width--; - } - case 'U': base = 10; goto val; - - case 'X': base = 16; goto val; - - case 'O': base = 8; - - val: width -= _uspr(&wptr,*args++,base); - goto pad; - - case 'C': *wptr++ = *args++; - width--; - goto pad; - - case 'S': if (!pf) precision = 200; - sptr = *args++; - while (*sptr && precision) { - *wptr++ = *sptr++; - precision--; - width--; - } - - pad: *wptr = '\0'; - pad2: wptr = wbuf; - if (!ljflag) - while (width-- > 0) - *line++ = ' '; - - while (*line = *wptr++) - line++; - - if (ljflag) - while (width-- > 0) - *line++ = ' '; - break; - - default: *line++ = c; - - } - } - else *line++ = c; - - *line = '\0'; -} - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/FLOATSUM.C b/software/CPM/CPM_MC_C1/FLOATSUM.C deleted file mode 100644 index c29ec94..0000000 --- a/software/CPM/CPM_MC_C1/FLOATSUM.C +++ /dev/null @@ -1,39 +0,0 @@ - -/* - This program is a simple example of how to use - Bob Mathias's floating point package. To compile it, - first compile (but do not link) both this file - and FLOAT.C. - Then, give the CLINK command: - - A>clink floatsum float - - and run the thing by saying: - - A>floatsum - - Note: the "printf" function resulting from this linkage - will support the "e" and "f" floating point conversion - characters, but the regular "printf" would not. The reason: - the special version of "_spr" in the FLOAT.C source file - takes precedence over the library version of "_spr", and - thus supports the extra features. See the comments in FLOAT.C - for more details on this strangeness. -*/ - -main() -{ - char s1[5], s2[5], s3[5]; - char string[30]; - char sb[30]; - int i; - atof(s1,"0"); - while (1) { - printf("sum = %10.6f\n",s1); - printf("\nEnter a floating number: "); - fpadd(s3,s1,atof(s2,gets(string))); - for (i=0; i<5; i++) s1[i] = s3[i]; - } -} - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/GETPUT.TC b/software/CPM/CPM_MC_C1/GETPUT.TC deleted file mode 100644 index 12ef9b5..0000000 --- a/software/CPM/CPM_MC_C1/GETPUT.TC +++ /dev/null @@ -1 +0,0 @@ -getbyte char unit(163) [ char nb int signal nb=unit(35) if(nb<=0)[ signal=fread(unit+36,unit) if(signal== -1)return 26 /* ^Z returned. if(signal< -1)[ ps"read error"; return 26 ] nb=0 ] unit(35)=nb+1 return unit(nb+36) ] putbyte char c,unit(163) [ char nb int signal nb=unit(35) if(nb<0)[ signal=fwrite(unit+36, unit+163, unit) nb=0 ] unit(36+nb)=c if(c==26) if(nb>0)[ signal=fwrite(unit+36, unit+163, unit) nb=0 ] unit(35)=nb+1 return signal ]  \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/GLOBALS.WP b/software/CPM/CPM_MC_C1/GLOBALS.WP deleted file mode 100644 index 2b2ff82..0000000 --- a/software/CPM/CPM_MC_C1/GLOBALS.WP +++ /dev/null @@ -1,40 +0,0 @@ -/* - Globals -*/ - - int curpag; /* current output page number (init 0) */ - int newpag; /* next output page number (init 1) */ - int lineno; /* next line to be printed (init 0) */ - int plval; /* page length in lines (init PAGELEN) */ - int m1val; /* margin before and including header */ - int m2val; /* margin after header */ - int m3val; /* margin after last text line */ - int m4val; /* bottom margin including footer */ - int bottom; /* last live line on page */ - char header[MAXLINE]; /* (init '\n') */ - char footer[MAXLINE]; /* (init '\n') */ - - char wrdbuf[INSIZE]; /* should be static in text() */ - - char fill; /* fill if YES (init YES) */ - int lsval; /* current line spacing (init 1) */ - int inval; /* current indent >= 0 (init 0) */ - int rmval; /* current right margin (init PAGEWIDTH) */ - int tival; /* current temporary indent (init 0) */ - int ceval; /* # of lines to be centered (init 0) */ - int ulval; /* # of lines to be underlined (init 0) */ - - char argtyp; /* '+', '-' or '0' argument type */ - - int outp; /* last char pos in outbuf (init 0) */ - int outw; /* width of outbuf */ - int outwds; /* # of words in outbuf */ - char outbuf[MAXOUT]; /* lines to be filled collect here */ - - char dir; /* direction from which to add blanks */ - - char *outfile; /* buffered output file structure pointer */ - - - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/GUESSNUM.TC b/software/CPM/CPM_MC_C1/GUESSNUM.TC deleted file mode 100644 index 20e313b..0000000 Binary files a/software/CPM/CPM_MC_C1/GUESSNUM.TC and /dev/null differ diff --git a/software/CPM/CPM_MC_C1/LIFE.C b/software/CPM/CPM_MC_C1/LIFE.C deleted file mode 100644 index 59dd46c..0000000 --- a/software/CPM/CPM_MC_C1/LIFE.C +++ /dev/null @@ -1,278 +0,0 @@ - -/* - "LIFE" - - The game invented by John Conway - - This version written by Leor Zolman to exemplify - PROPER use of "goto" statements in C programs! - - Note that the Universe is a toroid; - The left extreme is adjacent to the right extreme, - the top is adjacent to the bottom, and each corner - is adjacent to each other corner. - In other words, there ARE NO EXTREMES !! - Or, in a more physical illustration: If you could - look straight ahead through an infinitely powerful - telescope, you'd eventually see the back of your - head.... - -*/ - -#define HIGHT 16 /* # of lines on your terminal */ -#define WIDTH 64 /* # of columns on your terminal */ -#define XSIZE 100 /* length of cell array */ -#define YSIZE 100 /* width of cell array */ - /* To see how the toroid works, - try reducing XSIZE and YSIZE to - around 10 or 20. */ -#define CENTER 1 /* 1 = center; 0 = left justify */ - -char *gets(); -char cell[XSIZE][YSIZE]; -int minx, maxx, miny, maxy, pop, gen; -int adj[16]; -char doneflag; - -main() -{ - initw(adj,"-1,-1,-1,0,-1,1,0,-1,0,1,1,-1,1,0,1,1"); - for (;;) { - clear(); - setup(); - if (!pop) break; - adjust(); - display(); - while (pop) { - adjust(); - dogen(); - display(); - if (kbhit()) {getchar(); break;} - if (doneflag) break; - } - } - } - -/* initialize the cell matrix to all dead */ -clear() -{ - setmem(cell,(XSIZE*YSIZE),0); -} - -/* get initial set-up from user */ -setup() -{ - char c,y; - char string[YSIZE], *ptr; - y = pop = gen = minx = maxx = miny= maxy = 0; - printf("\n\nEnter initial configuration (null line to end):\n"); - - while (*gets(string)) { - ptr = string; - while (*ptr) { - if ( *ptr++ != ' ') { - cell[maxx][y] = 2; - ++pop; - } - ++y; - if (y==YSIZE) { - printf("Truncated to %d chars\n", - YSIZE); break; - } - } - --y; - ++maxx; - if (y>maxy) maxy = y; - if (maxx==XSIZE) break; - y = 0; - } - --maxx; -} - -/* display the current generation */ -display() -{ - int i,j,k,j9; - char c; - - if(minx && prow(minx-1)) minx--; - if(miny && pcol(miny-1)) miny--; - if ((maxx < (XSIZE-1)) && prow(maxx+1)) maxx++; - if((maxy<(YSIZE-1)) && pcol(maxy+1))maxy++; - - while (!prow(minx)) minx++; - while (!prow(maxx)) maxx--; - while (!pcol(miny)) miny++; - while (!pcol(maxy)) maxy--; - - printf("\n\ngeneration = %1d population = %1d ", - gen,pop); - ++gen; - - putchar('\n'); - - j9 = maxy - miny + 1; - for (i = minx; i<=maxx; i++) { - if (CENTER && j9(XSIZE-3) || - miny<2 || maxy>(YSIZE-3)) ; - i2 = (maxx==(XSIZE-1)) ? maxx : maxx+1; - j2 = (maxy==(YSIZE-1)) ? maxy : maxy+1; - for (i=minx ? minx-1 : minx; i<=i2; ++i) - for (j=miny ? miny-1 : miny; j<=j2; ++j) { - friends = 0; - if(bigflag) - for (k=0; k<16; ++k) { - if (cell[mod(i+adj[k++],XSIZE)] - [mod(j+adj[k],YSIZE)] & 2)++friends; - } - else - for (k=0; k<16; ++k) - if (cell[i+adj[k++]][j+adj[k]]&2) - ++friends; - - if (cell[i][j] & 2) { - if (friends<2 || friends>3) { - doneflag = 0; - cell[i][j] = 3; - --pop; - } - } - else if (friends==3) { - doneflag = 0; - cell[i][j] = 1; - ++pop; - } - } -} - - -int mod(a,b) -{ - if (a<0) return b+a; - if (a XSIZE-2) return; - if (minx==0) { - delta = (XSIZE-maxx)/2+maxx; - savdelta = delta; - for (i=maxx; i >= 0; --i) { - for (j=miny; j<=maxy; ++j) { - cell[delta][j] = cell[i][j]; - cell[i][j] = 0; - } - --delta; - } - minx = delta+1; - maxx = savdelta; - } - - if (maxx == (XSIZE-1)) { - delta = minx/2; - savdelta = delta; - for (i=minx; i YSIZE -2) return; - if (miny == 0) { - delta = (YSIZE-maxy)/2+maxy; - savdelta = delta; - for (i=maxy; i>=0; --i) { - for (j=minx; j<=maxx; ++j) { - cell[j][delta] = cell[j][i]; - cell[j][i] = 0; - } - --delta; - } - miny = delta+1; - maxy = savdelta; - } - - if (maxy == (YSIZE-1)) { - delta = miny/2; - savdelta = delta; - for (i=miny; i> 5) % ROWS -#define RANDCOL (rand() >> 6) % COLUMNS - -char speed, density, setcnt, erasmod, bkround; -char frontp, nactive, dchar, charcd, charmode; - -struct module { - char freq; - int nfactor; - char active; - } mtab[MODULES]; - -char activet[MODULES]; -char *modnames[MODULES]; -int adj[16]; - -int flag; -main() -{ - char cmod, i, j, k, l, c; - char x, y, x1, y1, x2, y2; - char count,brkflg; - int limit, d; - - startit(); - for(;;){ - if (nactive) - while (!kbhit()) { - if(frontp) { - speed = csw() >> 4; - density = csw() & 15; - } - if(erasmod == 1) clear(); - do - cmod = rand() % nactive; - while (mtab[activet[cmod]].freq > rand()&15); - - limit = rand() % setcnt; - for (i=0; i < limit; i++) { - if (kbhit()) break; - switch (erasmod) { - case 2: clear(); break; - case 3: if(!(rand()%(speed+speed)))clear(); - } - outp(255, ~activet[cmod]); - - switch(activet[cmod]) { - case 0: /* lines */ - count = rand()%(density*5); - do { - figure(); - dline(0, RANDROW, - RANDCOL, - (rand(), RANDROW), - RANDCOL); - } while (count--); - break; - - case 1: /* Connected Random lines */ - count = rand()%(density*5); - x = RANDROW; - y = RANDCOL; - do { - figure(); - x1 = RANDROW; - y1 = RANDCOL; - dline (0,x,y,x1,y1); - x = x1; - y = y1; - } while (count--); - break; - - - case 2: /* rectangles */ - count = rand() % (density<<3); - do { - figure(); - x1 = RANDROW; - y1 = RANDCOL; - x2 = RANDROW; - y2 = RANDCOL; - dline (0, x1, y1, x1, y2); - dline (0, x2, y1, x2, y2); - dline (0, x1, y1, x2, y1); - dline (0, x1, y2, x2, y2); - } while (count--); - break; - - - case 3: /* triangles */ - count = rand() % (density<<2); - do { - figure(); - x = rand()%ROWS; - x1 = RANDROW; - x2 = RANDROW; - y = RANDCOL; - y1 = RANDCOL; - y2 = RANDCOL; - dline (0, x, y, x1, y1); - dline (0,x1,y1,x2,y2); - dline (0,x2,y2,x,y); - } while (count--); - break; - - case 4: /* ECKS IS */ - count = rand() % (density<<3); - do { - figure(); - x = RANDROW; - x1 = RANDROW; - y = RANDCOL; - - y1 = RANDCOL; - dline (0,x,y,x1,y1); - dline (0,x,y1,x1,y); - } while (count--); - break; - - case 5: /* vertices */ - count = rand() % density; - do { - figure(); - x = RANDROW; - y = RANDCOL; - while (rand()&15) - dline(0,x,y,RANDROW,RANDCOL); - } while (count--); - break; - - case 6: /* dart */ - x1 = RANDROW; - y1 = RANDCOL; - count = rand() % (density<<2); - do { - d = rand() % 8; - do { - x = x1; - y = y1; - plot (x,y,rand()); - x1 += adj[d+d]; - y1 += adj[d+d+1]; - } while (x1<16 && y1<64); - x1=x; y1=y; - } while (count--); - break; - - - } - } - } - c = getchar(); - flag = 1; - brkflg=0; - while (!brkflg) { - putchar(HOME); - if (!flag) { - commands(); - printf("\nCommand: "); - } - c = flag? c : getchar(); - flag = 0; - switch (c) { - case '\n': - rand(); rand(); rand(); clear(); brkflg=1; - break; - case 's': - speed = gethd( - "new speed factor (0=slow ... F=fast): "); - break; - - case 'd': - density = gethd( - "new density factor (0=sparse ... F=dense): "); - break; - - case 'n': - setcnt = gethd( - "new maximum set size (0 - F): "); - break; - - case 'f': - frontp = 1; - printf("\nOK; the high order 4 input switches"); - printf(" at port 255 now control\n"); - printf(" SPEED, and the low order 4 bits"); - printf(" control DENSITY.\n"); - printf("Type CR to continue..."); - getchar(); - break; - - case 'k': - frontp = 0; break; - - case 'q': - return; - - case 'b': - printf("\nEnter new backround character \ -(or ESCAPE for inversion): "); - if ((bkround = getchar() ) == ESC ) { - printf("\nOK, now type the actual char: "); - bkround = getchar() | 0x80; - } - break; - - case 'r': - display(); - if ( !(c = getmod() ) || !mtab[c-1].active) - break; - mtab[c-1].active = 0; - --nactive; - compile(); - break; - - case 'm': - display(); - if ( !(c = getmod() )) break; - mtab[c-1].freq = gethd( - "Frequency factor (0 - F): "); - mtab[c-1].active = 1; - ++nactive; - compile(); - break; - - case 'e': - putchar('\n'); - printf("0 = never erase 1 = erase \ -on module entry\n"); - printf("2 = at start of sets \ -3 = randomly\n"); - do erasmod = gethd( - "Enter new erase mode (0 - 3): "); - while (erasmod > 3); - break; - - case ' ': - brkflg=1; - break; - - case 'c': - printf("\n0 - fixed character 1 - random char per line\n"); - printf("2 - rand char per figure 3 - randomness\n"); - do charmode = gethd("Enter character choosing mode (0-3): "); - while (charmode > 3); - if (!charmode) { - printf("\nType the character (or ESCAPE for inversion): "); - if ( (dchar = getchar()) == ESC) { - printf("\nType the actual character: "); - dchar = getchar() | 0x80; - } - break; - } - if (charmode == 3) charcd = rand() % 100; - break; - - } - } - brkflg=0; - } -} - - -clear() -{ - setmem(VDMBASE, ROWS*COLUMNS, bkround); - outp ( 0xc8, 0); -} - - -compile() -{ - char slot; int i; - slot = 0; - for (i=0; i= '0' && c <= '9') return c - '0'; - if (c>='a' && c <= 'f') return c - 87; - } -} - -getch() -{ - char c; - c = getchar(); - if (c >= 'A' && c <= 'Z') return c+32; - return c; -} - - -getmod() -{ - char c; - printf("\nEnter module letter (a - %c): ", - MODULES+'a'-1); - while (( c = getch() ) == ' ' || c=='\t'); - if (c >= 'a' && c <= MODULES+'a'-1) return c-'a'+1; - return 0; -} - - -display() -{ - int i,j,k; - clrplot(); - putchar('\n'); - for (i=0; i=0 && n<=9) return n+'0'; - return n+87; -} - - -figure() -{ - int delay; - if (charmode==2) dchar = rand(); - if (15-speed) for (delay=0; delay<((15-speed)<<5); - delay++); -} - - -dline(c,x1,y1,x2,y2) -char c; -int x1,y1,x2,y2; -{ - if (charmode==1) dchar= rand(); - else if (charmode == 3) if (!charcd--) { - dchar = - (rand()%4==1) ? bkround - : rand(); - charcd = rand() % 100; - } - line(dchar,x1,y1,x2,y2); -} - - -startit() -{ - int i; - srand(0); - initw(adj,"-1,-1,-1,0,0,1,1,1,-1,0,1,-1,1,-1,0,1"); - speed = 15; - density = 12; - setcnt = 15; - erasmod = 3; - bkround = ' '; - frontp = 0; - nactive = 5; - dchar = rand(); - charmode = 3; - mtab[0].freq = 5; - mtab[0].active = 1; - mtab[1].active = 1; - mtab[1].freq = 5; - mtab[2].active = 1; - mtab[2].freq = 2; - mtab[3].active = 1; - mtab[3].freq = 4; - mtab[4].active = 1; - mtab[4].freq = 3; - modnames[0] ="Random Lines"; - modnames[1] ="Connected Random Lines"; - modnames[2] ="Rectangles"; - modnames[3] ="Triangles"; - modnames[4] ="Ecks Is"; - modnames[5] ="Vertices"; - modnames[6] ="Dart"; - mtab[0].nfactor=3; - mtab[1].nfactor=3; - mtab[2].nfactor = 1; - mtab[3].nfactor = 1; - mtab[4].nfactor = 2; - mtab[5].nfactor = 1; - mtab[6].nfactor = 1; - setplot(VDMBASE,ROWS,COLUMNS); - for (i=5; i foo arg1 arg2 arg3 ) - But, unfortunately, CP/M doesn't bother to save that - part of the command line, so the C COM file can never - see what its name really is. - Note that ARGV can NEVER equal zero; the case of zero - arguments causes ARGV to be equal to 1. Again, this - is to maintain compatibility with UNIX C. - - Alternatively (and, in fact, how it is done here), it - is possible to use the variable argv as a pointer, so - that the value of - *++argv - upon entry to main would point to the first - argument string; after incrementing argv again - it would point to the second argument string, etc. - Note how the increment operation specified by - argv++ - or - ++argv - knows to add 2 to argv, since argv was declared as - a pointer to pointers, and pointers take 2 bytes! - Thus, should argv have been (incorrectly) declared - char *argv; - then the - argv++ - operation would add only 1 to argv, instead of 2. - - Oh well, enough tutorial. Here's the program... - -*/ - - -#define BUFSIZ 8192 - -int lpos; -int lines; - -main(argc,argv) -int argc; -char **argv; -{ - outp(0,8); /* set 3P+S to 1200 baud */ - while (--argc) { - printf("\nPrinting %s...\n",*++argv); - putlist(*argv); - } -} - -putlist(file) -char *file; -{ - char buffer[BUFSIZ]; - int fd,i,j; - int nsects; - lpos=1; /* keep track of print head position */ - nsects = BUFSIZ/128; - bdos(5,0x0d); - for(i=0; i<8; i++) bdos(5,0x0a); - lines=1; - fd=open(file,0); - if ( fd == -1) return; - while ((j= read(fd,buffer,nsects))==nsects) - putchunk(buffer); - if (j) putchunk(buffer); - close(fd); -} - - -/* - This routine puts BUFSIZ characters (or until EOF) - out on the list device. -*/ - -putchunk(buffer) -char *buffer; -{ - char c; - int i,j,k; - for (k=0; k 2) goto loop; - formfeed(); - } - formfeed(); - if (pgno % 2) formfeed(); - fabort(fd); - } -} - -/* - Print a line of text out on the list device, and - return true if a formfeed was encountered in the - text. -*/ - -linepr(string) -char *string; -{ - char c, ffflag; - ffflag = 0; - while (c = *string++) - switch (c) { - case FF: - ffflag = 1; - break; - case '\n': - putlpr('\r'); - putlpr('\n'); - colno = 0; - linesleft--; - break; - - case '\t': - do { - putlpr(' '); - colno++; - } while (colno % 8); - break; - - default: - putlpr(c); - colno++; - } - if (ffflag) formfeed(); - return ffflag; -} - -putlpr(c) -char c; -{ - bios(LIST,c); -} - -formfeed() -{ - if (FF) putlpr(FF); - else while (linesleft--) putlpr('\n'); - linesleft = PGLEN; -} - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/MACDEFS.WP b/software/CPM/CPM_MC_C1/MACDEFS.WP deleted file mode 100644 index 9f5f980..0000000 --- a/software/CPM/CPM_MC_C1/MACDEFS.WP +++ /dev/null @@ -1,44 +0,0 @@ -/* - Word processor commands -*/ - -#define UNKNOWN -1 -#define BP 1 /* begin page */ -#define BR 2 /* break */ -#define CE 3 /* center */ -#define FI 4 /* fill */ -#define FO 5 /* footer title */ -#define HE 6 /* header title */ -#define IN 7 /* indent */ -#define LS 8 /* line spacing */ -#define NF 9 /* no fill */ -#define PL 10 /* page length */ -#define RM 11 /* right margin */ -#define SP 12 /* space by lines */ -#define TI 13 /* temporary indent */ -#define UL 14 /* underline */ - - -/* - array dimensions -*/ -#define MAXLINE 200 /* title buffer size */ -#define INSIZE 200 /* input buffer size */ -#define MAXOUT 200 /* output buffer size */ -#define PAGELEN 66 /* default page length */ -#define PAGEWIDTH 60 /* default page width */ - -/* - convienence definitions -*/ - - -#define HUGE 2000 -#define NOFILE -1 -#define EOFF -1 -#define YES 1 -#define NO 0 -#define COMMAND '.' - - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/MM.C b/software/CPM/CPM_MC_C1/MM.C deleted file mode 100644 index c4a0376..0000000 --- a/software/CPM/CPM_MC_C1/MM.C +++ /dev/null @@ -1,181 +0,0 @@ -/* - Mastermind game, written by: Stephen A. Ward, - January, 1980 - - Modified for BDS C by: Leor Zolman, - February, 1980 - - - Usage: mm [ -b ] [ -k ] [ -c# ] [ -p# ] - - where: -b tells # of possible solutions before each guess - -c# sets number of different characters (e.g., "-c4" means A-D) - (defaults to 6) - -p# sets number of positions in solution string - (defaults to 4) - -k disables kibitzing (enabled by default.). - - Thus, for example, the invokation - mm -c10 -p3 - would simulate the game of "Bagels", where the layout is ten different - characters in three positions. I don't think "Bagels" allows repetitions, - though, so it isn't QUITE the same... - -*/ - -#define NPEGS 10 /* Max NPeg */ -#define MCOLORS 26 /* Max NColors */ -#define NHIST 100 - -char Secret[NPEGS+2]; /* was CHAR */ -char History[NHIST*NPEGS]; /* was CHAR */ -int Jots[NHIST]; -int guesses; -int NColors, /* Number of colors */ - NPeg; /* Number of pegs */ - -char KFlag, /* Kibitz flag */ - BFlag; /* Debug flag */ - - - -main(argc, argv) - char **argv; - { - register int i,j; - int ngames,ntries; - ngames = ntries = 0; - char *trial, *arg; - NColors = 6; /* Number of colors */ - NPeg = 4; /* Number of pegs */ - KFlag = 1; /* Kibitz flag */ - BFlag = 0; /* Debug flag */ - - for (i=1; i MCOLORS) NColors = MCOLORS; - continue; - case 'P': NPeg = atoi(++arg); - if (NPeg > NPEGS) NPeg = NPEGS; - continue; - default: printf("Illegal option %s\n", - argv[i]); exit(-1); } - else - { printf("Usage: mm [ -b ] [ -k ] [ -c# ] [ -p# ]\n"); - exit(-1); }} - - printf("Mastermind game:\n"); - printf(" I have a secret string of %d letters ",NPeg); - printf("between A and %c.\n", 'A' + NColors - 1); - printf(" Object: find it in as few guesses as possible.\n"); - printf(" For each guess, I will tell you how many\n"); - printf(" Hits (right letter in the right place) and\n"); - printf(" Misses (right letter in the wrong place)\n"); - printf(" you had for that guess.\n"); - printf(" Note: letters may appear more than once in my strings.\n"); - - srand1("\nType any character to begin: "); - getchar(); - -Game: - for (i=0; i>4 ? "\t\t\t%d hit" : "\t\t\tno hit"), j>>4); - if ((j>>4) - 1) putchar('s'); - - printf ( (j & 0xf ? ", %d miss" : ", no miss"), j & 0xf); - if ((j & 0xf) - 1) printf("es"); - - putchar('\n'); - - if (j == (NPeg << 4)) - { printf("You got it in %d guesses!\n", ++guesses); - ntries += guesses; - ngames++; - i = ntries/ngames; - printf("Average for %d game%c is %1d.%1d\n", - ngames, (ngames != 1) ? 's' : 0x80, - i , ntries*100 /ngames %100); - goto Game; }} - Secret[NPeg] = 0; - printf("My secret symbol was "); - for (i=0; i 0) score++; } - return score; } - -int incr(tt) - char *tt; - { register int i; - i = 0; - while (i < NPeg) - { if (++tt[i] < NColors) return 1; - tt[i] = 0; i++; } - return 0; } - - -int Check() - { char tt[NPEGS]; - char *hh; - register int i, j; - int count; - count = 0; - for (i=0; i NPeg && !isspace(where[i])) { - printf("Too many letters\n"); goto again; - } - if (i < NPeg) { printf("Too few letters\n"); goto again; } - for (i=0; i= NColors) - { printf("Bad letter -- use A thru %c\n", 'A'+NColors-1); - goto again; } - } - return 1; -} - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/MYLIB.C b/software/CPM/CPM_MC_C1/MYLIB.C deleted file mode 100644 index ae8a2f7..0000000 --- a/software/CPM/CPM_MC_C1/MYLIB.C +++ /dev/null @@ -1,160 +0,0 @@ -/* - Searches the buffer at buff of length len - for character chr. Returns pointer to first - occurrence of chr in buff or NULL if chr is not - in buff. NOTE: This could be done with 1 CPIR - instruction in machine code. Write one. -*/ - -#include - -char *index(buff,len,chr) - char *buff,chr; - unsigned len; -{ - char *last; - - last = buff + len; /* sentinel beyond buffer */ - - while(*buff != chr) - if(++buff == last)return(NULL); - - return(buff); -} - - -/* - Searches buffer buff of length len for first character - which does not match character chr. Returns a pointer - to first such character or NULL if no such character - exists. -*/ - -char *nindex(buff,len,chr) - char *buff,chr; - unsigned len; -{ - char *last; - - last = buff + len; /* sentinel beyond buffer */ - - while(*buff == chr) - if(++buff == last)return(NULL); - - return(buff); -} - - -/* - Removes all occurrnces of character chr from the - buffer buff of length len, shrinking the buffer. - Returns the new buffer length. -*/ - -unsigned compress(buff,len,chr) - char *buff,chr; - unsigned len; -{ - char *tp1,*tp2; - unsigned tplen; - - /* first check if chr exists in buffer */ - - if((tp1 = index(buff,len,chr)) == NULL) - return(len); /* No, return original length */ - - /* find next non-chr character */ - /* if none exists, tp1 is boundary of new buffer */ - - if((tp2 = nindex(tp1,len-(tp1-buff),chr)) == NULL) - return(tp1-buff); - - /* close gap, recursively compressing the remainder */ - /* of buff from tp2 on. Isn't recursion neat? */ - - movmem(tp2,tp1,tplen=compress(tp2,len-(tp2-buff),chr)); - - return(tplen + (tp1 - buff)); -} - -/* - Reads nsec sectors from drive disk starting at - track trk, sector sctr to address buff. Returns - number of sectors successfully read. Note: Assumes - you have enough space at buff to hold everything. - If not, it will write over whatever else is beyond. - Use with caution. -*/ - -rdsecs(disk,trk,sctr,nsec,buff) -char disk,trk,sctr,*buff; -int nsec; -{ - int count; - count = 0; - bios(SELECT_DISK,disk); - while(nsec--){ - bios(SET_DMA,buff); - bios(SET_TRACK,trk); - bios(SET_SECTOR,sctr); - if(bios(READ_SECTOR) == 255) - return(count); - count++; - if(++sctr > 26){ - sctr = 1; - trk++; - } - if(trk > 76)return(count); - buff += SECSIZ; - } -} - - -/* - Writes nsec sectors to drive disk starting at - track trk, sector sctr from address buff. Returns - number of sectors successfully written. - Use with caution. -*/ - -wrtsecs(disk,trk,sctr,nsec,buff) -char disk,trk,sctr,*buff; -int nsec; -{ - int count; - count = 0; - bios(SELECT_DISK,disk); - while(nsec--){ - bios(SET_DMA,buff); - bios(SET_TRACK,trk); - bios(SET_SECTOR,sctr); - if(bios(WRITE_SECTOR) == 255) - return(count); - if(++sctr > 26){ - sctr = 1; - trk++; - } - if(trk > 76)return(count); - count++; - buff += SECSIZ; - } -} - -/* - Cursor positioning for the H19; gotoxy(x,y,c) where 1<=x<=25, - 1<=y<=80 and c is a string pointer. This function is also in - DEFF.CRL. NOTE: the 25th line must be separately enabled. - Also, no attempt is made to ensure that x and y are in the - proper range. -*/ - -gotoxy(line,column,string) - int line,column; - char *string; -{ - line--; column--; - puts("\033Y"); - putchar(line+0x20); putchar(column+0x20); - puts(string); -} - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/OTHELLO.C b/software/CPM/CPM_MC_C1/OTHELLO.C deleted file mode 100644 index 68b0a23..0000000 --- a/software/CPM/CPM_MC_C1/OTHELLO.C +++ /dev/null @@ -1,527 +0,0 @@ - -/* - - OTHELLO -- The Game of Dramatic Reversals - - written by Bert Halstead - modified for BDS C by Leor Zolman - -This program is a good example of: - - a) structured, heirarchical function organization - b) arrays as formal parameters - c) use of the "qsort" library function - - Object of the game is for two players to alternate -placing their marker someplace on an 8 by 8 grid, so that -at least one of the opponent's pieces becomes surrounded -by the moving player's peices -- causing the flanked pieces -to flip 'color' and belong to the moving player. After 60 -moves have been played (or if no player has a legal move left), -the player with the most of his own pieces on the board wins. - - The playing pieces are '*' and '@'. You may choose to play -either '*' or '@' for the first game; thereafter, you and the -computer will alternate going first for each game. Whoever -goes first always plays `*'. - - You enter a move as a two digit number, each digit being -from 1 to 8, first digit representing row and second representing -column. For example: if playing '*', your first move might be '46', -meaning 4th row down, 6th position across. - - As an alternative to entering a move, one of the following -commands may be typed: - - g causes computer to play both sides until game - is over - - a causes computer to print out an analysis of - each of your possible moves. A letter from A - to Z will appear at each of your legal move - positions, where A is the machine's opinion - of an excellant move and Z is a real loser. - - hn sets handicap. n is 1,2,3, or 4. If n is - positive, gives n free pieces to the computer. - If n is negative, gives YOU the free peices. - - f forfeit the current move. This happens - automatically if you have no legal moves. - - q quit the current game. - - b prints out board again. - - s prints out the score, and tells who is winning. - -*/ - - -#define BLACK '*' -#define WHITE '@' -#define EMPTY '-' - - -int handicap; -char selfplay; /* true if computer playing with itself */ -int h[4][2]; /* handicap position table */ -char mine, his; /* who has black (*) and white (@) in current game */ -char mefirst; /* true if computer goes first in current game */ - -main(argc,argv) -int argc; -char **argv; -{ - char b[8][8]; - int i; - h[0][0] = h[0][1] = h[2][0] = h[3][1] = 0; - h[1][0] = h[1][1] = h[2][1] = h[3][0] = 7; - printf("\nWelcome to the BDS C OTHELLO program!\n"); - printf("\nNote: `*' always goes first...Good luck!!!\n\n"); - - srand1("Do you want to go first? "); - if (toupper(getchar()) == 'Y') - mefirst = 0; - else - mefirst = 1; - - printf("\n\n"); - - do { - clrbrd(b); - prtbrd(b); - i = game(b,4); - mefirst = !mefirst; - if (i==4) break; - if (i=='Q') continue; - printf("\n"); - i = prtscr(b); - if (i>0) printf(" You won by %d\n",i); - else if (i<0) printf(" You lost by %d\n",-i); - else printf(" A draw\n"); - } while (ask("Another game? ")=='Y'); -} - -game(b,n) -char b[8][8]; -int n; -{ - char c; - int ff; - int i,j; - handicap = 0; - selfplay = ' '; - ff=0; - - if (mefirst) { - mine = BLACK; his = WHITE; - printf("\nI go first:\n\n"); - } - else { - mine = WHITE; his = BLACK; - printf("\nYou go first:\n\n"); - } - - while(1) { - if (cntbrd(b,EMPTY)==0) return 'D'; - if (cntbrd(b,EMPTY)==60 && mine == BLACK) goto Istart; - if (chkmvs(b,his)==0) { - printf(!mefirst ? "Forfeit" : " ...Forfeit\n"); - ff |= 1; - } - else switch (c = getmov(&i,&j)) { - case 'B': prtbrd(b); continue; - case 'S': i= prtscr(b); - if (i>0) printf(" You're winning\n"); - else if (i<0)printf(" You're losing!\n"); - else putchar('\n'); - continue; - case 'Q': case 4: return c; - - case 'H': if (n>abs(handicap)+4) - printf("Illegal!\n"); - else for (j=0; i!=0; j++) { - b[h[j][0]][h[j][1]]= i>0?BLACK:WHITE; - handicap += i>0 ? 1 : -1; - ++n; - i += i>0 ? -1 : 1; - } - prtbrd(b); continue; - case 'A': analyze(b,his,mine,EMPTY); - continue; - case 'G': my_mov(b,his,mine,EMPTY,&i,&j); - case 'M': if (chkmov(b,his,i,j)>0) { - printf(!mefirst ? "%1d-%1d" : " ...%1d-%1d\n", - i+1,j+1); - putmov(b,his,i,j); - } - else { - printf("Illegal!\n"); - continue; - } - break; - case 'F': if (n>abs(handicap)+4) { - printf ("Illegal!\n"); - continue; - } - else printf(!mefirst ? "Forfeit" : - " ...Forfeit\n"); - } -Istart: if (cntbrd(b,EMPTY) == 0) return 'D'; - if (chkmvs(b,mine)==0) { - printf(!mefirst ? "...Forfeit\n": "Forfeit...\n"); - ff |=2; - } - else { - my_mov(b,mine,his,EMPTY,&i,&j); - printf(!mefirst ? "...%1d-%1d\n" : "%1d-%1d...\n", - i+1,j+1); - putmov(b,mine,i,j); - ++n; - } - if (ff==3 || n>64) return 'D'; - if (!(ff & 1)) prtbrd(b); - ff = 0; - } -} - - -prtscr(b) -char *b; -{ - int i,j; - printf("%1d-%1d",i = cntbrd(b,his), j=cntbrd(b,mine)); - return i-j; -} - -char getmov(i,j) -int *i, *j; -{ - char a,c; - int n; - char *p; - char skipbl(); - if (selfplay == 'G') { - if (!kbhit()) return 'G'; - selfplay = ' '; - getchar(); - } - printf("Move: "); - while(1) switch (c=skipbl()) { - case '\n': printf("Move? "); continue; - case 'G': if ((c = skipbl()) != '\n') - goto flush; - selfplay='G'; - return 'G'; - case 'B': case 'S': case 'Q': - case 'F': case 'A': - a=c; - if (( c = skipbl()) != '\n') goto flush; - return a; - case 'H': if ((a=c=skipbl()) == EMPTY) - c=getchar(); - if (c<'1' || c>'4' || skipbl() !='\n') - goto flush; - *i = a==EMPTY? -(c-'0') : (c-'0'); - return 'H'; - case 4: return c; - default: if (c<'1' || c>'8') goto flush; - *i = c-'1'; - c = skipbl(); - if (c<'1' || c>'8') goto flush; - *j = c- '1'; - if ((c=skipbl()) == '\n') return 'M'; - flush: while (c != '\n' && c != 4) - c=getchar(); - if (c==4) return c; - printf ("Huh?? "); - } -} - -char ask(s) -char *s; -{ - char a,c; - printf ("%s ",s); - a=skipbl(); - while (c != '\n' && c != 4) c= getchar(); - return a; -} - -char skipbl() -{ - char c; - while ((c = toupper(getchar())) == ' ' || c=='\t'); - return c; -} - - - -chkmvs(b,p) -char b[8][8]; -char p; -{ - int i,j,k; - k=0; - for (i=0; i<8; i++) for (j=0; j<8; j++) - k += chkmov(b,p,i,j); - return k; -} - - -chkmov(b,p,x,y) -char b[8][8],p; -int x,y; -{ - if (b[x][y] != EMPTY) return 0; - return chkmv1(b,p,x,y,0,1) + chkmv1(b,p,x,y,1,0) + - chkmv1(b,p,x,y,0,-1)+ chkmv1(b,p,x,y,-1,0)+ - chkmv1(b,p,x,y,1,1) + chkmv1(b,p,x,y,1,-1)+ - chkmv1(b,p,x,y,-1,1)+ chkmv1(b,p,x,y,-1,-1); -} - - -chkmv1(b,p,x,y,m,n) -char b[8][8],p; -int x,y,m,n; -{ - int k; - k=0; - while ((x += m) >= 0 && x < 8 && (y += n) >= 0 && y<8) - { - if (b[x][y]==EMPTY) return 0; - if (b[x][y]== p ) return k; - if (x==0 || x==7 || y==0 || y==7) - k += 10; - else k++; - } - return 0; -} - - -notake(b,p,o,e,x,y) -char b[8][8]; -char p,o,e; -int x,y; -{ - return notak1(b,p,o,e,x,y,0,1)&& - notak1(b,p,o,e,x,y,1,1)&& - notak1(b,p,o,e,x,y,1,0)&& - notak1(b,p,o,e,x,y,1,-1); -} - - -notak1(b,p,o,e,x,y,m,n) -char b[8][8],p,o,e; -int x,y,m,n; -{ - int c1,c2; - c1 = notak2(b,p,o,e,x,y,m,n); - c2 = notak2(b,p,o,e,x,y,-m,-n); - return !(c1==o && c2==e || c1==e && c2==o); -} - - -notak2(b,p,o,e,x,y,m,n) -char b[8][8],p,o,e; -int x,y,m,n; -{ - x += m; y +=n; - if (x>=0 && x<=7 && y>=0 && y<=7) - while(b[x][y] == 0) { - x += m; y+=n; - if (x<0 || x>7 || y<0 || y>7 || b[x][y]==e) - return o; - } - while (x>=0 && x<=7 && y>=0 && y<=7 && b[x][y]==p) - { x +=m; y+=n; } - if (x<0 || x>7 || y<0 || y>7) return p; - return b[x][y]; -} - - -putmov(b,p,x,y) -char b[8][8]; -char p; -int x,y; -{ - int i,j; - b[x][y] = p; - for (i= -1; i<=1; i++) for (j= -1; j<=1; j++) { - if ((i != 0 || j!=0)&&chkmv1(b,p,x,y,i,j)>0) - putmv1(b,p,x,y,i,j); - } -} - - -putmv1(b,p,x,y,m,n) -char b[8][8]; -char p; -int x,y,m,n; -{ - while ((x += m) >= 0 && x<8 && (y += n)>=0 && y<8) { - if (b[x][y] == EMPTY || b[x][y] == p) return; - b[x][y] = p; - } -} - - -struct mt { - int x; - int y; - int c; - int s; - }; - -my_mov(b,p,o,e,m,n) -char b[8][8],p; -int *m, *n; -{ - struct mt t[64]; - int i,k; - int cmpmov(); - k = fillmt(b,p,o,e,t); - if (!k) return 0; - qsort (&t, k, 8, &cmpmov); - for (i=1; i=10) { s -= 4; oside |= 8; } - } - if (s< -oside) s= -oside; - if (side>0) return s+side-7+10*ok; - if (i==1 || i==6) {s--; side++;} - if (j==1 || j==6) {s--; side++;} - if (side>0) return s; - if (i==2 || i==5) s++; - if (j==2 || j==5) s++; - return s; -} - -cmpmov(a,b) -struct mt *a, *b; -{ - if ((*a).s > (*b).s) return -1; - if ((*a).s < (*b).s) return 1; - if ((*a).c > (*b).c) return -1; - if ((*a).c < (*b).c) return 1; - return 0; -} - - - -clrbrd(b) -char b[8][8]; -{ - int i,j; - for (i=0; i<8; i++) - for (j=0; j<8; j++) - b[i][j]= EMPTY; - b[3][3] = b[4][4] = BLACK; - b[3][4] = b[4][3] = WHITE; -} - - -prtbrd(b) -char b[8][8]; -{ - int i,j; - printf(" 1 2 3 4 5 6 7 8\n"); - for (i=0; i<8; i++) { - printf("%2d",i+1); - for (j=0; j<8; j++) { - putchar(' '); - putchar(b[i][j]); - } - putchar('\n'); - } - putchar('\n'); -} - - -cpybrd(a,b) -char *a, *b; -{ - int i; - i=64; - while (i--) - *a++ = *b++; -} - -cntbrd(b,p) -char *b, p; -{ - int i,j; - i= 64; j=0; - while (i--) - if (*b++ == p) ++j; - return (j); -} - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/P.C b/software/CPM/CPM_MC_C1/P.C deleted file mode 100644 index 08380c5..0000000 --- a/software/CPM/CPM_MC_C1/P.C +++ /dev/null @@ -1,66 +0,0 @@ - -/* - This program is used with the H19 hold screen mode - to print out files in the same manner as the CP/M - TYPE command, but with SCROLL key control. - - Usage: - A>p filename.ext - - - Note: This program assumes that the H19 is not - normally in HOLD SCREEN mode, and turns it - off when through. - - Dann Lunsford, 22 October, 1980 -*/ - -#include "bdscio.h" - -#define X_OFF 0x13 -#define X_ON 0x11 - -char stopf; - -main(argc,argv) -int argc; -char **argv; -{ - int fd; - char buf[BUFSIZ]; - char linebuf[135]; - - if (argc != 2) { - puts("Usage: p filename\n"); - exit(); - } - - if ((fd = fopen(argv[1], buf)) == ERROR) { - puts("Can't open file "); - puts(argv[1]); - putchar('\n'); - exit(); - } - - puts(CLEARS); /* Clear screen so page fills immediately */ - puts("\033x3"); /* Enter hold screen mode */ - stopf = 0; - - whilå (fgets(linebuf,buf© && !stopf) - puts(linebuf); - - puts("\033y3"); /* Turn off HOLD SCREEN mode */ -} - -putchar(c) -char c; -{ - if(c=='\n')bios(CONOUT,'\r'); - bios(CONOUT,c); - if(bios(CONST)){ - if(bios(CONIN) == X_OFF) - while(bios(CONIN) != X_ON); - else stopf = 1; - } -} - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/PNUM.C b/software/CPM/CPM_MC_C1/PNUM.C deleted file mode 100644 index 27a5808..0000000 --- a/software/CPM/CPM_MC_C1/PNUM.C +++ /dev/null @@ -1,40 +0,0 @@ - -/* - This command prints out a given file with line - numbers. Usage: - - A>pnum filename - - written by Leor Zolman - Jan, 1980 - - The last statement of this program is a hint - as to the kind of power C can provide... -*/ - -#include "bdscio.h" - -main(argc,argv) -char **argv; -{ - int fd, lnum; - char buf[BUFSIZ]; - char linebuf[135]; - - if (argc != 2) { - printf("Usage: pnum filename\n"); - exit(); - } - - if ((fd = fopen(argv[1], buf)) == ERROR) { - printf("cannot open: %s\n",argv[1]); - exit(); - } - - lnum = 1; - - while (fgets(linebuf,buf)) - printf("%4d: %s", lnum++, linebuf); -} - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/PPONG.C b/software/CPM/CPM_MC_C1/PPONG.C deleted file mode 100644 index 2340498..0000000 --- a/software/CPM/CPM_MC_C1/PPONG.C +++ /dev/null @@ -1,263 +0,0 @@ -/* - Polish Pong game for H19/H89, RHH (Robert H. Halstead) August 1980: - - Object is to guide the little ball around the screen by setting up - and removing blockade sections. All control is via the keypad; "4" - and "6" cause blockades to be formed at the current position of the - roving ball, while pressing "5" at the exact moment the ball hits a - blockade should make that blockade disappear. Oh yes, and the POINT - of all this is to make the ball hit the little square target--once - this is done, the square will disappear and reappear somewhere else, - to be hit again. Go for hitting the target the specified number of - times AS QUICKLY AS POSSIBLE. Your score is how many seconds you - took; the lower the better. - Keys "8" and "2" speed up and slow down the ball; as you get better, - try it at a faster speed! -*/ - -#include "bdscio.h" - -#define MAXX 78 /* horizontal size of board */ -#define MAXY 23 /* vertical size */ -#define MAXTARG 20 /* # of targets per game */ -#define ISPEED 400 /* initial ball speed */ -#define SPEEDINC 100 /* increments/decrements in ball speed */ - -#define TIMX 50 /* locations of status strings */ -#define TIMY 23 -#define TARGX 30 -#define TARGY 23 -#define SPEEDX 10 -#define SPEEDY 23 -#define BESTX 70 -#define BESTY 23 - -#define CONINF 1 /* console input FDOS function */ - -#define MSPS 960 /* "millisecs" per second */ - -#define QUITCH 3 /* ^C quits the program */ -#define DELETE 0177 /* DELETE restarts the game */ - -#define XOFF ('S'&037) /* flow control chars */ -#define XON ('Q'&037) - -#define EGRAPH "\033F" /* H19 escape sequences */ -#define XGRAPH "\033G" -#define REGKPM "\033u\033>" - -#define VBAR '`' /* H19 alternate graphic chars */ -#define HBAR 'a' -#define SLASH 'x' -#define BSLASH 'y' -#define BALL '^' -#define TARGET 'i' - -char board[MAXX][MAXY]; /* board with current layout */ - -int ballx,bally,ballxv,ballyv; /* state of ball */ -int Speed,Dist; /* speed of ball */ -int TargLeft; /* number of targets left */ -int MSecs,Secs; /* bookkeeping for time elapsed */ -int NewTime; /* nonzero if time has changed */ -int Best; /* best score so far */ -int InChar; /* character read from input */ - -putchx(c) - int c; - { if (++MSecs >= MSPS) - { MSecs = 0; Secs++; - NewTime = 1; - } - Dist += Speed; - if (bios(2)) - { InChar = bios(3) & 0177; - if (InChar == QUITCH) - { InChar = -1; - outs(0,MAXY-1,XGRAPH); - prints(CURSORON); - exit(0); - } - if (InChar == XOFF) - { while (InChar != XON) - { while (!bios(2)); - InChar = bios(3) & 0177; - } - InChar = -1; - } - } - bios(4,c); - if (c == '\n') putchx('\r'); - } - -/* -int getch() /* get a char from console, no echo */ - { int c; - c = inp(CDATA); - return(c); - } -*/ - -prints(s) /* put out a string */ - char *s; - { int c; - while (c = *s++) putchx(c); - } - -puts(s) /* same as prints, but "srand1" needs it */ - char *s; - { - prints(s); - } - -ouch(ch,x,y) /* put character at position */ - int ch,x,y; - { - putchx(ESC); putchx('Y'); putchx(y+32); putchx(x+32); putchx(ch); - } - -outs(x,y,s) /* put string at position (x,y) */ - int x,y; - char *s; - { - putchx(ESC); putchx('Y'); putchx(y+32); putchx(x+32); - prints(s); - } - -puttarg() - { char buff[100]; - sprintf(buff,"\033p%2d\033q",TargLeft); - outs(TARGX,TARGY,buff); - } - -puttime() - { char buff[100]; - sprintf(buff,"\033p%3d\033q",Secs); - outs(TIMX,TIMY,buff); - } - -putspeed() - { char buff[100]; - sprintf(buff,"\033p%3d\033q",Speed/10); - outs(SPEEDX,SPEEDY,buff); - } - - int moveball() - { int i,nx,ny; - Dist = 0; - i = InChar; - if (i > 0) - { InChar = -1; - switch (i) - { case '4': /* lay down backslash */ - if (board[ballx][bally] == ' ') - board[ballx][bally] = BSLASH; - else putchx(7); - break; - - case '6': /* lay down slash */ - if (board[ballx][bally] == ' ') - board[ballx][bally] = SLASH; - else putchx(7); - break; - - case '5': /* delete current char */ - i = board[ballx][bally]; - if (i == SLASH || i == BSLASH) board[ballx][bally] = ' '; - else putchx(7); - break; - - case '8': /* go faster */ - if (Speed < 1000) { Speed += SPEEDINC; putspeed(); } - break; - - case '2': /* go slower */ - if (Speed > SPEEDINC+50) { Speed -= SPEEDINC; putspeed(); } - break; - - case DELETE: /* start a new game */ - return(0); - - default: - putchx(7); break; - } - } - switch (board[ballx][bally]) - { case ' ': break; - case VBAR: ballxv = -ballxv; break; - case HBAR: ballyv = -ballyv; break; - case BSLASH: i = ballxv; ballxv = ballyv; ballyv = i; break; - case SLASH: i = ballxv; ballxv = -ballyv; ballyv = -i; break; - case TARGET: - if (--TargLeft <= 0) return(0); - puttarg(); - board[ballx][bally] = ' '; - do { nx = rand()%(MAXX-2) + 1; - ny = rand()%(MAXY-2) + 1; - } while (board[nx][ny] != ' '); - board[nx][ny] = TARGET; - ouch(TARGET,nx,ny); - break; - } - nx = ballx + ballxv; - ny = bally + ballyv; - ouch(BALL,nx,ny); - ouch(board[ballx][bally],ballx,bally); - if (NewTime) { puttime(); NewTime = 0; } - ballx = nx; bally = ny; - while (Dist < (ballyv?22000:10000)) putchx(1); - /* further delay to slow ball down */ - return(1); - } - -main() - { puts("Welcome to Polish Pong!\n"); sleep(10); - Best = 32767; - Speed = ISPEED; /* governs how fast ball moves */ - while (playgame()); - } - -int playgame() - { int i,j; - char buff[100]; /* temp */ - InChar = -1; /* initially, no char typed in */ - srand1("\033H\033GType any key to start game: \033K"); - if (bdos(1) == QUITCH) /* clear the input character */ - exit(); /* and quit on control-C */ - InChar = -1; /* clear space out of input buffer */ - ballx = rand()%(MAXX-2) + 1; - bally = rand()%(MAXY-2) + 1; - ballxv = ballyv = 0; - i = (rand()&2) - 1; - if (rand()&1) ballxv = i; else ballyv = i; - for (i = 0; i < MAXX; i++) for (j = 0; j < MAXY; j++) board[i][j] = ' '; - for (i = 0; i < MAXX; i++) board[i][0] = board[i][MAXY-1] = HBAR; - for (i = 0; i < MAXY; i++) board[0][i] = board[MAXX-1][i] = VBAR; - board[0][0] = 'f'; /* special corner pieces */ - board[0][MAXY-1] = 'e'; - board[MAXX-1][0] = 'c'; - board[MAXX-1][MAXY-1] = 'd'; - board[rand()%(MAXX-2)+1][rand()%(MAXY-2)+1] = TARGET; - /* place initial target */ - TargLeft = MAXTARG; /* start with full complement of targets */ - prints(REGKPM); prints(CLEARS); prints(EGRAPH); prints(CURSOROFF); - for (j = 0; j < MAXY; j++) - { for (i = 0; i < MAXX; i++) putchx(board[i][j]); - putchx('\n'); - } - outs(TIMX-11,TIMY,"\033G\033pTime Used: "); - outs(TARGX-14,TARGY,"Targets Left: "); - if (Best < 32767) - { sprintf(buff,"Best Time: %3d",Best); - outs(BESTX-11,BESTY,buff); - } - outs(SPEEDX-7,SPEEDY,"Speed: \033F\033q"); - putspeed(); - puttarg(); - MSecs = Secs = 0; puttime(); - ouch(BALL,ballx,bally); - while (moveball()); - if (TargLeft == 0 && Secs < Best) Best = Secs; - return(1); - } - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/PPS.DOC b/software/CPM/CPM_MC_C1/PPS.DOC deleted file mode 100644 index 31fff30..0000000 --- a/software/CPM/CPM_MC_C1/PPS.DOC +++ /dev/null @@ -1,23 +0,0 @@ -.sp 2 -x. Changes to PPS -.sp -Change and locate text strings can be 40 characters long. -.sp -Program space (vector pr) has dimension 5000. -.sp -The line buffer (vector ln) has dimension 120. -.sp -Typing a carriage return after the prompter > causes the next -line to become current. -I.e. an empty line is equivalent to +1. -(Before, an empty line was ignored.) -.sp -A new command, .dir, prints the directory, or portions -of it. -.sp -The + and - commands are recoded, the former for compactness -and regularity, and the latter for speed. -.sp -The .w command requires a filename, and will give a diagnostic -if there is none. - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/PPS.TC b/software/CPM/CPM_MC_C1/PPS.TC deleted file mode 100644 index 96a85ae..0000000 Binary files a/software/CPM/CPM_MC_C1/PPS.TC and /dev/null differ diff --git a/software/CPM/CPM_MC_C1/PPSLF.TC b/software/CPM/CPM_MC_C1/PPSLF.TC deleted file mode 100644 index 90ddd13..0000000 Binary files a/software/CPM/CPM_MC_C1/PPSLF.TC and /dev/null differ diff --git a/software/CPM/CPM_MC_C1/PRESSUP.C b/software/CPM/CPM_MC_C1/PRESSUP.C deleted file mode 100644 index 7f5a814..0000000 --- a/software/CPM/CPM_MC_C1/PRESSUP.C +++ /dev/null @@ -1,341 +0,0 @@ - - -/* Press-up game... - pressup - where may include - -f Machine goes first - -d n Search depth is n moves (default 3) - (greater search depths take longer...but - play better!!) - -b Print machine's evaluation of its moves. - - THIS PROGRAM WILL ONLY WORK ON TERMINALS HAVING - LOWER CASE CHARACTERS!!!!!!!!!!!!!!!!!!!!!!!!!! - - This excellant program was written by: - Prof. Steve Ward - Director, Real-Time Systems Group - MIT Lab for Computer Science - Cambridge, Massachussetts, 02139 - - (slightly modified by Leor Zolman) - - The game of Press-Ups is played as follows: - The board is a n by n array of pegs, each of - which is standing up at the start of the game. Pegs - come in 3 colors: Red (yours), Blue (the machine's), - and white (periods, actually; they're neutral.) - - The first player to move must "push down" a neutral - peg. Thereafter, players take turns pushing down pegs, - where each peg pushed must be adjacent to the last one - pushed. - - Pegs are named by giving a letter and a number, for the - row and column of the desired peg. - - As soon as a player gets all of his pegs down, he wins. - When there are no more legal moves to play, - the player with the most of his own colored pegs down - is the winner. - - Watch out...at search depths of 6 or more, this program - plays a mean game!!! -*/ - -#define SIDE 7 /* Dimension of board */ - -#define HISFIRST (SIDE*2+1) /* His best first move */ -#define MYFIRST (SIDE+SIDE/2-1) /* My best first move */ -#define BELL 0x07 -#define BACKSP 0x08 -int Depth; /* Search depth (default = 3) */ -int Helpflag; -char FFlag, /* -f option: machine goes first */ - BFlag; /* Debugging flag */ -char Startflag; /* True on first move only */ - -char *image; -int Adj[16]; - -int BestMove; /* Returned by search */ - -#define BBOARD struct bord - -struct bord - { char board[SIDE*SIDE]; - int star; - char red; - char blue; - }; - -BBOARD initb; - -BBOARD master, savebd; - -char string[20]; - -CheckWin(bp) - BBOARD *bp; - { int i; - i = search(bp,1,1,-32000,-32000); - if (BestMove >= 0) return 0; - - if (i>0) printf("I win!\n"); - if (i<0) printf("You win!\n"); - if (i==0) printf("Tie game!\n"); - return 1; - } - -asknew() -{ - printf("\nAnother game? "); - if (toupper(getchar()) != 'Y') exit(); - printf("\n"); -} - -main(argc,argv) - char **argv; - { int i,j; char *arg; - FFlag = BFlag = 0; - image = ".rbXRB"; - initw(Adj,"-1,-1,-1,0,-1,1,0,-1,0,1,1,-1,1,0,1,1"); - - Depth = 3; - for (i=1; i 500) printf("I've got you!\n"); - if (i < -500) printf("You've got me!\n"); - - } - } - - -pboard(bp) -BBOARD *bp; - { int i, j, n; - char letter; - letter = 'A'; - printf("\n\n "); - for (i=0; i star) printf(" * "); - else printf(" %c ",image[bp->board[n]]); } - printf("| %c",letter++); - - if (i==0) printf("\tSearch Depth: %1d moves", - Depth); - if (i==2) printf("\tScore:\tBlue(me) Red(you)"); - if (i==3) printf("\t\t %1d %1d", - master.blue, master.red); - if (i==5) { - if (Helpflag) - printf("\tYou've had help!"); - if (Startflag) - printf(FFlag?"\tI go first" - :"\tYou go first"); - Startflag = 0; - } - printf("\n"); - } - printf(" "); for (i=0; i<(2+3*SIDE); i++) printf("-"); printf("\n"); - printf(" "); - for (i=0; iboard[i] = p1->board[i]; - while(i--); - p2->star = p1->star; - p2->red = p1->red; - p2->blue = p1->blue; - } - - -/* display move #n */ - -dmove(n) - { - move(&master,n); - pboard(&master); - bcopy(&master,&savebd); - } - -move(bp,n) -BBOARD *bp; - { int type; - type = bp->board[n] += 3; - if (type == 4) bp->red++; - else if (type == 5) bp->blue++; - bp->star = n; - } - -search (bp,ddepth,who,alpha,beta) -BBOARD *bp; - { BBOARD new; - int i,j,k; - int myalpha,hisalpha,result,status; - int best; - int num; - int bestmove, ii, jj, n; - int SavStar; - int SavBlue; - int SavRed; - int Save; - char moves[9]; - status = -1; - best = -32000; - num = 0; - SavStar = bp -> star; - SavBlue = bp -> blue; - SavRed = bp -> red; - BestMove = -1; /* No best move yet... */ - - if (SavStar == -1) /* special case opening moves */ - { BestMove = HISFIRST; - if (who > 0) BestMove = MYFIRST; - return 0; }; - - if (!ddepth--) - return(who * (bp->blue - bp->red)); - if (bp->blue == (SIDE*2-4) || bp->red == (SIDE*2-4)) - return(who*(bp->blue - bp->red)*1000); - - /* alpha-beta pruning */ - if (who>0) { myalpha = bp->blue; hisalpha = bp->red; } - else { myalpha = bp->red; hisalpha = bp->blue; } - myalpha += ddepth; /* Most optimistic estimate. */ - if (myalpha > (SIDE*2-4)) myalpha = (SIDE*2-4); - if (myalpha == (SIDE*2-4)) myalpha = 1000*(myalpha-hisalpha); - else myalpha -= hisalpha; - if (myalpha <= alpha) return best; - - k = bp->star; - i = k%SIDE; - j = k/SIDE; - for (n=0; n<8; n++) - { - if ((ii = i+Adj[n+n]) < 0 || ii >= SIDE) continue; - if ((jj = j+Adj[n+n+1]) < 0 || jj >= SIDE) continue; - if (bp->board[moves[num] = jj*SIDE + ii] < 3) num++; } - if (num == 0) return(who*(bp->blue - bp->red)*1000); - bestmove = moves[0]; - for (i=0; iboard[moves[i]]; move(bp,moves[i]); - k = -search(bp,ddepth,-who,beta,alpha); - bp->board[moves[i]] = Save; - bp->blue = SavBlue; bp->red = SavRed; bp->star = SavStar; - if (k > alpha) alpha = k; - if (k > best) { best = k; bestmove = moves[i]; } - if (k>100) break; } - BestMove = bestmove; - return best; } - - - -Help() - { printf("I'm thinking for you...\n"); - Helpflag = 1; - search(&master,Depth,-1,-32000,-32000); - return BestMove; } - -getmove() - { int row, col, n; - int dc, dr; - int star2; - star2 = master.star; -loop: printf("\nYour move (z for help; p for board): "); -getrow: for (;;) { - if ((row = toupper(getchar()) ) == 'Z') { - printf("\n"); - return Help(); - } - - if (row == 'Q') return row; - if (row == 'P') { - pboard(&master); - goto loop; - } - if (row == 0177 || row == '\n') goto err; - if (row<'A' || row> ('A'+SIDE-1)) - putchar(BACKSP); - else break; - } - row -= 'A'; - - for (;;) { - col = toupper(getchar()); - if (col == 0177) { - putchar(BACKSP); - goto getrow; - } - if (col == '\n' || col == '\b') goto err; - if (col < '1' || col > ('0'+SIDE)) - putchar(BACKSP); - else break; - } - - col -= '1'; - n = row*SIDE + col; - dr = abs(row - star2/SIDE); - dc = abs(col - star2%SIDE); - - if ((star2 < 0 && master.board[n] == 0) || - (dr < 2 && dc < 2 && master.board[n] < 3)) - return(n); - - err: putchar(BELL); - printf(" Illegal! "); - goto loop; - } - - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/QUEUE.C b/software/CPM/CPM_MC_C1/QUEUE.C deleted file mode 100644 index d8eaf5d..0000000 --- a/software/CPM/CPM_MC_C1/QUEUE.C +++ /dev/null @@ -1,216 +0,0 @@ -/* FIFO queue package - (W) Copywrong 1980 Scott W. Layson - -These cute little routines implement First In, First Out queues. There -are complete sets of routines provided: one to handle integer-sized -(2-byte) objects, and the other to handle byte-sized things. - -The routines are good for applications such as I/O buffering in programs -that do several things at once. For example, consider the following -program fragment (remember that all this text is one big comment!): - -#define KBD_Q_SIZE 40 - -struct cqueue { - char *cruft[4], space[KBD_Q_SIZE]; - } kbd_q; - -/ * This program eats command characters and does something hairy with them * / - -main() -{ - <... assorted declarations ...> - CQInit (&kbd_q, KBD_Q_SIZE); - while (1) do - { cmd = get_qd_char(); - hairily_process (cmd); - } -} - -/ * Return a character off the queue if there are any, otherwise wait - for one to be typed * / - -get_qd_char() -{ - if (!CQEmpty(&kbd_q) - return CQGrab(&kbd_q); - else return getchar(); -} - -/ * If a character has been typed, queue it * / - -kbd_check() -{ - if (kbhit()) - CQShove (getchar(), &kbd_q); -} - - -Careful scattering of calls to kbd_check throughout hairily_process() -will prevent keyboard characters from being missed no matter how far -the user types ahead (up to the KBD_Q_SIZE, of course). - -Small misfeature: the queue will actually hold one fewer object than -the size allocated for it. E.g., the above kbd_q will hold -(KBD_Q_SIZE - 1) characters. This usually doesn't matter, as usual -practice is just to make a queue much larger than it really has to be -anyway. - -************** End of comments **********************************/ - - -struct queue { - int *head, *tail, *top, *bottom, space; - }; - - -/* Initialization routine (must be called before any operation is done - on the queue) */ - -QInit(queue_p,size) -struct queue *queue_p; -int size; -{ - queue_p->head = queue_p->tail = queue_p->top = &(queue_p->space); - queue_p->bottom = queue_p->top +size -1; -} - - -/* Routine to grab something off the head of a queue - Does no error checking! Be careful of underflow! */ - -QGrab(queue_p) -struct queue *queue_p; -{ - return ((queue_p->head >= queue_p->bottom) ? - *(queue_p->head = queue_p->top) : - *++(queue_p->head)); -} - - -/* Routine to shove something onto the tail of a queue - Does no error checking! BE careful of underflow! */ - -QShove(x,queue_p) -struct queue *queue_p; -int x; -{ - *((queue_p->tail >= queue_p->bottom) ? - (queue_p->tail = queue_p->top) : - ++(queue_p->tail)) = x; -} - - -/* Emptiness predicate */ - -QEmpty(queue_p) -struct queue *queue_p; -{ - return (queue_p->head == queue_p->tail); -} - - -/* Fullness predicate */ - -QFull(queue_p) -struct queue *queue_p; -{ - return((queue_p->tail+1 == queue_p->head) || - (queue_p->tail == queue_p->bottom && - queue_p->head == queue_p->top)); -} - - -/* Peek at head of queue without disturbing it */ - -QPeek(queue_p) -struct queue *queue_p; -{ - return ( (queue_p->head == queue_p->bottom) ? - *queue_p->top : - *(queue_p->head + 1) ); -} - - - - - - -/* Here is the same repertoire of routines, but set up for - characters instead of integers: -*/ - - -struct cqueue { - char *chead, *ctail, *ctop, *cbottom, cspace; - }; - - -/* Initialization routine (must be called before any operation done - on the queue) */ - -CQInit(queue_p,size) -struct cqueue *queue_p; -int size; -{ - queue_p->chead = queue_p->ctail = queue_p->ctop = &(queue_p->cspace); - queue_p->cbottom = queue_p->ctop +size -1; -} - - -/* Routine to grab something off the head of a queue -Does no error checking! Be careful of underflow! */ - -CQGrab(queue_p) -struct cqueue *queue_p; -{ - return ((queue_p->chead >= queue_p->cbottom) ? - *(queue_p->chead = queue_p->ctop) : - *++(queue_p->chead)); -} - - -/* Routine to shove something onto the tail of a queue - Does no error checking! Be careful of overflow! */ - -CQShove(x,queue_p) -struct cqueue *queue_p; -int x; -{ - *((queue_p->ctail >= queue_p->cbottom) ? - (queue_p->ctail = queue_p->ctop) : - ++(queue_p->ctail)) = x; -} - - -/* Emptiness predicate */ - -CQEmpty(queue_p) -struct cqueue *queue_p; -{ - return (queue_p->chead == queue_p->ctail); -} - - -/* Fullness predicate */ - -CQFull(queue_p) -struct cqueue *queue_p; -{ - return((queue_p->ctail+1 == queue_p->chead) || - (queue_p->ctail == queue_p->cbottom && - queue_p->chead == queue_p->ctop)); -} - - -/* Peek at head of queue without disturbing it */ - -CQPeek(queue_p) -struct cqueue *queue_p; -{ - return ( (queue_p->chead == queue_p->cbottom) ? - *queue_p->ctop : - queue_p->chead[1] ); -} - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/R2.MAP b/software/CPM/CPM_MC_C1/R2.MAP deleted file mode 100644 index 1d1aa76..0000000 Binary files a/software/CPM/CPM_MC_C1/R2.MAP and /dev/null differ diff --git a/software/CPM/CPM_MC_C1/RALLY.C b/software/CPM/CPM_MC_C1/RALLY.C deleted file mode 100644 index bec5ca8..0000000 --- a/software/CPM/CPM_MC_C1/RALLY.C +++ /dev/null @@ -1,411 +0,0 @@ -/* - H19 RALLY Game, 5/80 Steve Ward - - Works ONLY on Heathkit/Zenith H19/Z19 terminal - (or H89 computer) - - Command format: - - A>rally [-rn] [-b] [mapname] - - where: "n" is an optional seed for the random number generator - (results in exactly the same minor track deviations each - time it is given with a particular track); - If "n" is omitted, then track deviations are totally - random for each session (but same for each run in any - single session.) - - "-b" is a debugging option doing Steve-knows-what. - - "mapname" specifies the map file to use for the track - (defaults to "rally.map"). -*/ - - -#include "bdscio.h" /* Get std console parameters */ - -#define CARY 16 /* Y position of car. */ -#define IBAD 0 -#define LSPEED 7 /* Line 25 label posns */ -#define LMILES 20 -#define MAXSPD 9 -#define SPDSCL 128 -#define TENTHS 10 /* Number of lines per mile. */ -#define TICMIN 1920 /* Number of tics per minute. */ - -char Free[10000], *Freep; - -char CRTFrz, CRTChr; -int Miles; -char Pavement, Freeze, BFlag; -char CurX, CurY, SignY; -int CarX, CarDX; -char RevFlg, AltFlg; -int Speed, Tenths; -char Image[CARY*80+80]; -char *ImPtr, *ImEnd; -int Seed; -int Ranno; -char InBuf[BUFSIZ], SavChr; -int SpTime[MAXSPD+1]; - -struct Road { - struct Node *Next; - char active; - char Token; - int Windy; - int Curvy; - int Age; - int ToGo; - char Holes; - char X; - char dx; - char width; } Road1, Road2; - -struct Sign { - struct Node *Next; - char key; - char text[0]; }; - -struct Fork { - struct Node *Next; - char key; - char *Branch; }; - -struct Dist { - struct Node *Next; - char key; - char wid, curve, wind; - int miles; }; - -union Node { - struct Dist; - struct Fork; - struct Sign; } *Tag[128]; - - -/* - Write a character to the terminal, handling X-ON/X-OFF - protocol and not going into a busy loop if the terminal - isn't ready to send a character, but rather just returning - in that case to let the caller do more crunching and try - again later. -*/ - -putchar(c) - { char stat, ch; - for(;;) - { if ((CIMASK & (stat = inp(CSTAT))) == (CAHI ? CIMASK : 0)) - switch(ch = (0177 & inp(CDATA))) { - case 'S'-64: CRTFrz=1; break; - case 'Q'-64: CRTFrz=0; break; - case 'C'-64: puts("\033z"); exit(); - default: CRTChr=ch; } - if (CRTFrz) continue; - if ((stat & COMASK) == (CAHI ? COMASK : 0)) - { if (c) outp(CDATA,c); return; } - } -} - - -char *new(size) - { char *rr; - rr = Freep; Freep += size; return rr; } - -struct Dist *NRoad(widx, curv, windx, dist) - { struct Dist *rr; - rr = new(sizeof *rr); - rr->key = 'D'; rr->Next = 0; - rr->miles = dist; rr->wid = widx; - rr->curve = curv; rr->wind = windx; - return rr; } - -struct Sign *NSign(txt) - char *txt; - { int leng; char *cc, *dd; - struct Sign *ss; - leng = sizeof *ss; leng++; - for (cc=txt; *cc++; leng++); - ss = new(leng); ss->key = 'S'; ss->Next = 0; - dd = &(ss->text); for (cc=txt; *dd++ = *cc++;); - return ss; } - -struct Fork *NFork(kk) - { struct Fork *ff; - ff = new(sizeof *ff); ff->key = kk; - ff->Next = 0; ff->Branch = 0; - return ff; } - -PrNode(nn) - struct Node *nn; - { printf("Node %x: %c -> %x \r\n", nn, nn->key, nn->Next); } - -char rdc() - { char ch; - if (ch = SavChr) { SavChr=0; return ch; }; - return (getc(InBuf)); } - -char pkc() - { return (SavChr = rdc()); } - -int rdn() - { int ans, ch; - ans = 0; - while (isdigit(pkc())) ans = ans*10 + (rdc() - '0'); - return ans; } - -struct Dist *LRoad() - { int w, c, iwid, dd; - char ch; - dd = rdn(); - w = -1; c = -1; iwid = 20; - while (pkc() != '\n') switch(rdc()) - { case '~': c++; continue; - case 'W': iwid = rdn(); continue; - case '!': w++; continue; - default: continue; } - return NRoad(iwid, c, w, dd); - } - -struct Dist *Load(name) - char *name; - { char ch, buf[100], *cc; - struct Sign First, Ignore; - struct Node *it, *last; - puts("\033z"); - SavChr = 0; - it = &First; First.key = '?'; - if (fopen(name, InBuf) == -1) - { printf("Can't read %s\r\n", name); exit(); } - - while ((ch = rdc()) != 014) putchar(ch); - while ((ch = rdc()) != ('Z'-64)) - { last = it; - switch(ch) - { case '=': Tag[rdc(InBuf)] = Freep; break; - case '|': while (rdc() != '\n'); break; - case '"': cc = buf; - while (((ch = rdc()) != '"') && - (ch != '\n')) *cc++ = ch; - *cc = 0; - it->Next = NSign(buf); it = it->Next; - break; - case '#': it->Next = LRoad(); it = it->Next; - break; - - case ':': it->Next = rdc(); - case '.': it = &Ignore; break; - - case '>': it->Next = NFork('R'); it = it->Next; - it->Branch = rdc(); - break; - case '<': it->Next = NFork('L'); it = it->Next; - it->Branch = rdc(); - break; - - case ' ': case '\n': case '\r': case '\t': - case '\f': break; - - default: puts("Illegal syntax: "); putchar(ch); - while ((ch = rdc(InBuf)) != '\n') putchar(ch); - puts("\n\r"); break; }} - NSign("Unbound label"); - srand1("\033x1\033x5\033Y8 (type a character to start)"); - if (!Seed) Seed = rand(); /* Do this only if "-r" option given - without any argument. */ - bdos(1); - return First.Next; } - -Exec(rr) -struct Road *rr; - { int x, dir, tt, right, left; - union Node *nn; - nn = rr->Next; rr->Next = nn->Next; - x = rr->X; dir = -1; - - switch (nn->key) { - case 'S': right = x+(rr->width); left = 78-right; - x = x>left? 0:right+2; - printf("\033Y%c%c\033G %s \033F", - SignY++, x+32, &(nn->text)); - return; - case 'D': rr->Age = 0; - if (nn->wind != 255) rr->Windy = ~(-1 << nn->wind); - if (nn->curve != 255) rr->Curvy = nn->curve; - rr->ToGo = nn->miles; - if (nn->wid != 255) rr->width = nn->wid; return; - case 'L': dir = 1; - case 'R': if (!Freeze) fork(nn->Branch, dir); return; - } - } - -MoveTo(x, y) { puts("\033Y"); putchar(y+32); putchar(x+32); } -SpeedL() { MoveTo(LSPEED, 24); putchar(Speed + '0'); } -label(val, posn) - { printf("\033Y8%c%d ", posn+32, val); } - - -getchar() - { char ch; - while (!(ch = CRTChr)) putchar(0); - CRTChr = 0; return ch; } - -car(x) - { puts("\033Y"); putchar(CARY+31); putchar(x+32); - puts(" "); } - -roll() - { puts("\033H\033L"); - CurX=0; CurY=0; - if ((ImPtr += 80) == ImEnd) ImPtr = Image; - Pavement = ImPtr[CarX]; - setmem(ImPtr, 80, IBAD); } - -road(x, width, rdno) - { char i, *cc; - puts("\033Y "); - putchar(32+x); - if (!RevFlg) { puts("\033p"); RevFlg=1; } - if (!AltFlg) { puts("\033F"); AltFlg=1; } - cc = &(ImPtr[x]); - for (i=width; i--;) { putchar('i'); *cc++ |= rdno; }} - -/* Update a Road; returns 1 if finish line. */ - -UpRd(rr) - struct Road *rr; - { int ddx, left, right, curve, act, rough; unsigned i; - if (!(act = rr->active)) return 0; - (rr->ToGo)--; - while ((rr->ToGo) <= 0) - { if (i = (rr->Next)) - { if (i == '.') return 1; - if (i == '*') { rr->active = 0; return 0; } - if (i < 128) - { rr->Next = Tag[i]; - if (BFlag) { puts("\033H\033G"); - putchar(i); - puts("\033F"); }} - Exec(rr); } - else { rr->active = 0; return 0; }} - if (Freeze) rough=0; - else rough=1; - if (++(rr->Age) > 24) - if (!(Pavement & (rr->Token))) - { rr->active = 0; Freeze = 0; return 0; } - ddx = rr->dx; - left = rr->X; right = left+(rr->width); - if (left < 1) ddx = rough; - else if (right > 79) ddx = -rough; - else if ((!Freeze) && (!((rr->Windy) & Ranno))) - { curve = rr->Curvy; - if (Ranno & 64) ddx += 1; - if (Ranno & 1024) ddx -= 1; - if ((ddx > curve) || (ddx < (-curve))) ddx = rr->dx; } - rr->dx = ddx; - rr->X += ddx; - road(rr->X, rr->width, rr->Token); - return 0; } - -/* returns 2 iff end, 0 iff crash, 1 else. */ - -int Update() - { int Eor; - SignY=32; - roll(); - Eor = UpRd(&Road1) | UpRd(&Road2); - if (Eor) return 2; - Delay(SpTime[Speed]); - if ((CarX += CarDX) < 0) { CarX=0; CarDX=0; } - else if (CarX > 79) { CarX=79; CarDX=0; } - car(CarX); - if (Pavement == IBAD) return 0; - return 1; } - -Delay(n) - { char ch; - n |= 1; - while (n--) - { putchar(0); - if (CRTChr) - { ch = getchar(); - switch(ch) { - case '4': CarDX--; break; - case '6': CarDX++; break; - case '5': - case '2': if (Speed>1) Speed--; Speed--; - case '8': if (++Speed > MAXSPD) Speed=MAXSPD; - SpeedL(); - }}}} - -fork(where, dir) - struct Node *where; - { struct Road *r1, *r2, newx; - r1 = &Road1; r2 = &Road2; - if (!(r1->active)) { r1 = &Road2; r2 = &Road1; } - r1->dx = dir; r2->dx = -dir; - r2->X = r1->X; - r2->active = 1; r2->Age = 0; - r2->Windy = r1->Windy; - r2->Curvy = r1->Curvy; - r2->width = r1->width; - r2->Next = where; r2->ToGo = -1; - Freeze = 1; } - -main(argc, argv) - char **argv; - { int i, j, Mins, Hours, Tics; - char *arg, *MapNam; - struct Node *First; - Seed = 12345; - j = SPDSCL*MAXSPD; - for (i=1; i<= MAXSPD; i++) SpTime[i] = j/i - SPDSCL; - SpTime[MAXSPD] = 0; - BFlag = 0; MapNam = "RALLY.MAP"; - for (i=1; i> 1); - Speed=3; - Update(); - for (i=0; i= TICMIN) { Tics -= TICMIN; Mins++; }; - while (Mins >= 60) { Mins -= 60; Hours++; }; - if (!(i = Update())) - { puts("\033H CRASHED AFTER "); -done: printf("\033G %d Hours, %d Minutes\007!!! !!! !!! ", Hours, Mins); - delay(10000); - goto top; } - else if (i == 2) - { puts("\033H YOU MADE IT IN "); - goto done; } - if (++Tenths >= 10) - { label(++Miles, LMILES); Tenths=0; } - goto loop; - } -  \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/RALLY.MAP b/software/CPM/CPM_MC_C1/RALLY.MAP deleted file mode 100644 index afbbaa1..0000000 Binary files a/software/CPM/CPM_MC_C1/RALLY.MAP and /dev/null differ diff --git a/software/CPM/CPM_MC_C1/STDLIB.C b/software/CPM/CPM_MC_C1/STDLIB.C deleted file mode 100644 index b9b762f..0000000 --- a/software/CPM/CPM_MC_C1/STDLIB.C +++ /dev/null @@ -1,370 +0,0 @@ - -/* - - The files STDLIB*.C contain source for all DEFF.CRL - functions which are written in C; Any functions which - appear in DEFF.CRL but have no corresponding source - were written in machine code and hand-converted to - .CRL format (as described in the User's Guide.) - - All functions written by Leor Zolman....who is - soley responsible for their kludginess. - -*/ - -#define RAM 0x0000 - -/* Buffered I/O for C */ - -struct buf { - int fd; - int nleft; - char *nextp; - char buff[128]; - }; - - -fopen(filename,iobuf) -struct buf *iobuf; -char *filename; -{ - int fd2; - if ((fd2= open(filename,0))<0) return -1; - iobuf -> fd = fd2; - iobuf -> nleft = 0; - return fd2; -} - - -getc(iobuf) -struct buf *iobuf; -{ - if (iobuf==0) return getchar(); - if (iobuf -> nleft--) return *iobuf -> nextp++; - if ((read(iobuf -> fd, iobuf -> buff, 1)) <= 0) - return -1; - iobuf -> nleft = 127; - iobuf -> nextp = iobuf -> buff; - return *iobuf -> nextp++; -} - -getw(iobuf) -struct buf *iobuf; -{ - int a,b; - if (((a=getc(iobuf)) >= 0) && ((b= getc(iobuf)) >=0)) - return 256*b+a; - return -1; -} - - -fcreat(name,iobuf) -char *name; -struct buf *iobuf; -{ - int fd2; - unlink(name); - if ((fd2 = creat(name))<0 ) return -1; - iobuf -> fd = fd2; - iobuf -> nextp = iobuf -> buff; - iobuf -> nleft = 128; - return fd2; -} - - -putc(c,iobuf) -int c; -struct buf *iobuf; -{ - if (iobuf == 1) return putchar(c); - if (iobuf -> nleft--) return *iobuf->nextp++ =c; - if ((write(iobuf -> fd, iobuf -> buff,1)) <=0) - return -1; - iobuf -> nleft = 127; - iobuf -> nextp = iobuf -> buff; - return *iobuf -> nextp++ = c; -} - - -putw(w,iobuf) -unsigned w; -struct buf *iobuf; -{ - if ((putc(w%256,iobuf) >=0)&&(putc(w/256,iobuf)>=0)) - return w; - return -1; -} - - -fflush(iobuf) -struct buf *iobuf; -{ - if (iobuf==1) return 0; - if (iobuf -> nleft == 128) return 0; - if ((write(iobuf -> fd, iobuf -> buff,1)) <=0) - return -1; - if (iobuf -> nleft != 0) - return seek(iobuf->fd, -1, 1); - iobuf -> nleft = 128; - iobuf -> nextp = iobuf -> buff; - return 0; -} - -/* - Some string functions -*/ - - -puts(s) -char *s; -{ - while (*s) putchar (*s++); -} - - -atoi(n) -char *n; -{ - int val; - char c; - int sign; - val=0; - sign=1; - while ((c = *n) == '\t' || c== ' ') ++n; - if (c== '-') {sign = -1; n++;} - while ( dig(c = *n++)) val = val * 10 + c - '0'; - return sign*val; -} - - -strcat(s1,s2) -char *s1, *s2; -{ - char *temp; temp=s1; - while(*s1) s1++; - do *s1++ = *s2; while (*s2++); - return temp; -} - -strcmp(s1,s2) -char *s1, *s2; -{ - while (*s1++ == *s2++) if (!*s1) return 0; - return (*--s1 > *--s2) ? 1 : -1; -} - - -strcpy(s1,s2) -char *s1, *s2; -{ - char *temp; temp=s1; - while (*s1++ = *s2++); - return temp; -} - - -strlen(s) -char *s; -{ - int len; - len=0; - while (*s++) len++; - return(len); -} - - -/* - Some character diddling functions -*/ - -isalpha(c) -char c; -{ - return isupper(c) || islower(c); -} - - -isupper(c) -char c; -{ - return c>='A' && c<='Z'; -} - - -islower(c) -char c; -{ - return c>='a' && c<='z'; -} - - -isdigit(c) -char c; -{ - return c>='0' && c<='9'; -} - - -isspace(c) -char c; -{ - return c==' ' || c=='\t' || c=='\n'; -} - - -toupper(c) -char c; -{ - return islower(c) ? c-32 : c; -} - - -tolower(c) -char c; -{ - return isupper(c) ? c+32 : c; -} - - -/* - Other stuff... -*/ - - -qsort(base,nel,width,compar) -char *base; -int(*compar)(); -int nel; -int width; -{ - unsigned i,j,x; - x=base+nel*width; - for (i=base; i0) - for(j=0;j0) - for(j=0; j=0; i-=4) - prhd((*args>>i)&15); - if((i=width-4)>0) for(j=0; j='0' && n<='9'); -} - - -int uspr(n) -unsigned n; -{ - int temp; - if (n<10) { - putchar(n+'0'); - return 1; - } - temp = uspr(n/10); - uspr(n%10); - return temp+1; -} - -abs(n) -{ - return n<0 ? -n : n; -} - - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/STDLIB1.C b/software/CPM/CPM_MC_C1/STDLIB1.C deleted file mode 100644 index a50f17f..0000000 --- a/software/CPM/CPM_MC_C1/STDLIB1.C +++ /dev/null @@ -1,457 +0,0 @@ - - -#include "bdscio.h" - -/* - STDLIB1.C -- for BDS C v1.41 -- 10/14/80 - - The files STDLIB*.C contain source for all DEFF.CRL - functions which are written in C; Any functions which - appear in DEFF.CRL but have no corresponding source - were written in machine code and converted to .CRL - format (as described in the User's Guide.) - - All functions written by Leor Zolman....who is - soley responsible for their kludginess. - - Functions appearing in this file: - - fopen getc ungetc getw - fcreat putc putw - fflush fclose - atoi - strcat strcmp strcpy strlen - isalpha isupper islower isdigit - isspace toupper tolower - qsort - initw initb getval - alloc * free * - abs max min - - * -- Compilation of alloc and free must be explicitly enabled by - swapping the commenting of the ALLOC_ON and ALLOC_OFF definitions - in BDSCIO.H. - -*/ - - -/* - Buffered I/O for C: -*/ - -int fopen(filename,iobuf) -struct _buf *iobuf; -char *filename; -{ - if ((iobuf -> _fd = open(filename,0))<0) return ERROR; - iobuf -> _nleft = 0; - return iobuf -> _fd; -} - - -int getc(iobuf) -struct _buf *iobuf; -{ - int nsecs; - if (iobuf == 0) return getchar(); - if (iobuf == 3) return bdos(3); - if (iobuf -> _nleft--) return *iobuf -> _nextp++; - if ((nsecs = read(iobuf -> _fd, iobuf -> _buff, NSECTS)) <= 0) - return ERROR; - iobuf -> _nleft = (NSECTS * SECSIZ - 1); - iobuf -> _nextp = iobuf -> _buff; - return *iobuf->_nextp++; -} - -/* - Buffered "unget" a character routine. Only ONE - byte may be "ungotten" between consecutive "getc" calls. -*/ - -int ungetc(c, iobuf) -struct _buf *iobuf; -char c; -{ - if (iobuf == 0) return ungetch(c); - if (iobuf -> _nleft == (NSECTS * SECSIZ)) return ERROR; - *--iobuf -> _nextp = c; - iobuf -> _nleft++; - return OK; -} - - -int getw(iobuf) -struct _buf *iobuf; -{ - int a,b; - if (((a=getc(iobuf)) >= 0) && ((b= getc(iobuf)) >=0)) - return 256*b+a; - return ERROR; -} - - -int fcreat(name,iobuf) -char *name; -struct _buf *iobuf; -{ - unlink(name); - if ((iobuf -> _fd = creat(name)) < 0 ) return ERROR; - iobuf -> _nextp = iobuf -> _buff; - iobuf -> _nleft = (NSECTS * SECSIZ); - return iobuf -> _fd; -} - - -int putc(c,iobuf) -char c; -struct _buf *iobuf; -{ - if (iobuf == 1) return putchar(c); - if (iobuf == 2) return (bdos(5,c)); - if (iobuf == 3) return (bdos(4,c)); - if (iobuf -> _nleft--) return *iobuf -> _nextp++ = c; - if ((write(iobuf -> _fd, iobuf -> _buff, NSECTS)) != NSECTS) - return ERROR; - iobuf -> _nleft = (NSECTS * SECSIZ - 1); - iobuf -> _nextp = iobuf -> _buff; - return *iobuf -> _nextp++ = c; -} - - -int putw(w,iobuf) -unsigned w; -struct _buf *iobuf; -{ - if ((putc(w%256,iobuf) >=0 ) && (putc(w / 256,iobuf) >= 0)) - return w; - return ERROR; -} - - -int fflush(iobuf) -struct _buf *iobuf; -{ - int i; - if (iobuf < 4) return OK; - if (iobuf -> _nleft == (NSECTS * SECSIZ)) return OK; - - i = NSECTS - iobuf->_nleft / SECSIZ; - if (write(iobuf -> _fd, iobuf -> _buff, i) != i) - return ERROR; - i = (i-1) * SECSIZ; - - if (iobuf -> _nleft) { - movmem(iobuf->_buff + i, iobuf->_buff, SECSIZ); - iobuf -> _nleft += i; - iobuf -> _nextp -= i; - return seek(iobuf->_fd, -1, 1); - } - - iobuf -> _nleft = (NSECTS * SECSIZ); - iobuf -> _nextp = iobuf -> _buff; - return OK; -} - -int fclose(iobuf) -struct _buf *iobuf; -{ - return close(iobuf -> _fd); -} - - - -/* - Some string functions -*/ - - -int atoi(n) -char *n; -{ - int val; - char c; - int sign; - val=0; - sign=1; - while ((c = *n) == '\t' || c== ' ') ++n; - if (c== '-') {sign = -1; n++;} - while ( isdigit(c = *n++)) val = val * 10 + c - '0'; - return sign*val; -} - - -char *strcat(s1,s2) -char *s1, *s2; -{ - char *temp; temp=s1; - while(*s1) s1++; - do *s1++ = *s2; while (*s2++); - return temp; -} - - -int strcmp(s,t) -char s[], t[]; -{ - int i; - i = 0; - while (s[i] == t[i]) - if (s[i++] == '\0') - return 0; - return s[i] - t[i]; -} - - -char *strcpy(s1,s2) -char *s1, *s2; -{ - char *temp; temp=s1; - while (*s1++ = *s2++); - return temp; -} - - -int strlen(s) -char *s; -{ - int len; - len=0; - while (*s++) len++; - return len; -} - - -/* - Some character diddling functions -*/ - -int isalpha(c) -char c; -{ - return isupper(c) || islower(c); -} - - -int isupper(c) -char c; -{ - return c>='A' && c<='Z'; -} - - -int islower(c) -char c; -{ - return c>='a' && c<='z'; -} - - -int isdigit(c) -char c; -{ - return c>='0' && c<='9'; -} - - -int isspace(c) -char c; -{ - return c==' ' || c=='\t' || c=='\n'; -} - - -char toupper(c) -char c; -{ - return islower(c) ? c-32 : c; -} - - -char tolower(c) -char c; -{ - return isupper(c) ? c+32 : c; -} - - - - -/* - Other stuff... -*/ - - -/* - This is the new qsort routine, utilizing the shell sort - technique given in the Software Tools book (by Kernighan - & Plauger.) - - NOTE: this "qsort" function is different from the "qsort" given - in some old releases (pre 1.32) -- here, the items are sorted - in ASCENDING order. The old "qsort" sorted stuff in DESCENDING - order, and was in part responsible for the atrocious play of - the "Othello" program (it always made the WORST moves it could - find...) -*/ - -qsort(base, nel, width, compar) -char *base; int (*compar)(); -{ int gap,ngap, i, j; - int jd, t1, t2; - t1 = nel * width; - for (ngap = nel / 2; ngap > 0; ngap /= 2) { - gap = ngap * width; - t2 = gap + width; - jd = base + gap; - for (i = t2; i <= t1; i += width) - for (j = i - t2; j >= 0; j -= gap) { - if ((*compar)(base+j, jd+j) <=0) break; - _swp(width, base+j, jd+j); - } - } -} - -_swp(w,a,b) -char *a,*b; -int w; -{ - char tmp; - while(w--) {tmp=*a; *a++=*b; *b++=tmp;} -} - - - - -/* - Initialization functions -*/ - - -initw(var,string) -int *var; -char *string; -{ - int n; - while ((n = getval(&string)) != -32760) *var++ = n; -} - -initb(var,string) -char *var, *string; -{ - int n; - while ((n = getval(&string)) != -32760) *var++ = n; -} - -int getval(strptr) -char **strptr; -{ - int n; - if (!**strptr) return -32760; - n = atoi(*strptr); - while (**strptr && *(*strptr)++ != ','); - return n; -} - - - -/* - Storage allocation routines, taken from chapter 8 of K&R, but - simplified to ignore the storage allignment problem and not - bother with the "morecore" hack (a call to "sbrk" under CP/M is - a relatively CHEAP operation, and can be done on every call to - "alloc" without degrading efficiency.) - - Note that compilation of "alloc" and "free" is disabled until - the "#define ALLOC_ON 1" statement is un-commented in the header - file ("BDSCIO.H"). This is done so that the external storage - required by alloc and free isn't declared unless the user - actually needs the alloc and free functions. As soon as BDS C - gets static variables, this kludge will go away. -*/ - - -#ifdef ALLOC_ON /* Compilation of alloc and free is enabled only - when the ALLOC_ON symbol is #defined in BDSCIO.H */ - -char *alloc(nbytes) -unsigned nbytes; -{ - struct _header *p, *q, *cp; - int nunits; - nunits = 1 + (nbytes + (sizeof (_base) - 1)) / sizeof (_base); - if ((q = _allocp) == NULL) { - _base._ptr = _allocp = q = &_base; - _base._size = 0; - } - for (p = q -> _ptr; ; q = p, p = p -> _ptr) { - if (p -> _size >= nunits) { - if (p -> _size == nunits) - q -> _ptr = p -> _ptr; - else { - p -> _size -= nunits; - p += p -> _size; - p -> _size = nunits; - } - _allocp = q; - return p + 1; - } - if (p == _allocp) { - if ((cp = sbrk(nunits * sizeof (_base))) == ERROR) - return NULL; - cp -> _size = nunits; - free(cp+1); /* remember: pointer arithmetic! */ - p = _allocp; - } - } -} - - -free(ap) -struct _header *ap; -{ - struct _header *p, *q; - - p = ap - 1; /* No need for the cast when "ap" is a struct ptr */ - - for (q = _allocp; !(p > q && p < q -> _ptr); q = q -> _ptr) - if (q >= q -> _ptr && (p > q || p < q -> _ptr)) - break; - if (p + p -> _size == q -> _ptr) { - p -> _size += q -> _ptr -> _size; - p -> _ptr = q -> _ptr -> _ptr; - } - else p -> _ptr = q -> _ptr; - - if (q + q -> _size == p) { - q -> _size += p -> _size; - q -> _ptr = p -> _ptr; - } - else q -> _ptr = p; - - _allocp = q; -} - -#endif - - - -/* - Now some really hairy functions to wrap things up: -*/ - -int abs(n) -{ - return (n<0) ? -n : n; -} - -int max(a,b) -{ - return (a > b) ? a : b; -} - -int min(a,b) -{ - return (a <= b) ? a : b; -} - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/STDLIB2.C b/software/CPM/CPM_MC_C1/STDLIB2.C deleted file mode 100644 index 3be88bd..0000000 --- a/software/CPM/CPM_MC_C1/STDLIB2.C +++ /dev/null @@ -1,647 +0,0 @@ -/* - STDLIB2.C -- for BDS C v1.41 -- 10/14/80 - - This file contains the source for the following - library functions: - - printf fprintf sprintf _spr - scanf fscanf sscanf _scn - fgets - puts fputs - swapin - - Note that all the upper-level formatted I/O functions - ("printf", "fprintf", "scanf", and "fscanf") now use - "_spr" and "_scn" for doing conversions. While - this leads to very modularized source code, it also - means that calls to "scanf" and "fscanf" must process - ALL the information on a line of text; if the format - string runs out and there is still text left in the - line being processed, the text will be lost (i.e., the - NEXT scanf or fscanf call will NOT find it.) - - An alternate version of "_spr" is given in the file - FLOAT.C for use with floating point numbers; see FLOAT.C - for details. Since "_spr" is used by "printf", this - really amounts to an alternate version of "printf." - - Also note that temporary work space is declared within - each of the high-level functions as a one-dimensional - character array. The length limit on this array is - presently set to 132 by the #define MAXLINE statement; - if you intend to create longer lines through printf, - fprintf, scanf, or fscanf calls, be SURE to raise this - limit by changing the #define statement. - - Some misc. comments on hacking text files with CP/M: - The conventional CP/M text format calls for each - line to be terminated by a CR-LF combination. In the - world of C programming, though, we like to just use - a single LF (also called a newline) to terminate - lines. AND SO, the functions which deal with reading - and writing text lines from disk files to memory and - vice-versa ("fgets", "fputs") take special pains to - convert CR-LF combinations into single '\n' characters - when reading from disk ("fgets"), and convert '\n' - characters to CR-LF combinations when writing TO disk - ("fputs"). This allows the C programmer to do things - in style, dealing only with a single line terminator - while the text is in memory, while maintaining compat- - ibility with the CP/M text format for disk files (so - that, for example, a text file can be "type"d under - the CCP.) - To confuse matters further, the "gets" function - (which simply buffers up a line of console input) - terminates a line with '\0' (a zero byte) instead - of CR or LF. Thus, if you want to read in lines of - input from the console and write them to a file, - you'll have to manually put out the CR and LF at the - end of every line ("gets" was designed this was to - be compatible with the UNIX version). - - Remember to put out a 0x1a (control-Z, CPMEOF) at - the end of text files being written out to disk. - - Also, watch out when reading in text files using - "getc". While a text file is USUALLY terminated - with a control-Z, it MAY NOT BE if the file ends - on an even sector boundary (although respectable - editors will now usually make sure the control-Z - is always there.) This means that there are two - possible return values from "getc" which can signal - an End-of file: CPMEOF ( 0x1a, or control-Z), - ERROR (-1, or 255 if you assign it to a char variable) - should the CPMEOF (0x1a) be missing. -*/ - -#include "bdscio.h" - -char toupper(), isdigit(); - -/* - printf - - usage: - printf(format, arg1, arg2, ...); - - Note that since the "_spr" function is used to - form the output string, and then "puts" is used to - actually print it out, care must be taken to - avoid generating null (zero) bytes in the output, - since such a byte will terminate printing of the - string by puts. Thus, a statment such as: - - printf("%c foo",'\0'); - - would print nothing at all. - - This is my latest version of the "printf" standard library - routine. This time, folks, it REALLY IS standard. I've - tried to make it EXACTLY the same as the version presented - in Kernighan & Ritchie: right-justification of fields is - now the default instead of left-justification (you can have - left-justification by using a dash in the conversion, as - specified in the book); the "%s" conversion can take a precision - now as well as a field width; the "e" and "f" conversions, for - floating point numbers, are supported in a special version of - "_spr" given in source form in the FLOAT.C file. If you do - a lot of number crunching and wish to have that version be the - default (it eats up a K or two more than this version), just - replace the version of "_spr" in DEFF.CRL with the one in FLOAT.C, - using the CLIB program, or else be stuck with always typing in - "float" on the clink command line... -*/ - -printf(format) -char *format; -{ - char line[MAXLINE]; - _spr(line,&format); /* use "_spr" to form the output */ - puts(line); /* and print out the line */ -} - - -/* - scanf: - This one accepts a line of input text from the - console, and converts the text to the required - binary or alphanumeric form (see Kernighan & - Ritchie for a more thorough description): - Usage: - scanf(format, ptr1, ptr2, ...); - - Returns number of items matched. - - Since a new line of text must be entered from the - console each time scanf is called, any unprocessed - text left over from the last call is lost forever. - This is a difference between BDS scanf and UNIX - scanf. Another is that the field width specification - is not supported here. -*/ - -int scanf(format) -char *format; -{ - char line[MAXLINE]; - gets(line); /* get a line of input from user */ - return _scn(line,&format); /* and scan it with "_scn" */ -} - - -/* - fprintf: - Like printf, except that the first argument is - a pointer to a buffered I/O buffer, and the text - is written to the file described by the buffer: - ERROR (-1) returned on error. - - usage: - fprintf(iobuf, format, arg1, arg2, ...); -*/ - -int fprintf(iobuf,format) -char *format; -struct _buf *iobuf; -{ - char text[MAXLINE]; - _spr(text,&format); - return fputs(text,iobuf); -} - - -/* - fscanf: - Like scanf, except that the first argument is - a pointer to a buffered input file buffer, and - the text is taken from the file instead of from - the console. - Usage: - fscanf(iobuf, format, ptr1, ptr2, ...); - Returns number of items matched (zero on EOF.) - Note that any unprocessed text is lost forever. Each - time scanf is called, a new line of input is gotten - from the file, and any information left over from - the last call is wiped out. Thus, the text in the - file must be arranged such that a single call to - fscanf will always get all the required data on a - line. This is not compatible with the way UNIX does - things, but it eliminates the need for separate - scanning functions for files, strings, and console - input; it is more economical to let both "fscanf" and - "scanf" use "sscanf". If you want to be able to scan - a partial line with fscanf and have the rest still be - there on the next fscanf call, you'll have to rewrite - fscanf to be self contained (not use sscanf) and use - "ungetc" to push back characters. - - Returns number of items succesfully matched. -*/ - -int fscanf(iobuf,format) -char *format; -struct _buf *iobuf; -{ - char text[MAXLINE]; - if (!fgets(text,iobuf)) return 0; - return _scn(text,&format); -} - - -/* - sprintf: - Like fprintf, except a string pointer is specified - instead of a buffer pointer. The text is written - directly into memory where the string pointer points. - - Usage: - sprintf(string,format,arg1, arg2, ...); -*/ - -sprintf(buffer,format) -char *buffer, *format; -{ - _spr(buffer,&format); /* call _spr to do all the work */ -} - - -/* - sscanf: - - Reads a line of text in from the console and scans it - for variable values specified in the format string. Uses - "_scn" for actual conversions; see the comments below in - the _scn function for more details. - - Usage: - scanf(format,&arg1,&arg2,...); -*/ - -int sscanf(line,format) -char *line, *format; -{ - return _scn(line,&format); /* let _scn do all the work */ -} - - - -/* - General formatted output conversion routine, used by - fprintf and sprintf..."line" is where the output is - written, and "fmt" is a pointer to an argument list - which must consist of a format string pointer and - subsequent list of (optional) values. Having arguments - passed on the stack works out a heck of a lot neater - than it did before when the args were passed via an - absolute vector in low memory! -*/ - - -_spr(line,fmt) -char *line, **fmt; -{ - char _uspr(), c, base, *sptr, *format; - char wbuf[MAXLINE], *wptr, pf, ljflag; - int width, precision, *args; - - format = *fmt++; /* fmt first points to the format string */ - args = fmt; /* now fmt points to the first arg value */ - - while (c = *format++) - if (c == '%') { - wptr = wbuf; - precision = 6; - ljflag = pf = 0; - - if (*format == '-') { - format++; - ljflag++; - } - - width = (isdigit(*format)) ? _gv2(&format) : 1; - - if ((c = *format++) == '.') { - precision = _gv2(&format); - pf++; - c = *format++; - } - - switch(toupper(c)) { - - case 'D': if (*args < 0) { - *wptr++ = '-'; - *args = -*args; - width--; - } - - case 'U': base = 10; goto val; - - case 'X': base = 16; goto val; - - case 'O': base = 8; /* note that arbitrary bases can be - added easily before this line */ - - val: width -= _uspr(&wptr,*args++,base); - goto pad; - - case 'C': *wptr++ = *args++; - width--; - goto pad; - - case 'S': if (!pf) precision = 200; - sptr = *args++; - while (*sptr && precision) { - *wptr++ = *sptr++; - precision--; - width--; - } - - pad: *wptr = '\0'; - pad2: wptr = wbuf; - if (!ljflag) - while (width-- > 0) - *line++ = ' '; - - while (*line = *wptr++) - line++; - - if (ljflag) - while (width-- > 0) - *line++ = ' '; - break; - - default: *line++ = c; - - } - } - else *line++ = c; - - *line = '\0'; -} - -/* - Internal routine used by "_spr" to perform ascii- - to-decimal conversion and update an associated pointer: -*/ - -int _gv2(sptr) -char **sptr; -{ - int n; - n = 0; - while (isdigit(**sptr)) n = 10 * n + *(*sptr)++ - '0'; - return n; -} - - -/* - Internal function which converts n into an ASCII - base `base' representation and places the text - at the location pointed to by the pointer pointed - to by `string'. Yes, you read that correctly. -*/ - -char _uspr(string, n, base) -char **string; -unsigned n; -{ - char length; - if (n b-1) return ERROR; - else return c; -} - - -/* - puts: - Write out the given string to the console. - A newline is NOT automatically appended: -*/ - -puts(s) -char *s; -{ - while (*s) putchar(*s++); -} - - -/* - fgets: - This next function is like "gets", except that - a) the line is taken from a buffered input file instead - of from the console, and b) the newline is INCLUDED in - the string and followed by a null byte. - - This one is a little tricky due to the CP/M convention - of having a carriage-return AND a linefeed character - at the end of every text line. In order to make text - easier to deal with from C programs, this function (fgets) - automatically strips off the CR from any CR-LF combinations - that come in from the file. Any CR characters not im- - mediately followed by LF are left intact. The LF - is included as part of the string, and is followed - by a null byte. (Note that LF equals "newline".) - There is no limit to how long a line - can be here; care should be taken to make sure the - string pointer passed to fgets points to an area - large enough to accept any possible line length - (a line must be terminated by a newline (LF, or '\n') - character before it is considered complete.) - - The value NULL (defined to be 0 here) is returned - on EOF, whether it be a physical EOF (attempting to - read past last sector of the file) OR a logical EOF - (encountered a control-Z.) The 1.3 version didn't - recognize logical EOFs, because I did't realize how - SIMPLE it was to implement a buffered I/O "ungetc" - function. -*/ - -char *fgets(s,iobuf) -char *s; -struct _buf *iobuf; -{ - int count, c; - char *cptr; - count = MAXLINE; - cptr = s; - if ( (c = getc(iobuf)) == CPMEOF || c == EOF) return NULL; - - do { - if ((*cptr++ = c) == '\n') { - if (cptr>s+1 && *(cptr-2) == '\r') - *(--cptr - 1) = '\n'; - break; - } - } while (count-- && (c=getc(iobuf)) != EOF && c != CPMEOF); - - if (c == CPMEOF) ungetc(c,iobuf); /* push back control-Z */ - *cptr = '\0'; - return s; -} - - - -/* - fputs: - This function writes a string out to a buffered - output file. The '\n' character is expanded into - a CR-LF combination, in keeping with the CP/M - convention. - If a null ('\0') byte is encountered before a - newline is encountered, then there will be NO - automatic termination character appended to the - line. - ERROR (-1) returned on error. -*/ - -fputs(s,iobuf) -char *s; -struct _buf *iobuf; -{ - char c; - while (c = *s++) { - if (c == '\n') putc('\r',iobuf); - if (putc(c,iobuf) == ERROR) return ERROR; - } - return OK; -} - - -/* - swapin: - This is the swapping routine, to be used by the root - segment to swap in a code segment in the area of memory - between the end of the root segment and the start of the - external data area. See the document "SWAPPING.DOC" for - detailed info on the swapping scheme. - - Returns ERROR (-1) on error, OK (0) if segment loaded in OK. - - This version does not check to make sure that the code - yanked in doesn't overlap into the extenal data area (in - the interests of keeping the function short.) But, if you'd - like swapin to check for such problems, note that memory - locations ram+115h and ram+116h contain the 16-bit address - of the base of the external data area (low order byte first, - as usual.) By rewriting swapin to read in one sector at a time - and check the addresses, accidental overlap into the data area - can be avoided. -*/ - -swapin(name,addr) -char *name; /* the file to swap in */ -{ - int fd; - if (( fd = open(name,0)) == ERROR) { - printf("Swapin: cannot open %s\n",name); - return ERROR; - } - if ((read(fd,addr,9999)) < 0) { - printf("Swapin: read error on %s\n",name); - close(fd); - return ERROR; - } - close(fd); - return OK; -} - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/STONE.C b/software/CPM/CPM_MC_C1/STONE.C deleted file mode 100644 index ad4da32..0000000 --- a/software/CPM/CPM_MC_C1/STONE.C +++ /dev/null @@ -1,433 +0,0 @@ -/* - === - "STONE" --- H19 Version (for H19/Z19/H89/Z89 ONLY) - === - - (otherwise known as "Awari") - - This version written by: - - Terry Hayes & Clark Baker - Real-Time Systems Group - MIT Lab for Computer Science - - Hacked up a little by Leor Zolman and Steve Ward - (Steve did all the neat H19 display hackery!) - - The algorithm used for STONE is a common one - to Artificial Intelligence people: the "Alpha- - Beta" pruning heuristic. By searching up and down - a tree of possible moves and keeping record of - the minimum and maximum scores from the - terminal static evaluations, it becomes possible - to pinpoint move variations which can in no way - affect the outcome of the search. Thus, those - variations can be simply discarded, saving - expensive static evaluation time. - - THIS is the kind of program that lets C show its - stuff; Powerful expression operators and recursion - combine to let a powerful algorithm be implemented - painlessly. - - And it's fun to play! - - - Rules of the game: - - Each player has six pits in front of him and a - "home" pit on one side (the computer's home pit - is on the left; your home pit is on the right.) - - At the start of the game, all pits except the home - pits are filled with n stones, where n can be anything - from 1 to 6. - - To make a move, a player picks one of the six pits - on his side of the board that has stones in it, and - redistributes the stones one-by-one going counter- - clockwise around the board, starting with the pit - following the one picked. The opponent's HOME pit is - never deposited into. - - If the LAST stone happens to fall in that player's - home pit, he moves again. - - If the LAST stone falls into an empty pit on the - moving player's side of board, then any stones in the - pit OPPOSITE to that go into the moving - player's home pit. - - When either player clears the six pits on his - side of the board, the game is over. The other player - takes all stones in his six pits and places them in - his home pit. Then, the player with the most stones - in his home pit is the winner. - - The six pits on the human side are numbered one - to six from left to right; the six pits on the - computer's side are numbered one to six right-to- - left. - - The standard game seems to be with three stones; - Less stones make it somewhat easier (for both you - AND the computer), while more stones complicate - the game. As far as difficulty goes, well...it - USED to be on a scale of 1 to 50, but I couldn't - win it at level 1. So I changed it to 1-300, and - couldn't win at level 1. So I changed it to 1-1000, - and if I STILL can't win it at level 1, I think - I'm gonna commit suicide. - - Good Luck!!! -*/ - -unsigned total; -char string[80]; - -unsigned COUNT, Seed; -int NUM; - -int holex[14]; -int holey[14]; -int stonex[48]; -int stoney[48]; - -exinit() - { initw(holex, "7,10,10,10,10,10,10,8,4,4,4,4,4,4"); - initw(holey, "7,16,24,32,40,48,56,66,56,48,40,32,24,16"); - initw(stonex, "0,0,0,-1,1,1,1,-1,-1,1,1,0,0,-1,-1,-2,-2,-2,-2,\ - -2,-3,-3,-3,-3,-3,-1,0,-2,1,-3,2,2,2,2,3,3,-4,-4,-4,-4,3,2,3,\ - 2,3,3,-4,-4"); - initw(stoney, "0,1,-1,0,0,-1,1,-1,1,-2,2,-2,2,-2,2,0,-1,1,-2,2,\ - 0,-1,1,-2,2,-3,-3,-3,-3,-3,0,-1,-2,1,0,-1,-1,0,-2,1,1,2,-2,-3,\ - 2,-3,2,-3"); - } - -putchar(ch) - { - bios(4,ch); - } - -dance(y, x) - { int i,j,k; - k = 30; - puts("\033q\033F"); - while (!bios(2)) - { display(y,x); - for (i=0; i1000) goto new; - printf("Number of stones (1-6): "); - NUM = atoi(gets(string)); - COUNT = inp * 65; - NewBD(); - initb(board); - display(21,50); printf("\033p Difficulty: %d \033q", inp); - display(19,0); - printf("Do you want to go first (y or n)? "); - inp = toupper(getchar()); - printf("\033l\n\n"); - if (inp == 'N') goto first; - y = 0; - while(notdone(board)) { -again: display(20,10); - printf("\033G\033p Your move: \b\b"); - for (;;) { - dance(20, 40); puts("\033p"); display(20,22); - inp = getchar() - '0'; - if (toupper(inp+'0')=='Q')goto new; - if (inp < 1 || inp > 6 || !board[inp]) - { putchar(7); goto again; } - y++; - break; - } - puts("\033q"); - if (!dmove(board,inp)) continue; -first: display(20,10); rptc(' ', 30); - y = 0; - while (notdone(board)) { - display(21, 10); - printf("\033p I'm thinking \033q"); - inp = comp(board); - display(21,10); rptc(' ', 30); - display(22,10); - printf("\033p Computer moves: "); - printf("%d \033q",inp-7); - y++; - if (dmove(board,inp)) break; - display(22,10); rptc(' ', 30); - } - y = 0; - } - com = board[0]; - hum = board[7]; - for (inp = 1; inp < 7; inp++) { - hum += board[inp]; - com += board[inp+7]; - } - display(23,10); - printf("\033p Score: me %d you %d . . . ",com,hum); - if (com>hum) switch (rand() % 4) { - case 0: printf("Gotcha!!"); - break; - case 1: printf("Chalk one up for the good guys!"); - break; - case 2: printf("Automation does it again!"); - break; - case 3: printf("I LOVE to WIN!"); - } - else if (hum==com) printf("How frustrating!!"); - else printf("Big Deal! Try a REAL difficulty!"); - printf(" \033q\033G"); - display(19,0); - sleep(5); - printf("\033p New Game (y/n): \033q\033K"); - dance(19,40); - if (toupper(getchar()) == 'Y') goto new; - display(23,0); - printf("\033z"); - exit(); -} - -mod(i,j) int i,j; -{ - ++i; - if (i == 7) return( j ? 7 : 8); - if (i > 13) return ( j ? 1 : 0); - return(i); -} - -initb(board) char *board; -{ - int i,j; - for (i= 0; i <14; ++i) - { board[i]=0; - if (i != 0 && i != 7) for (j = 0; j < NUM; j++) incpit(board,i); } - return; -} - -comp(board) char *board; -{ - int score; - int bestscore,best; - char temp[14]; - int i; - unsigned nodes; - total = 0; - - if ((i = countnodes(board,8)) == 1) - for (best = 8; best < 14; ++best) - if (board[best]) return(best); - nodes = COUNT/i; - bestscore = -10000; - for (i = 13; i > 7; --i) if (board[i]) { - score = mmove(board,temp,i); - score = comp1( temp, score, nodes, bestscore, 10000); - if (score > bestscore) { - bestscore = score; - best = i; - } - } - display(19,10); - if (bestscore > 1000) - puts("\033p I'VE GOT YOU! \033q\n"); - if (bestscore < -1000) - printf("\033p YOU'VE GOT ME! \033q\n"); - return(best); -} - -comp1(board,who,count,alpha,beta) - char *board; int who; int alpha,beta; -unsigned count; -{ - int i; - int turn,new; - char temp[14]; - unsigned nodes; - if (count < 1) { - new = board[0]-board[7]; - for (i = 1; i < 7; ++i) { turn = min(7-i,board[i]); - new -= 2*turn - board[i]; } - for (i = 8; i < 14; ++i) { turn = min(14-i,board[i]); - new += 2*turn - board[i]; } - if (board[0] > 6*NUM) new += 1000; - if (board[7] > 6*NUM) new -= 1000; - return(new); - } - if (!notdone(board)) { - new = board[0]+board[8]+board[9]+board[10] - +board[11]+board[12]+board[13]-board[1]-board[2] - -board[3]-board[4]-board[5]-board[6]-board[7]; - if ( new < 0) return (new - 1000); - if ( new > 0) return (new + 1000); - return(0); - } - nodes = count/countnodes(board,8-who*7); - for (i = 7*(1-who)+6; i > 7*(1-who); --i) - if (board[i]) { - turn = mmove(board,temp,i); - new = comp1(temp,(turn? 1-who: who),nodes,alpha,beta); - if (who) { - beta = min(new,beta); - if (beta <= alpha) return(beta); } - else { - alpha = max(new,alpha); - if (alpha >= beta) return(alpha); } - } - return(who ? beta : alpha); -} - -min(i,j) int i,j; -{ - return(i < j ? i : j); -} - -max(i,j) int i,j; -{ - return(i > j ? i : j); -} - -notdone(board) char *board; -{ - return (board[1] || board[2] || board[3] || board[4] - || board[5] || board[6]) && - (board[8] || board[9] || board[10] || board[11] - || board[12] || board[13]); -} - -countnodes(board,start) int start; char *board; -{ - int i; - int num; - num = 0; - for (i = start; i< start + 6; ++i) - num += (board[i] ? 1 : 0); - return(num); -} - -incpit(board,pit) char *board; int pit; -{ - display(1+holex[pit]+stonex[board[pit]], - 3+holey[pit] +stoney[board[pit]]); - printf("\033F^\033G"); - board[pit]++; -} - -display(x,y) int x,y; -{ - printf("\033Y%c%c",x+32,y+32); -} - -decpit(board,pit) char *board; int pit; -{ - board[pit]--; - display(1+holex[pit]+stonex[board[pit]], - 3+holey[pit] +stoney[board[pit]]); - putchar(' '); -} - - -rpt(cc, n) - { while (n--) printf(cc); } - -rptc(cc, n) - { while (n--) putchar(cc); } - -nb1(n) - { rpt("ii q p q p q p q p q p q p q p q p ii\n\r", n); } - -NewBD() - { printf("\033H\033J\033p\033F"); - rptc('i', 77); - printf("\n\rii"); rptc(' ',73); - printf("ii\n\rii"); - printf(" ME 6 5 4 3"); - printf(" 2 1 ii\n\rii qr _p "); - rpt(" qr _p", 6); printf(" ii\n\r"); - printf("ii q p q p q p q p q p q p q p qr _p ii\n\r"); - nb1(2); - printf("ii q p _q pr _q pr _q pr _q pr _q pr _q pr q p ii\n\r"); - printf("ii q p q p ii\n\r"); - - printf("ii q p qr _p qr _p qr _p qr _p qr _p qr _p q p ii\n\r"); - nb1(2); - printf("ii _q pr q p q p q p q p q p q p q p ii\n\r"); - printf("ii _q pr _q pr _q pr _q pr _q pr _q pr _q pr ii\n\r"); - printf("ii 1 2 3 4 5 6 YOU ii\n\r"); - printf("ii ii\n\r"); - rptc('i', 77); - printf("\033G\033q"); - } - -sleep(n) - { int i; - while (n--) for (i=12000; i--;); } - -dmove(new,move) char *new,move; -{ int i; - int j; - int who; - if ((move < 1) || (move > 13) || (move == 7) || !new[move]) - printf("Bad arg to mmove: %d",move); - who = (move < 7 ? 1 : 0); - i = new[move]; - for (j = 0; j < i; j++) decpit(new,move); - sleep(1); - while (i--) { - move = mod(move,who); - incpit(new,move); - putchar(7); - sleep(1); - } - if (new[move] == 1 && who == (move < 7 ? 1 : 0) && move && move != 7) - while(new[14-move]) { - decpit(new,14-move); - incpit(new,who*7); - } - if (move == 0 || move == 7) return(0); - else return(1); -} - - -mmove(old,new,move) char *old; char *new; int move; -{ - int i; - int who; - total++; - - for (i = 0; i < 14; ++i) new[i] = old[i]; - if ((move < 1) || (move > 13) || (move == 7) || !new[move]) - printf("Bad arg to mmove: %d",move); - who = (move < 7 ? 1 : 0); - i = old[move]; - new[move] = 0; - while (i--) { - move = mod(move,who); - ++new[move]; - } - if (new[move] == 1 && who == (move < 7 ? 1 : 0) && move && move != 7) - { - new[who*7] += new[14-move]; - new[14-move] = 0; - } - if (move == 0 || move == 7) return(0); - else return(1); -} - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/STONE.COM b/software/CPM/CPM_MC_C1/STONE.COM deleted file mode 100644 index 614c172..0000000 Binary files a/software/CPM/CPM_MC_C1/STONE.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C1/STONE.CRL b/software/CPM/CPM_MC_C1/STONE.CRL deleted file mode 100644 index a353ba1..0000000 Binary files a/software/CPM/CPM_MC_C1/STONE.CRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C1/TC.ASM b/software/CPM/CPM_MC_C1/TC.ASM deleted file mode 100644 index 4fef3ac..0000000 --- a/software/CPM/CPM_MC_C1/TC.ASM +++ /dev/null @@ -1,2492 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;; COPYRIGHT 1977, TINY-C ASSOCIATES ;;;;;;;;;;;;;;;;;; -;;;;;; ALL RIGHTS RESERVED ;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ORG ($+100H)/100H*100H ;go to round address -LCFIX EQU 20H ;maps literals to lower case -;error codes -STATERR EQU 1 -CURSERR EQU 2 -SYMERR EQU 3 -RPARERR EQU 5 -RANGERR EQU 6 -CLASERR EQU 7 -SYNXERR EQU 9 -LVALERR EQU 14 -PUSHERR EQU 16 -TMFUERR EQU 17 -TMVRERR EQU 18 -TMVLERR EQU 19 -LINKERR EQU 20 -ARGSERR EQU 21 -LBRCERR EQU 22 -MCERR EQU 24 -SYMERRA EQU 26 -KILL EQU 99 -;recognition length of symbols -VLEN EQU 8 -;where tc exits to. -TCEXIT EQU 0000H -;end-of-line character -ASCRET EQU 0DH -; -;entry points - JMP COLD - JMP WARM - JMP HOT -;tailoring vector -ECHO DB 0 ;zero suppresses char echo -INCH JMP 0103h -OUTCH JMP 0106h -CHRDY JMP 0109h -FOPEN JMP 010Ch -FREAD JMP 010Fh -FWRITE JMP 0112h -FCLOSE JMP 0115h -USERMC JMP 0118h -PRBEGIN NOP - NOP - RET -STBEGIN NOP - NOP - RET -PRDONE NOP - NOP - RET -;MC tools -XMCESET JMP MCESET -XTOPTOI JMP TOPTOI -XPUSHK JMP PUSHK -MCARGS DB 0 -;escape character -ESCAPE DB 1BH -;space allocation -BSTACK DW 1A00H -ESTACK DW -1A80H -BFUN DW 1A80H -EFUN DW -1B00H -BVAR DW 1B00H -EVAR DW -2200H -BPR DW 2200H -EPR DW -4CF0H -MSTACK DW 1A00H -;standard cells -ERR DW 0 -ERRAT DW 0 -LEAVE DB 0 -BRAKE DB 0 -TOP DW 0 -NXTVAR DW 0 -CURFUN DW 0 -CURGLBL DW 0 -FNAME DW 0 -LNAME DW 0 -STCURS DW 0 -CURSOR DW 0 -PRUSED DW 0 -PROGEND DW 0 ;stored negative -APPLVL DB 0 -; -;literals -BALPHS EQU $ ;beginning of alphabetics -XIF DB LCFIX + 'i' - DB LCFIX + 'f' - DB 0 -XELS DB LCFIX + 'e' - DB LCFIX + 'l' - DB LCFIX + 's' - DB LCFIX + 'e' - DB 0 -XINT DB LCFIX + 'i' - DB LCFIX + 'n' - DB LCFIX + 't' - DB 0 -XCHAR DB LCFIX + 'c' - DB LCFIX + 'h' - DB LCFIX + 'a' - DB LCFIX + 'r' - DB 0 -XWHI DB LCFIX + 'w' - DB LCFIX + 'h' - DB LCFIX + 'i' - DB LCFIX + 'l' - DB LCFIX + 'e' - DB 0 -XRET DB LCFIX + 'r' - DB LCFIX + 'e' - DB LCFIX + 't' - DB LCFIX + 'u' - DB LCFIX + 'r' - DB LCFIX + 'n' - DB 0 -XBRK DB LCFIX + 'b' - DB LCFIX + 'r' - DB LCFIX + 'e' - DB LCFIX + 'a' - DB LCFIX + 'k' - DB 0 -XENDL DB LCFIX + 'e' - DB LCFIX + 'n' - DB LCFIX + 'd' - DB LCFIX + 'l' - DB LCFIX + 'i' - DB LCFIX + 'b' - DB LCFIX + 'r' - DB LCFIX + 'a' - DB LCFIX + 'r' - DB LCFIX + 'y' - DB 0 -XR DB LCFIX + 'r' ;loader 'read' command -XG DB LCFIX + 'g' ;'go' command - DB 0FFH ;end of alphabetics -LB DB '[' - DB 0 -RB DB ']' - DB 0 -LPAR DB '(' - DB 0 -RPAR DB ')' - DB 0 -COMMA DB ',' - DB 0 -NEWLINE DB ASCRET - DB 0 -CMNT DB '/' -XSTAR DB '*' - DB 0 -SEMI DB ';' - DB 0 -XPCNT DB '%' - DB 0 -XSLASH DB '/' - DB 0 -XPLUS DB '+' - DB 0 -XMINUS DB '-' - DB 0 -LT DB '<' - DB 0 -GT DB '>' - DB 0 -NOTEQ DB '!' - DB '=' - DB 0 -EQEQ DB '=' -XEQ DB '=' - DB 0 -GE DB '>' - DB '=' - DB 0 -LE DB '<' - DB '=' - DB 0 -XNL DB ASCRET - DB 0 -;EQ performs an assignment of top into top-1. Top-1 -; must be an lvalue. -EQ CALL TOPTOI ;value into DE - PUSH D ;stuff to be assigned - CALL POPST ;where to assign - ORA A - JZ EQ2 ;if class>0 set size=2 - MVI C,2 -EQ2 MOV A,B ;must be lvalue - CPI 'L' - JNZ EQERR - XCHG ;where -> HL - POP D ;stuff -> DE - MOV M,E ;assign lo byte - DCR C ;size-- - JZ PUSHK ;call/ret, put result on stack - INX H - MOV M,D ;hi byte - JMP PUSHK ;call/ret, put result on stack -EQERR CALL ESET - DB LVALERR - POP D - JMP PUSHK ;skip the assign part -; -;-(BC) -> BC -DNEG MOV A,C - CMA - MOV C,A - MOV A,B - CMA - MOV B,A - INX B - RET -; -;difference between two top values -> DE, setting Z, CY -TOPDIF CALL POPTWO ;hence fall into DSUB. -; -; (DE) - (BC) -> DE -DSUB MOV A,E - SUB C - MOV E,A - MOV A,D - SBB B - MOV D,A - ORA E ;Z now set, CY clear - MOV A,D - RLC ;sign is now in CY - RET -; -; (BC) + (DE) -> DE -DADD MOV A,C - ADD E - MOV E,A - MOV A,B - ADC D - MOV D,A - ORA E ;Z now set. CY cleared. - MOV A,D - RLC ;Sign is now in CY, Z not hurt. - RET -; -; (BC) * (DE) -> DE -DMPY LXI H,0 -DM2 MOV A,C ;test lo bit of BC - RRC - JNC DM3 - DAD D ;add multiplier -DM3 CALL BCRS ;shift BC right - JNZ DM4 ;return if BC is 0 - XCHG ;answer -> DE - RET -DM4 CALL DELS ;shift multiplier left, return - JNZ DM2 ; if zero. - XCHG - RET -; -; shift BC right, setting Z if 0. -BCRS XRA A ;zero CY flag - MOV A,B - RAR - MOV B,A - MOV A,C - RAR ;picks up carry left by hi byte - MOV C,A - ORA B - RET -; shift DE left. Sets z iff (DE)==0. -DELS XRA A ;zero CY flag -; rotate DE left, CY -> lo bit -RDEL MOV A,E ;lo byte first - RAL - MOV E,A - MOV A,D - RAL ;picks up carry left by lo byte - MOV D,A - ORA E - RET -; -; (DE) % (BC) -> DE, quotient in HL. -DREM MOV A,D ;sign of result -> stack - XRA B - PUSH PSW - MOV A,D ;make factors positive - ORA A - CM DENEG - MOV A,B - ORA A - CM DNEG - MVI A,16 ;shift count -> stack - PUSH PSW - XCHG ;numerator -> HL - LXI D,0 ;partial remainder -> DE -DR2 CALL HLLS ;divide loop. Long left shift - CALL RDEL ; DEHL. - JZ DR3 - CALL DCMP ;test BC <= DE - JM DR3 - MOV A,L ;set lo bit of L, and subtract - ORI 1 ; divisor from partial - MOV L,A ; remainder - CALL DSUB -DR3 POP PSW ;decrement shift count - DCR A - JZ DR4 - PUSH PSW - JMP DR2 -DR4 POP PSW ;put sign on quotient and rem - RP - CALL DENEG - XCHG - CALL DENEG - XCHG - RET -; -; (DE) / (BC) -> DE -DDIV CALL DREM - XCHG - RET -; -; -(DE) -> DE -DENEG MOV A,D - CMA - MOV D,A - MOV A,E - CMA - MOV E,A - INX D - RET -; -;double compare (DE) - (BC) changing neither, but -; setting s, cy -; Note that z is not set reliably. -DCMP MOV A,E - SUB C - MOV A,D - SBB B - RET -; -;HL left shift -HLLS DAD H - RET -; -;@@@@@@@@ stack tools @@@@@@@@@@ -; -;TOPTOI pops top of stack into DE, converting lvalue -; to actual if necessary. -TOPTOI CALL POPST ;class in A, lvalue in B, - STA TPCLASS ; size in C, stuff in DE - MOV A,B - CPI 'A' - JZ TT2 - XCHG ;fetch data - MOV E,M - INX H - MOV D,M -TT2 DCR C ;if size 1 and class 0 return - RNZ ; lo byte, with sign propgated - LDA TPCLASS ; thru hi byte. - ORA A - RNZ - MOV A,E - RLC ;propogate sign into D. - SBB A - MOV D,A - RET -TPCLASS DB 0 -; -;pops two from stack, top -> bc, next -> de. -POPTWO CALL TOPTOI - PUSH D - CALL TOPTOI - POP B - RET -; -;pops the stack into A, B, C, DE. New top in HL. -POPST LHLD TOP - MOV A,M ;class - INX H - MOV B,M ;lvalue - INX H - MOV C,M ;size - INX H - MOV E,M ;stuff, lo-byte - INX H - MOV D,M ;stuff, hi-byte - PUSH B - LXI B,-9 - DAD B ;decrement top by 5. - POP B - SHLD TOP - RET -; -;pushes constant 1. -PONE LXI D,1 - JMP PUSHK -;pushes constant 0. -PZERO LXI D,0 -;pushes constant in DE -PUSHK XRA A ;class 0 - MVI B,'A' ;actual - MVI C,2 ;2 byte size -;pushes class (A), lvalue (B), size (C), stuff (DE) -; onto stack. -PUSHST LHLD TOP ;add 5 to top. - PUSH D - LXI D,5 - DAD D - SHLD TOP - XCHG - LHLD ESTACK - DAD D - XCHG ;top -> HL - POP D ;restore stuff - JC PERR - MOV M,A - INX H - MOV M,B - INX H - MOV M,C - INX H - MOV M,E - INX H - MOV M,D - RET -PERR CALL ESET - DB PUSHERR - RET -; -; @@@@@@@@ ESET sets ERR unless one is already set @@@@ -ESET LDA ERR - XTHL - ORA A - JZ ES2 - INX H - XTHL - RET -ES2 MOV A,M - INX H - XTHL - STA ERR - LHLD CURSOR - SHLD ERRAT - RET -; -;store 0's from (DE) thru (HL) inclusive -ZERO MVI B,0 -;store (B) from (DE) thru (HL) inclusive -BZAP MOV A,L - SUB E - MOV A,H - SBB D - RC - MOV M,B - DCX H - JMP BZAP -; -;print string starting at (HL), terminated by null byte -PS MOV A,M - ORA A - RZ - CALL OUTCH - INX H - JMP PS -; -;@@@@@@@@@ SCAN TOOLS @@@@@@@@@@@@ -; -;LIT is used to match literals. It advances the cursor -; over blanks, then attempts a match with the literal. -; DE points to the literal, which is terminated by a -; null byte. On match, the cursor is advanced -; beyond the matched text, and NZ is set. On no match -; the cursor is not advanced (except over the initial -; blanks), and Z is set. LIT is called often, so some -; attention to speed is given, mainly by using inline -; code for blanks and string matching. -LIT LHLD CURSOR - MVI A,' ' ;trim blanks -LIT2 CMP M - JNZ LIT3 - INX H - JMP LIT2 -LIT3 SHLD CURSOR ;capture cursor, in case no mch -LIT4 LDAX D ;char from literal - ORA A - JZ MATCH ;null signals end of literal - CMP M ;char from program - INX D - INX H - JZ LIT4 - XRA A ;no match, return Zero - ORA A - RET -MATCH SHLD CURSOR ;capture new cursor - CMA ;return Not Zero - ORA A - RET -; -;advances cursor over blanks. Puts cursor in HL. -BLANKS LHLD CURSOR - MVI A,' ' -LOOP CMP M - JNZ BLOUT - INX H - JMP LOOP -BLOUT SHLD CURSOR - RET -; -;skips over balanced l-r delimiters, (assuming the -;first l delimiter is already matched.) Tests that -;cursor stays within program limits, and sets ERR and -;doesn't advance cursor on violation. -SKIP MVI D,1 ;counter -SK2 MOV A,M - CMP B - JZ SKL ;match left delimiter - CMP C - JNZ SKNEXT - DCR D ;match right delimiter - JNZ SKNEXT - INX H ;all done, bump over last - SHLD CURSOR ; matched. - STC - CMC ;CY off on success - RET -SKL INR D -SKNEXT INX H ;bump HL, test for overflow - XCHG ;cursor -> DE - PUSH H ;make H safe - LHLD PROGEND ;stored negative, so add - DAD D - POP H - XCHG ;now all reg's restored - JNC SK2 - CALL ESET - DB CURSERR - STC ;CY set on error - RET -; -;tests if (A) is alphanumeric. Plus on yes. -ALNUM CPI '0' - RM - CPI '9'+1 - JM YESA -;tests if (A) is alpha. Plus on yes. -ALPHA CPI 'A' - RM ;not alpha - CPI 'Z'+1 - JM YESA - CPI LCFIX + 'a' - RM - CPI LCFIX + 'z'+1 - JM YESA - CMA ;not alpha, this sets Minus. - ORA A - RET -YESA XRA A ;set Plus. - RET -; -;matches a variable or function name. Sets FNAME, -; LNAME to first and last chars of the name. Returns -; Not Zero on match, Zero on no match. -SYMNAME CALL BLANKS - SHLD FNAME - MOV A,M - CALL ALPHA - JM SY3 -SY2 INX H ;is a symbol, find its end. - MOV A,M - CALL ALNUM - JP SY2 - SHLD CURSOR ;just beyond symbol - DCX H - SHLD LNAME ;symbol end - RET -SY3 XRA A ;no symbol, return Z - RET -; -;matches 3 kinds of constants, setting FNAME, LNAME as -; in SYMNAME. Sets A to 0 on no match, 1,2,or 3 on mch -CONST CALL BLANKS - MOV A,M ;first char - CPI '+' ;test for number - JZ CN2 - CPI '-' - JZ CN2 - CPI '0' - JM CN3 - CPI '9'+1 - JP CN3 -CN2 SHLD FNAME ;number, cursor to fname -CN4 INX H ;find end - MOV A,M - CPI '0' - JM CN5 - CPI '9'+1 - JM CN4 ;is a digit, keep going -CN5 SHLD CURSOR ;not a digit - DCX H - SHLD LNAME - MVI A,1 ;type 1 constant (integer) - RET -CN3 CPI '"' ;test for quoted string - JNZ CN6 - INX H ;quote found - SHLD FNAME ;first char of string (quote -CN7 MOV A,M ; excluded - ORA A ;ended by either null or " - JZ CN8 - SBI '"' - JZ CN8 - INX H - XCHG ;cursor check - LHLD PROGEND - DAD D - XCHG - JNC CN7 - JMP CNERR ;cursor overflow -CN8 MOV M,A ;end quote found, replace with - DCX H ; a null. - SHLD LNAME ;last char of string - MVI A,2 ;constant of type 2 (char str) - ORA A - INX H - INX H - SHLD CURSOR - RET -CN6 CPI 27H ;test for prime - JNZ CN9 - INX H - SHLD FNAME -CN12 MOV A,M ;scan for matching prime - CPI 27H - JZ CN11 - INX H - XCHG ;cursor check - LHLD PROGEND - DAD D - XCHG - JNC CN12 - JMP CNERR -CN11 MVI A,3 ;found matching prime - ORA A - INX H - SHLD CURSOR - RET -CN9 XRA A ;no match - RET -CNERR CALL ESET - DB CURSERR - RET -; -;skips over remarks and/or end-of-lines in any order. -REM LXI D,NEWLINE - CALL LIT - JZ RE2 -RE3 MOV A,M ;skip linefeeds - CPI 0AH - JNZ REM - INX H - SHLD CURSOR - JMP REM -RE2 LXI D,CMNT - CALL LIT - RZ - MVI B,1 ;comment found, skip its text - MVI C,ASCRET - CALL SKIP - RC ;error check - JMP RE3 -; -;HL points to start of digit string. Converts to intger -; leaving result in DE. Uses all digits, even if DE -; overflows. First nondigit stops scan. -ATON XCHG ;pointer into DE - LXI H,0 ;answer developed here -AN2 LDAX D ;next ascii - SUI 48 - JC AN3 ;test for digit - CPI 10 - JNC AN3 - MOV B,H ;digit, set HL=10*HL+A - MOV C,L - DAD H - DAD H - DAD B - DAD H - MOV C,A - MVI B,0 - DAD B - INX D ;bump pointer - JMP AN2 -AN3 XCHG ;answer -> DE - RET -; -;HL points to beginning of ascii integer, possibly -; signed. Converts to integer and leaves value in DE. -AISGN DB 0 ;nonzero for - -ATOI XRA A - STA AISGN -AI6 MOV A,M ;skip blanks - CPI ' ' - JNZ AI2 - INX H - JMP AI6 -AI2 CPI '-' ;test sign - JNZ AI3 - STA AISGN ;is - - INX H -AI3 CPI '+' - JNZ AI4 - INX H -AI4 MOV A,M ;skip more blanks - CPI ' ' - JNZ AI5 - INX H - JMP AI4 -AI5 CALL ATON ;does the digits - LDA AISGN ;magnitude in DE - ORA A - RZ - JMP DENEG ;computes negative and returns -; -;@@@@@@@@@ SYMBOL TOOLS @@@@@@@@@@@ -; -;allocate reference in FUNB for variables of a function -NEWFUN LHLD CURFUN - LXI D,6 ;bump CURFUN by 6 - DAD D - SHLD CURFUN - XCHG ;test too many active functions - LHLD EFUN - DAD D - XCHG - JNC NF2 - CALL ESET - DB TMFUERR - RET -NF2 LDA NXTVAR ;init first and last var - MOV M,A ;fv lo byte - SUI 6+VLEN - MOV C,A ;lv lo byte -> C for now - LDA NXTVAR+1 - INX H - MOV M,A ;fv hi byte - SBI 0 ;picks up possible carry - INX H - MOV M,C ;lv lo byte - INX H - MOV M,A ;lv hi byte - LDA PRUSED ;now set up backup pointer - INX H - MOV M,A ;bu lo byte - LDA PRUSED+1 - INX H - MOV M,A ;bu hi bytv - RET ;all done -; -;deallocate variables of last function. -FUNDONE LHLD CURFUN - MOV A,M - STA NXTVAR ;lo byte - INX H - MOV A,M - STA NXTVAR+1 - INX H - INX H - INX H - MOV A,M - STA PRUSED - INX H - MOV A,M - STA PRUSED+1 - LXI D,-11 - DAD D ;subtract 5 for above INX's, - SHLD CURFUN ; plus 5 more to pop FUNB. - RET -; -;allocate a variable. Class in A, size in B, len in DE, -; passed value in HL. -CLASS DB 0 ;temps used by newvar -OBSIZE DB 0 -PASSED DW 0 -LEN DW 0 -FVAL DW 0 -KF DW 0 -; -NEWVAR STA CLASS - MOV A,B - STA OBSIZE - SHLD PASSED - XCHG - SHLD LEN - LHLD NXTVAR - CALL CANON ;put canonical form of name -; into (NXTVAR). Leaves HL -; pointing to last byte of NAME of VARB. - INX H ;-> CLASS in VARB. - LDA CLASS - MOV M,A - INX H ;-> OBJSIZE in VARB. - LDA OBSIZE - MOV M,A - INX H ;-> LEN in VARB (2 bytes). - LDA LEN - MOV M,A - INX H - LDA LEN+1 - MOV M,A - INX H - SHLD FVAL ;address where fval will be put - LDA CLASS - ORA A ;if class is 0, or not a passed - JZ NR2 ; arg, then get value space. - LHLD PASSED - MOV A,L - ORA H - JNZ NR3 -NR2 LHLD PRUSED ;get value space - INX H ; starting at PRUSED + 1 - SHLD KF ;Put in KF for later use. - XCHG - LHLD FVAL - MOV M,E - INX H - MOV M,D ;fval part of varb set to - LHLD LEN ; prused+1. Now bump prused - XCHG ; by obsize*len. - LHLD PRUSED - LDA OBSIZE - DAD D - DCR A - JZ NR7 - DAD D -NR7 SHLD PRUSED - XCHG ;test if allocation exceeds - LHLD EPR ; limits of prog space. - DAD D - XCHG - JNC NR4 - CALL ESET ;RAM exceeded - DB TMVLERR - RET -NR4 LHLD KF ;zero the allocated space - XCHG - LHLD PRUSED - CALL ZERO - JMP NR5 ;end of space allocation -NR3 LHLD FVAL ;Value is passed and is a - LDA PASSED ; class > 0. Put value in fval - MOV M,A ; part of VARB. Dont allocate - INX H ; space. - LDA PASSED+1 - MOV M,A - JMP NR6 -NR5 LDA CLASS ;if passed & class is 0 move - ORA A ; the passed value into the - JNZ NR6 ; allocated space. - LHLD PASSED - MOV A,H - ORA L - JZ NR6 - XCHG ;passed -> DE - LHLD KF - MOV M,E ;lo byte of passed value - INX H - MOV M,D ;hi byte, or junk if only one -; byte passed. Who cares. -NR6 LHLD CURFUN ;in FUNB set lvar part to this - INX H ; variable. - INX H - LDA NXTVAR - MOV M,A - INX H - LDA NXTVAR+1 - MOV M,A - LHLD NXTVAR ;increment NXTVAR - LXI D,6+VLEN ; by 6 + vlen - DAD D - SHLD NXTVAR - XCHG ;test if too many variables - LHLD EVAR - DAD D - XCHG - LHLD FVAL - RNC ;normal return, FVAL in HL. - CALL ESET ;VARB exceeded. - DB TMVRERR - RET -; -;ADDRVAL looks up a symbol pointed to by FNAME,LNAME. -; Returns address in HL, class in A, size in B, and -; length in DE. Sets err if symbol cannot be found. -; Searches 3 areas: -; area 0 locals -; 1 globals -; 2 library symbols -NAME DS VLEN ;holds canonical form of name -PVAR DW 0 -AREA DB 0 -SFUN DW 0 -LAST DW 0 -; -ADDRVAL LHLD CURFUN - SHLD SFUN ;search locals first - LXI H,NAME - CALL CANON - XRA A - STA AREA ;area 0 -AD8 LHLD SFUN ;variable search area - MOV E,M - INX H - MOV D,M ;fvar of search area -> DE - INX H - MOV C,M - INX H - MOV B,M ;lvar -> BC - XCHG - SHLD PVAR ;currently searched variable - MOV H,B - MOV L,C - SHLD LAST ;last to search in this area - LHLD PVAR ;begin search loop -AD2 LDA LAST ;test for end of loop - SUB L - LDA LAST+1 - SBB H - JC AD3 - MVI C,VLEN ;number of chars to match - LXI D,NAME ;match string address -AD4 LDAX D ;(HL already as table entry) - CMP M - JNZ AD5 ;no match - DCR C - INX D - INX H - JNZ AD4 ;next char - MOV A,M ;MATCH. HL points to class. - INX H - MOV B,M ;obsize - INX H - MOV E,M - INX H - MOV D,M ;length - INX H - ORA A ;if class > 0 & class < 'E' - JZ AD9 ; then return address of fval - CPI 'E' ; part of VARB, which is alrdy - RNZ ; in HL. -AD9 PUSH D ;otherwise return contents of - MOV E,M ; fval part of VARB. - INX H - MOV D,M - XCHG - POP D - RET -AD5 LHLD PVAR ;go to next variable - LXI D,VLEN+6 - DAD D - SHLD PVAR - JMP AD2 -AD3 LDA AREA ;go to next area - ORA A - JNZ AD6 - LHLD CURGLBL ;second search area, globals -AD7 SHLD SFUN - INR A - STA AREA - JMP AD8 -AD6 CPI 2 - JP ADERR - LHLD BFUN ;third area is library, which - JMP AD7 ; is at beginning of FUNB. -ADERR CALL ESET - DB SYMERRA - RET -; -;canonicalizes symbol from FNAME to LNAME inclusive, -; putting form with VLEN chars in (HL). -OUTNAME DW 0 -CANON SHLD OUTNAME - MVI A,VLEN ;zero output field - MVI B,0 - MOV C,B ;zero C for later -CA2 MOV M,B - DCR A - JZ CA3 - INX H - JMP CA2 -CA3 PUSH H ;save pointer to last byte - LHLD FNAME ;compute symbols actual length - LDA LNAME - SUB L - INR A - CPI VLEN - JM CA6 - MVI A,VLEN ;A now has number of chars to - MOV C,A ; be moved, and C is nonzero -CA6 XCHG ; iff act len > VLEN. - MOV B,A - LHLD OUTNAME ;FNAME -> DE, OUTNAME -> HL -CA4 LDAX D ;copy loop - MOV M,A - DCR B - JZ CA5 - INX D - INX H - JMP CA4 -CA5 POP H ;pointer to last byte - XRA A - ORA C ;test if short name - RZ - XCHG ;long name, put last char in - LHLD LNAME ; the canon form. - MOV A,M ;last char of name - XCHG - MOV M,A ;into last pos of outname - RET -;ASGN is the expression evaluator,so called because -; the highest form of an expression is an assignment. -; An asgn is a reln or an lvalue = asgn. Note that -; reln can match an lvalue. -;Returns non-zero if valid expression, 0 if invalid. -ASGN CALL RELN ;stacked as lvalue if that's -; what it is. - LXI D,XEQ ; test for = - CALL LIT - JZ A2 - CALL ASGN - LDA ERR ;check for error - ORA A - CZ EQ ;perform assignment -A2 LDA ERR ;return 0 (i.e. no match) if - ORA A ; there was an error - JZ A3 - XRA A - RET -A3 DCR A ;no error so return non-zero A - RET -; -;a RELN is an expr or a comparison of exprs -RELN CALL EXPR - LXI D,LE ; <= - CALL LIT - JZ R2 - CALL EXPR ;right side - CALL TOPDIF ;sets Z,C flags. C set as - JZ PONE ; though it were S. Must be - JC PONE ; zero or negative for true. - JMP PZERO ;These jumps all call/rets. -R2 LXI D,GE ; >= - CALL LIT - JZ R3 - CALL EXPR - CALL TOPDIF - JZ PONE - JNC PONE - JMP PZERO -R3 LXI D,EQEQ ; == - CALL LIT - JZ R4 - CALL EXPR - CALL TOPDIF - JZ PONE - JMP PZERO -R4 LXI D,NOTEQ - CALL LIT - JZ R5 - CALL EXPR - CALL TOPDIF - JNZ PONE - JMP PZERO -R5 LXI D,GT ; > - CALL LIT - JZ R6 - CALL EXPR - CALL TOPDIF - JZ PZERO - JC PZERO - JMP PONE -R6 LXI D,LT ; < - CALL LIT - RZ ; no relational operator - CALL EXPR - CALL TOPDIF - JC PONE - JMP PZERO -; -;an EXPR is a term or sum (diff) of terms. -EXPR LXI D,XMINUS ; unary - - CALL LIT - JZ EX2 - CALL TERM - CALL TOPTOI ;push negative of top back onto - MOV A,E - CMA - MOV E,A - MOV A,D - CMA - MOV D,A - INX D - CALL PUSHK - JMP EX3 -EX2 LXI D,XPLUS ;optional unary + - CALL LIT - CALL TERM -;first term is now stacked. Check for error so far. -EX3 LDA ERR - ORA A - RNZ - LXI D,XPLUS ; + - CALL LIT - JZ EX4 - CALL TERM - CALL POPTWO ;top two values on stack are -; actualized and put into -; (BC) and (DE). - CALL DADD ; (BC)+(DE)->(DE) - CALL PUSHK ; sum onto stack. - JMP EX3 ;back for more terms -EX4 LXI D,XMINUS ; - - CALL LIT - RZ ;no more terms - CALL TERM - CALL POPTWO - CALL DSUB - CALL PUSHK - JMP EX3 ;back for more terms. -; -;a term is a factor or a product of factors. -TERM CALL FACTOR -TE2 LDA ERR ;check for error so far - ORA A - RNZ - LXI D,XSTAR ; * - CALL LIT - JZ TE3 - CALL FACTOR - CALL POPTWO - CALL DMPY - CALL PUSHK - JMP TE2 ;back for more factors. -TE3 CALL REM ;make sure no /* - LXI D,XSLASH ; / - CALL LIT - JZ TE4 - CALL FACTOR - CALL POPTWO - CALL DDIV - CALL PUSHK - JMP TE2 -TE4 LXI D,XPCNT ; % - CALL LIT - RZ ;no more factors. - CALL FACTOR - CALL POPTWO - CALL DREM - CALL PUSHK - JMP TE2 -; -;a FACTOR is a ( asgn ), or a constant, or a variable -; reference, or a function reference. -FACTOR LXI D,LPAR ; ( - CALL LIT - JZ FA2 - CALL ASGN - LXI D,RPAR ; ) - CALL LIT - RNZ - CALL ESET ;right paren error - DB RPARERR - RET -FA2 CALL CONST ;recognizes 3 types of constant - JZ FA5 ; setting A accordingly. - CPI 1 - JNZ FA3 - LHLD FNAME ;type 1: integer. FNAME points - CALL ATOI ; to beginning. ATOI converts - JMP PUSHK ; it, leaving value in (DE). -FA3 CPI 2 - JNZ FA4 - MVI A,1 ;type 2: char string. Push - MVI B,'A' ; class=1, lval='A', size=1, - MVI C,1 ; and stuff=address of - LHLD FNAME ; beginning of string. - XCHG - JMP PUSHST -FA4 XRA A ;type 3: char constant. Push - MVI B,'A' ; class=0, lval='A', size=1, - MVI C,1 ; and stuff=actual character. - LHLD FNAME - MOV E,M - JMP PUSHST -FA5 CALL SYMNAME ;not a constant, try symbol. - JZ FA6 - LHLD FNAME ;symbol. Test for special - INX H ; symbol MC. First is symbol - LDA LNAME ; length exactly 2. - CMP L - JNZ FA7 - LDA LNAME+1 - CMP H - JNZ FA7 - MOV A,M ;length is 2, and (HL)=FNAME. - CPI 'C' - JNZ FA7 - DCX H - MOV A,M - CPI 'M' - JNZ FA7 - LXI H,0 - JMP ENTER ;causes machine call. -FA7 CALL ADDRVAL ;not MC, look up symbol. - SHLD FWHERE - STA CLASS - MOV A,B ;save results of lookup. - STA OBSIZE - XCHG - SHLD LEN - MOV A,D ;where is now in DE - ORA E - JZ FA8 - LDA CLASS - CPI 'E' ;class E => function entry - JZ FA9 - LXI D,LPAR ;variable. Test for subscript. - CALL LIT - JZ FA10 - LDA CLASS ;subscripted, class must be > 0 - DCR A - STA CLASS ;class of element is one less - JP FA11 ; than class of array. - CALL ESET - DB CLASERR - RET -FA11 LHLD FWHERE ;replace where by two bytes - MOV E,M ; referenced by where. - INX H - MOV D,M - PUSH D ;save where, len, class, - LHLD LEN ; obsize. - PUSH H - LHLD CLASS ;(also gets obsize) - PUSH H - CALL ASGN ;evaluate subscript - POP H - SHLD CLASS ;restore everything - POP H - SHLD LEN - POP H - SHLD FWHERE - RZ ;assign error - LXI D,RPAR ;skip ) - CALL LIT - CALL TOPTOI ;subscript value -> DE - XCHG - SHLD SUBSCR - XCHG - LHLD LEN - MOV A,L - DCR A - ORA H ;for LEN = 1 skip subscript - JZ FA12 ; check. - LDA CLASS - ORA A - JNZ FA12 ;skip for pointers, too. - ORA D - JM SUBERR ;cant be negative - MOV B,H ;len -> BC - MOV C,L - CALL DSUB - JC FA12 ;subscr-len must be negative -SUBERR CALL ESET - DB RANGERR -FA12 LHLD SUBSCR - XCHG ;where =+ subscr * obsize - LHLD FWHERE - LDA OBSIZE -FA13 DCR A - JM FA14 - DAD D - JMP FA13 -FA14 SHLD FWHERE -FA10 LDA OBSIZE ;push class, 'L', obsize, - MOV C,A ; stuff=where. - LDA CLASS - MVI B,'L' - LHLD FWHERE - XCHG - JMP PUSHST ;call/ret -FA9 LHLD FWHERE - JMP ENTER ;call/ret -FA8 CALL ESET ;symbol error - DB SYMERR - RET -FA6 CALL ESET ;cannot recognize factor - DB SYNXERR - RET -; -;locals used by ASGN, etc. -FWHERE DW 0 -SUBSCR DW 0 -;SKIPST skips over a (possibly compound) statement, -; including whole nested sets of if-then-elses. -; Assumes balanced [], even within comments. -SKIPST CALL REM - LXI D,LB ;test for [ - CALL LIT - JZ SS2 - MVI B,'[' - MVI C,']' - CALL SKIP - JMP REM ;and done -SS2 LXI D,XIF ;test for if or while - CALL LIT - JNZ SS6 - LXI D,XWHI - CALL LIT - JZ SS3 -SS6 LXI D,LPAR - CALL LIT - MVI B,'(' - MVI C,')' - CALL SKIP ;skip over (condition) part - CALL SKIPST ;skip then part - LXI D,XELS ;test for ELSE - CALL LIT - CNZ SKIPST ;skip else part - JMP REM ;and done -SS3 LHLD CURSOR ;simple statement, move cursor -SS4 MOV A,M ; past next ; or return. - CPI ASCRET - JZ SS8 - CPI ';' - JZ SS5 - INX H - XCHG ;test cursor overflow - LHLD PROGEND - DAD D - XCHG - JNC SS4 - JMP REM ;and done -SS5 INX H -SS8 SHLD CURSOR - JMP REM ;and done -; -;VALLOC parses one variable behind INT or CHAR and -; makes allocation and symbol entry. -TYPE DB 0 ;'C' or 'I' -VPASSED DW 0 ;0 for global or local, two -; byte value if param to fnction -; It turns out a 0 valued parameter gets the same -; treatment as a local. -VCLASS DB 0 ;defined in globals section. -ALEN DW 0 ;elements in an array. -; -VALLOC STA TYPE - SHLD VPASSED - CALL SYMNAME ;sets FNAME, LNAME around symbl - JZ V2 ;error if no symbol. - XRA A - STA VCLASS ;assume class 0 (not an array) - LXI D,LPAR - CALL LIT - JZ V3 - LHLD FNAME ;array, evaluate subscript - PUSH H ; expression. Must push FNAME, - LHLD LNAME ; LNAME, and class, because - PUSH H ; subscripts may invoke - LDA VCLASS ; functions which themselves - INR A ; allocate variables. - PUSH PSW - CALL ASGN - POP PSW ;restore pushed stuff. - STA VCLASS - POP H - SHLD LNAME - POP H - SHLD FNAME - LDA ERR ;test for error in ASGN - ORA A - RNZ - LXI D,RPAR - CALL LIT ;skip ) - CALL TOPTOI ;value of subscript + 1 into - INX D ; LEN - XCHG - SHLD ALEN - JMP V5 -V3 LXI H,1 ;non-subscripted variable - SHLD ALEN ; has ALEN 1. -V5 LDA TYPE ;object size is 1 of 'C', 2 for - MVI B,1 ; 'I' - CPI 'C' - JZ V7 - INR B ;obsize in B -V7 LDA VCLASS ;class in A - LHLD ALEN ;len in DE. - XCHG - LHLD VPASSED ;passed in HL - JMP NEWVAR ;call/ret, NEWVAR allocates the -; variable -V2 CALL ESET - DB SYMERR - RET -; -;@@@@@@@@@@ tiny - c interpreter @@@@@@@@@@@@ -; -;ST interprets a possibly compound statement -; -ST CALL QUIT ;test if program should quit. - LDA ERR - ORA A - RNZ - CALL REM ;pass over remarks and/or -; end of line - CALL STBEGIN ;bugout for blips, statistics, -; ; etc, user provided. -ST2 LHLD CURSOR ;capture cursor - SHLD STCURS - CALL DECL ;test for declaration - JNZ REM - LXI D,LB ;test for left bracket - CALL LIT - JZ TIF - CALL REM -CMPND LDA ERR ;compound statement. Execute - MOV B,A ; each of its inner stmnts. - LDA LEAVE ; Exit on error, leave, break, - ORA B ; or ] literal. - MOV B,A - LDA BRAKE - ORA B - RNZ - LXI D,RB ; ] - CALL LIT - JNZ REM ;and done - CALL ST ;recursive call to ST - JMP CMPND ;then do next statement. -TIF LXI D,XIF ;test for IF - CALL LIT - JZ TWHI - LXI D,LPAR ;skip ( - CALL LIT - CALL ASGN ;evaluate condition - RZ ;return on error - LXI D,RPAR ;skip ) - CALL LIT - CALL TOPTOI ;condition value - MOV A,D - ORA E - JZ IF2 - CALL ST ;true, execute conditional - LXI D,XELS ;skip else clause if there - CALL LIT - CNZ SKIPST - RET -IF2 CALL SKIPST ;false, skip conditional - LXI D,XELS ;execute else clause if there - CALL LIT - CNZ ST - RET -TWHI LXI D,XWHI ;test for WHILE - CALL LIT - JZ TSEM - LXI D,LPAR ;skip ( - CALL LIT - CALL ASGN ;condition - RZ ;return on error - LXI D,RPAR ;skip ) - CALL LIT - CALL TOPTOI ;condition value - MOV A,D - ORA E - JZ WH2 - LHLD STCURS ;true, save STCURS and CURSOR - PUSH H - LHLD CURSOR - PUSH H - CALL ST ;execute object of while - POP H ;saved cursor into OBJT - SHLD OBJT - POP H ; and stcurs into AGIN - SHLD AGIN - LDA BRAKE ;if a BREAK statement caused - ORA A ; this return, then set CURSOR - JZ WH3 ; to object of the while and - LHLD OBJT ; skip over it, and restore - SHLD CURSOR ; break. The WHILE is alllll - CALL SKIPST ; done. - XRA A - STA BRAKE - RET -WH3 LHLD AGIN ;Otherwise, set cursor back to - SHLD CURSOR ; beginning of while statement - RET ; and return, causing WHILE to -; to be done again. -WH2 CALL SKIPST ;If condition is false, skip - RET ; the object, and done. -TSEM LXI D,SEMI ;test for null statement - CALL LIT - JNZ REM ;and done -TRET LXI D,XRET ;test for RETURN statement - CALL LIT - JZ TBRK - LXI D,SEMI ;if ; or remark push a 0. - CALL LIT - JNZ TR2 - LXI D,XNL - CALL LIT - JNZ TR2 - CALL ASGN ;otherwise push return value - JMP TR4 -TR2 CALL PZERO -TR4 MVI A,1 ;set leave flag - STA LEAVE - RET -TBRK LXI D,XBRK ;test for BREAK - CALL LIT - JZ TASG - MVI A,1 ;set break flag - STA BRAKE - RET -TASG CALL ASGN ;if none of above, must be an - JZ STER ; expression, or an error. - CALL TOPTOI ;if an expression, discard its -; value. - LXI D,SEMI ;skip optional ; - CALL LIT - JMP REM ;and done -STER CALL ESET - DB STATERR ;statement error - RET -OBJT DW 0 ;points to object of while -AGIN DW 0 ;points to beginning of while -; -;DECL tests for and interprets declarations -DECL LXI D,XCHAR - CALL LIT ;test for CHAR - JZ TINT -CH2 MVI A,'C' - LXI H,0 - CALL VALLOC - LXI D,COMMA - CALL LIT - JNZ CH2 ;get all vars -CH3 LXI D,SEMI ;skip optional ; - CALL LIT - MVI A,07FH ;set flag to Not Zero - ORA A - RET -TINT LXI D,XINT - CALL LIT - RZ ;flag is zero -IN2 MVI A,'I' - LXI H,0 - CALL VALLOC - LXI D,COMMA - CALL LIT - JNZ IN2 - JMP CH3 -; -;catches interrupts (ESC key) at appl level. -QUIT LDA APPLVL - ORA A - RZ - CALL CHRDY - RZ - MOV B,A ;char keyed in -> B - LDA ESCAPE - CMP B - RNZ - CALL INCH ;discard the ESC - CALL ESET ;signal the escape - DB KILL - RET -; -;evaluates arguments of a function. Sets cursor to -; beginning of function's text. Parses its argument -; declarations, giving them values of the parameters. -; executes the function. Determines cause of exit, and -; pushes default 0 return value if needed. Restores -; cursor. -NARGS DB 0 ;number of args -WHERE DW 0 ;0 for MC, otherwise address of -; function. -ARG DW 0 ;pointer into stack to first -; arg. -ENTER SHLD WHERE - XRA A - STA NARGS - LHLD TOP - LXI D,5 - DAD D - SHLD ARG - LXI D,LPAR ;skip optional ( - CALL LIT - LXI D,RPAR ;test for no args, several ways - CALL LIT - JNZ ARGSDNE - LHLD CURSOR - MOV A,M - CPI ']' - JZ ARGSDNE - CPI ';' - JZ ARGSDNE - CPI ASCRET - JZ ARGSDNE - CPI '/' - JZ ARGSDNE -EN2 LDA ERR ;eval args, first test for err - ORA A - RNZ - LHLD ARG ;save locals - PUSH H - LHLD WHERE - PUSH H - LHLD NARGS - PUSH H - CALL ASGN ;evaluate - POP H ;restore locals - MOV A,L - POP H - SHLD WHERE - POP H - SHLD ARG - INR A ;increment NARGS - STA NARGS - LXI D,COMMA - CALL LIT ;comma means more args - JNZ EN2 - LXI D,RPAR ;optional ) - CALL LIT -ARGSDNE LDA ERR - ORA A - RNZ - LHLD WHERE ;test for MC - MOV A,H - ORA L - JNZ EN3 - LDA NARGS - CALL MC - RET -EN3 LHLD CURSOR ;save current cursor - PUSH H - LHLD STCURS - PUSH H - LHLD WHERE ;set cursor to start of fctn - SHLD CURSOR - CALL NEWFUN ;new layer of value space -EN4 CALL REM ;parse arg decls and pass value - LXI D,XINT ;works just like DECL, except - CALL LIT ; uses SETARG instead of - JZ EN5 ; VALLOC. -EN6 LHLD ARG - MVI B,'I' - CALL SETARG - LHLD ARG ;bump ARG pointer to next - LXI D,5 ; stack layer - DAD D - SHLD ARG - LXI D,COMMA - CALL LIT - JNZ EN6 - LXI D,SEMI - CALL LIT - JMP EN4 -EN5 LXI D,XCHAR - CALL LIT - JZ EN7 -EN8 LHLD ARG - MVI B,'C' - CALL SETARG - LHLD ARG - LXI D,5 - DAD D - SHLD ARG - LXI D,COMMA - CALL LIT - JNZ EN8 - LXI D,SEMI - CALL LIT - JMP EN4 -EN7 LHLD TOP ;test correct number of args - LXI D,5 - DAD D - LDA ARG ;should be TOP+5 - CMP L - JZ EN9 - POP D ;set up old cursor for - POP H ; the error call - SHLD CURSOR - PUSH H - PUSH D - CALL ESET - DB ARGSERR -EN9 LXI H,NARGS ;pop all args off stack - DCR M - JM EN11 - CALL POPST - JMP EN9 -EN11 LDA ERR ;if no errors, execute function - ORA A - CZ ST - LDA LEAVE ;push 0 if default leave - ORA A - CZ PZERO - XRA A ;zero LEAVE - STA LEAVE - POP H ;restore cvrsor - SHLD STCURS - POP H - SHLD CURSOR - CALL FUNDONE ;pop layer of value space - RET -; -;HL points into stack to an arg. B (used by VALLOC) is -; type. SETARG gets actual value of arg, calls VALLOC -; to allocate local space, which also puts arg value -; into allocated space. -SETARG PUSH B - MOV B,M ;class - INX H - MOV A,M ;lvalue - INX H - MOV C,M ;size - INX H - MOV E,M ;stuff - INX H - MOV D,M - CPI 'A' ;test for actual - JZ SE2 - XCHG ;address of datum -> HL - MOV E,M - INX H - MOV D,M -SE2 MOV A,C ;if size==1 & class==0 - DCR A - ORA B - JNZ SE3 - MOV A,E ; then propogate sign - RLC - SBB A - MOV D,A -SE3 POP B ;type -> A - MOV A,B - XCHG ;passed value -> HL - JMP VALLOC ;call/ret, valloc does the rest -; -;scans program and allocates all externals in next fctn -; layer. An "endlibrary" line causes a new fctn layer -; to be opened. -LINK CALL NEWFUN -LI2 LDA ERR ;check no error - ORA A - RNZ - LHLD CURSOR - INX H - INX H - XCHG - LHLD PROGEND - DAD D - XCHG - RC - CALL REM ;more text to process, skip - LXI D,LB ; remarks. - CALL LIT ;test for compound statement. - JZ LIDCL - MVI B,'[' ;skip compound st. - MVI C,']' - CALL SKIP - JMP LI2 -LIDCL CALL DECL ;test for declaration, and - JNZ LI2 ; allocate it - LXI D,XENDL ;test for endlibrary statement. - CALL LIT - JZ LISYM - CALL NEWFUN - JMP LI2 -LISYM CALL SYMNAME ;test for symbol - JZ LIERR - MVI A,'E' ;allocate a variable with - MVI B,2 ; class E, size 2, len 1, - MVI E,1 ; passed value = cursor. (This - MVI D,0 ; is a function entry.) - LHLD CURSOR - CALL NEWVAR - LHLD CURSOR ;advance cursor to beginning of - MVI A,'[' ; program body. -LI3 CMP M - JZ LI4 - INX H - XCHG - LHLD PROGEND - DAD D - XCHG - JNC LI3 - CALL ESET - DB LBRCERR - RET -LI4 SHLD CURSOR ;skip body - CALL SKIPST - JMP LI2 -LIERR CALL ESET - DB LINKERR - RET -; -;move -(bc) bytes from (hl) to (de) -MOVE MOV A,M - STAX D - INX D - INX H - INR C - JNZ MOVE - INR B - JNZ MOVE - RET -;it all starts here!!!!! -;cold start erases system level tc programs, and enters -; the loader. Used to load a tailered or different -; system program. -;warm start does not erase sys level progs, but enters -; the loader so more can be loaded. -;hot start assumes all the loading is done, and immed -; starts up the loaded sys level tc prog. -;Unfortunately, there is no hot start that preserves -; application programs. -COLD LHLD MSTACK ;initialize 8080 stack, if need - MOV A,H - ORA L - JZ CL2 - SPHL -CL2 LXI B,-10 ;copy initial statement - LHLD BPR ; PR - XCHG - LXI H,INST ; into PR - CALL MOVE - LHLD BPR - LXI D,9 - DAD D - CALL HLNEG - SHLD PROGEND - CALL LOGO -WARM CALL LOADER -HOT CALL LOGO - LHLD PROGEND - CALL HLNEG - SHLD PRUSED - LHLD BPR - SHLD CURSOR - LHLD BFUN - LXI D,6 - DAD D - SHLD CURGLBL - LXI D,-12 - DAD D - SHLD CURFUN - LHLD BVAR - SHLD NXTVAR - LHLD BSTACK - LXI D,-5 - DAD D - SHLD TOP - XRA A - MOV H,A - MOV L,A - STA ERR - SHLD ERRAT - STA LEAVE - STA BRAKE - CALL LINK - CALL NEWFUN - LHLD BPR - SHLD CURSOR - CALL PRBEGIN - CALL ST ;this executes the system progm - CALL PRDONE - LXI H,DONEMSG - CALL PS - LDA ERR - ORA A - JZ NOERR - LHLD ERR - XCHG - CALL PN - MVI A,' ' ; and a space, - CALL OUTCH - LHLD ERRAT - XCHG - CALL PN -NOERR MVI A,0DH - CALL OUTCH - JMP WARM -DONEMSG DB 0DH - DB 0DH - DB 'D' - DB 'O' - DB 'N' - DB 'E' - DB ' ' - DB 0 -INST DB '[' - DB 'm' - DB 'a' - DB 'i' - DB 'n' - DB '(' - DB ')' - DB ';' - DB ']' - DB 0 -; -LOADER LXI H,BUFF - MVI A,'>' - CALL OUTCH - CALL OUTCH - CALL OUTCH -D2 CALL INCH - MOV B,A - LDA ECHO - ORA A - MOV A,B - CNZ OUTCH - MOV M,A - CPI 7FH ;delete char - JZ D3 - CPI 0DH ;return - JZ DOIT - INX H - JMP D2 -D3 LXI D,-BUFF-1 - PUSH H - DAD D - POP H - JNC D2 - DCX H - JMP D2 -DOIT MVI M,0 ;null at command's end - LDA BUFF+1 ;ignore period in buff. - MOV B,A - LDA XR ;the letter r - CMP B - JZ LOAD - MVI A,LCFIX+'x' ; .x is the exit command - CMP B - JZ TCEXIT - LDA XG ;the letter g - CMP B - RZ ;leaves editor - MVI A,'?' ;unrecognized command - CALL OUTCH - CALL OUTCH - CALL OUTCH - MVI A,0DH - CALL OUTCH - JMP LOADER -LOAD LXI H,BUFF+3 ;file name - LXI D,1 ;read option - LXI B,1 ;unit - MVI A,1 ;open to read - CALL FOPEN - JNZ LOADER - LHLD PROGEND ;where to load (stored neg) -L2 CALL HLNEG - LXI B,1 ;unit - CALL FREAD ;read one block - JNZ L5 ;err or end of file - DAD D ;# bytes read in DE - MVI M,0 ;just beyond last byte read - CALL HLNEG - SHLD PROGEND ;points to null byte at end - JMP L2 -L5 LXI B,1 ;close unit 1 - CALL FCLOSE - JMP LOADER -BUFF DS 40 -; -;Negate HL -HLNEG MOV A,H - CMA - MOV H,A - MOV A,L - CMA - MOV L,A - INX H - RET -; -;print (DE) as signed integer -PN LXI H,BUFF - CALL ITOA - MVI M,0 ;put null at end - LXI H,BUFF - JMP PS ;and done -; -;convert (DE) to ascii signed integer -ITOA MOV A,D ;test for minus - ORA A - JP NTOA - CALL DENEG ;make positive - MVI M,'-' ;output minus - INX H ;now fall into NTOA -;convert (DE) to ascii unsigned integer -NTOA MOV A,D - ORA E ;must be at least one digit, so - JNZ NT2 ; test for 0. - MVI M,'0' - INX H - RET -NT2 XRA A ;put mark on stack - PUSH PSW -NT3 LXI B,10 - PUSH H - CALL DDIV - MOV A,L ;remainder -> A - POP H - ADI '0' - PUSH PSW ;ascii digit -> stack - MOV A,D ;done if quotient is zero - ORA E - JNZ NT3 -NT4 POP PSW ;top of stack is digit or mark. - RZ ;done if mark. - MOV M,A ;otherwise digit -> buffer. - INX H - JMP NT4 -; -;prints the copyright message on the terminal. -LOGO LXI H,CPMSG - JMP PS -CPMSG DB 0CH - DB '*' - DB '*' - DB '*' - DB ' ' - DB ' ' - DB 'T' - DB 'I' - DB 'N' - DB 'Y' - DB '-' - DB 'C' - DB ' ' - DB ' ' - DB ' ' - DB 'V' - DB 'E' - DB 'R' - DB 'S' - DB 'I' - DB 'O' - DB 'N' - DB ' ' - DB '1' - DB '.' - DB '0' - DB ' ' - DB ' ' - DB '*' - DB '*' - DB '*' - DB 0DH - DB 0AH - DB 'C' - DB 'O' - DB 'P' - DB 'Y' - DB 'R' - DB 'I' - DB 'G' - DB 'H' - DB 'T' - DB ' ' - DB '1' - DB '9' - DB '7' - DB '7' - DB ',' - DB ' ' - DB 'T' - DB ' ' - DB 'A' - DB ' ' - DB 'G' - DB 'I' - DB 'B' - DB 'S' - DB 'O' - DB 'N' - DB 0DH - DB 0AH - DB 0 -;move the block (DE)...(HL) inclusive (BC) bytes. If -; (BC) is positive, the block is moved up in RAM, -; highest byte first, lowest byte last. If (BC) is -; negative, the block is moved down in RAM, lowest -; byte first. Thus large blocks can be safely moved -; up or down short distances. -MOVEBL MOV A,B - ORA A - JM MOVEDN - ORA C - RZ -MOVEUP SHLD FROMPTR ;hi end of block is fromptr - DAD B ;to pointer -> DE - XCHG - LDA FROMPTR ; - length -> BC - CMA - ADD L ; - length = - MOV C,A ; current HL - fromptr +1 - LDA FROMPTR+1 - CMA - ADC H - MOV B,A - LHLD FROMPTR -MU2 MOV A,M - STAX D - DCX H - DCX D - INR C - JNZ MU2 - INR B - JNZ MU2 - RET -MOVEDN XCHG ;lo end of block is from ptr - SHLD FROMPTR - DAD B ;to pointer -> HL - LDA FROMPTR ; - length -> BC - SUB E - MOV C,A - LDA FROMPTR+1 - SBB D - MOV B,A - DCX B - XCHG ;to ptr -> DE - LHLD FROMPTR ;from ptr -> HL - JMP MOVE -FROMPTR DW 0 -; -;scan for the Nth occurance of a character in a block, -; or the end of the block, whichever comes first. The -; block is (DE)..(HL) inclusive. N is (BC) and can be -; 0 to 65k. (A) is the character. On completion, (DE) -; points to the Nth occurance, or to the last byte of -; the block. (BC) is N minus the number of (A) found, -; e.g. 0 if N (A)'s were found. HL is undisturbed. -SCANN PUSH PSW ;ch -> stack - XCHG ;reverse first and last -SC2 MOV A,C - ORA B ;test if done - JZ SC9 - MOV A,E - SUB L - MOV A,D - SBB H - JC SC9 - POP PSW - PUSH PSW - CMP M - JNZ SC3 - DCX B -SC3 INX H - JMP SC2 -SC9 DCX H - XCHG - POP PSW - RET -; -;count the occurances of a character in a block. (A) is -; the character. The block is (DE)..(HL) inclusive. -; The count is returned in (BC). (A) and (DE) are -; unchanged. (HL) is clobbered. -COUNTCH LXI B,0 - PUSH PSW ;ch -> stack -CC2 MOV A,L ;test for end - SUB E - MOV A,H - SBB D - JC CC9 - POP PSW - PUSH PSW - CMP M - DCX H - JNZ CC2 - INX B ;count this one - JMP CC2 -CC9 POP PSW - RET -;Machine Call routine to interface to 8080 coded -; routines. Standard routines used by the system -; are coded here, numbers 1 to 11. 12 to 999 are -; reserved. 1000 and up are available to users. -MC STA MCARGS ;for checking, - CALL TOPTOI ; for MC's that need it. - LXI H,-1000 ;test for user MC - DAD D - JC USERMC - MOV A,E ;fctn num -> A - CPI 1 - JZ MC1 - CPI 2 - JZ MC2 - CPI 3 - JZ MC3 - CPI 4 - JZ MC4 - CPI 5 - JZ MC5 - CPI 6 - JZ MC6 - CPI 7 - JZ MC7 - CPI 8 - JZ MC8 - CPI 9 - JZ MC9 - CPI 10 - JZ MC10 - CPI 11 - JZ MC11 - CPI 12 - JZ MC12 - CPI 13 - JZ MC13 - CPI 14 - JZ MC14 -MCESET CALL ESET - DB MCERR - RET -; -;put a character to screen -MC1 CALL TOPTOI ;char -> A - CALL PUSHK ;push it back - MOV A,E - JMP OUTCH -; -;get a char from keyboard -MC2 CALL INCH ;char -> DE - MOV B,A ;test for ESC in appl level - LDA APPLVL - ORA A - JZ USEIT - LDA ESCAPE - CMP B - JNZ USEIT - CALL ESET - DB KILL -USEIT LDA ECHO ;test if echo required - ORA A - MOV A,B - CNZ OUTCH - MOV E,A - XRA A - MOV D,A - JMP PUSHK ;put char onto stack -; -;file open (r/w, name, fsize, unit) -MC3 CALL TOPTOI - PUSH D - CALL TOPTOI - PUSH D - CALL TOPTOI - PUSH D - CALL TOPTOI ;r/w -> A - MOV A,E - ORA D - POP H ;name pointer -> HL - POP D ;file size -> DE - POP B ;unit -> BC - CALL FOPEN - LXI D,0 - MOV E,A ;push result code - JMP PUSHK -; -; read block( where, unit) -MC4 CALL TOPTOI - PUSH D - CALL TOPTOI - XCHG ;where -> HL - POP B ;unit -> BC - CALL FREAD - JZ MC4P ;if result code is 0 DE has - LXI D,-1 ; byte count to be pushed. - MOV E,A ; Otherwise A is an err or eof -MC4P JMP PUSHK ; code to be returned negative -; -;write block ( first byte, last byte, unit). Block may -; be any size from 1 to 256. -MC5 CALL TOPTOI - PUSH D - CALL TOPTOI - PUSH D - CALL TOPTOI - XCHG ;first -> HL - POP D ;last -> DE - POP B ;unit -> BC - CALL FWRITE - LXI D,0 ;push result code - MOV E,A - JMP PUSHK -; -;close file ( unit ) -MC6 CALL TOPTOI - MOV C,E ;unit -> BC - MOV B,D - CALL FCLOSE - JMP PZERO ;return a 0 -; -;move a block up or down. Args are first,last,K. If K -; negative, block is moved down |k| bytes, if positive -; then up K bytes. -MC7 CALL TOPTOI - PUSH D - CALL TOPTOI - PUSH D - CALL TOPTOI ;first -> DE - POP H ;last - POP B ;K - CALL MOVEBL - JMP PZERO ;return a 0 -; -;count # instances of character CH in a block. Args are -; first,last,CH. -MC8 CALL TOPTOI - PUSH D - CALL TOPTOI - PUSH D - CALL TOPTOI ;first -> DE - POP H ;last - POP B ;ch -> A - MOV A,C - CALL COUNTCH - MOV E,C ;count -> DE - MOV D,B - JMP PUSHK -; -;scan for nth occurance of CH in a block. Args are -; first,last,CH,cnt address. Return pointer to nth -; occurance,if it exists, otherwise to last. Also -; cnt is reduced by one for every CH found. -MC9 CALL TOPTOI - PUSH D - CALL TOPTOI - PUSH D - CALL TOPTOI - PUSH D - CALL TOPTOI ;first -> DE - POP H ;last - POP B ;ch -> A - MOV A,C - XTHL - MOV C,M ;cnt -> BC - INX H - MOV B,M - DCX H - XTHL ;addr of cnt still on stack - PUSH D ;first on stack, too - CALL SCANN - POP H ;make ptr (DE) relative to - MOV A,E ; first - SUB L - MOV E,A - MOV A,D - SBB H - MOV D,A - POP H ;BC -> cnt - MOV M,C - INX H - MOV M,B - JMP PUSHK ;return pointer to last byte -; ; examined. -; -;trap to moniter 4.0 for debugging. -MC10 DB 0FFH ;RST 7 - RET -; -;enters an application program, setting up a new -; globals variable level, redefining progend, links -; the program, executes if no error occured, upon -; completion captures a few facts (err, and either -; cursor or errat) and restores old globals level, -; progend, zeros err, pushes a zero as the value of -; this function, and resumes the calling program. -MC11 LHLD CURSOR - PUSH H - LHLD PROGEND - PUSH H - LHLD PRUSED - PUSH H - LHLD CURGLBL - PUSH H - CALL TOPTOI ;appl pr address - XCHG - PUSH H - SHLD CURSOR - CALL TOPTOI ;end of appl addr - XCHG - SHLD PRUSED - CALL HLNEG - SHLD PROGEND - CALL LINK - LHLD CURFUN - SHLD CURGLBL - CALL TOPTOI ;start statement address - XCHG - SHLD CURSOR - CALL NEWFUN - CALL TOPTOI ;facts address - PUSH D - LXI H,APPLVL ;increment appl level - INR M - PUSH H - LDA ERR ;if no err so far, do it!! - ORA A - JNZ DONE - CALL PRBEGIN - CALL ST - CALL PRDONE -DONE POP H ;its done, decrement appl level - DCR M - CALL FUNDONE ;discard appl locals - CALL FUNDONE ; and globals - LHLD CURSOR ;set up facts - LDA ERR - ORA A - JZ MCEN2 - LHLD ERRAT -MCEN2 XCHG ;returned currsor -> DE - POP H ;facts -> HL - POP B ;appl pr address -> BC - MOV A,E ;make returned cursor relative - SUB C ; to appl address - MOV E,A - MOV A,D - SBB B - MOV D,A - LDA ERR - MOV M,A ;err -> facts - XRA A - INX H - MOV M,A ;err hi byte -> facts - INX H - MOV M,E ;cursor -> facts - INX H - MOV M,D - POP H ;curglobal - SHLD CURGLBL - POP H - SHLD PRUSED - POP H ;progend - SHLD PROGEND - POP H ;cursor - SHLD CURSOR - XRA A ;zero the error - STA ERR - JMP PZERO ;value of MC11 -; -;test if keyboard char ready, return copy if so,else 0. -MC12 CALL CHRDY - MVI D,0 - MOV E,A - JMP PUSHK -; -;print RAM, from and to addresses are given -; nulls are mapped to quotes -MC13 CALL TOPTOI - PUSH D - CALL TOPTOI - XCHG ;from -> HL - POP D ;to -> DE -LOOP13 MOV A,E ;test if done - SUB L - MOV A,D - SBB H - JC PZERO ;done - MOV A,M - ORA A - JNZ EC13 - MVI A,'"' -EC13 CALL OUTCH - INX H - JMP LOOP13 -; -;print a signed integer -MC14 CALL TOPTOI - PUSH D - CALL PN - POP D - JMP PUSHK - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/TC.COM b/software/CPM/CPM_MC_C1/TC.COM deleted file mode 100644 index 432d5bb..0000000 Binary files a/software/CPM/CPM_MC_C1/TC.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C1/TCASM.DOC b/software/CPM/CPM_MC_C1/TCASM.DOC deleted file mode 100644 index 0442b00..0000000 --- a/software/CPM/CPM_MC_C1/TCASM.DOC +++ /dev/null @@ -1,148 +0,0 @@ -.sp 2 -CAVEAT, or BEWARE THE PRESUMED WONDERFUL, FRIENDLY ASSEMBLER. -.sp -As noted in the description below, every effort has -been made to remove booby-traps from this source code. -I own several assemblers. -None can process this text correctly, e.g. the lower case -problem mentioned below. -Following INTEL standard mnemonics is not a guarantee -that a assembler does not have occasional wierd behavior. -We suggest you approach the use of the source code file -as a "project" of a few evenings wrestling, or in a bad case -a few weeks. -.sp 2 -CHANGES FROM APPENDIX A -.sp -The tc.asm file contains the source code for the tiny-c -interpreter, close to what is in Appendix A of the Owner's -Manual. -It differs in these ways: -.sp -.in 5 -.ti -4 -1. The eight patches XX through XX8 at the end of -Appendix A have been moved inline. -This means that, when assembled, slightly different -addresses will result. -.sp -.ti -4 -2. All P operands are changed to PSW in PUSH P and POP P -instructions. -.sp -.ti -4 -3. The labels POP and PUSH are changed to POPST and -PUSHST. -The label OUT is changed to BLOUT. -So no labels "collide" with operator mnemonics. -.sp -.ti -4 -Some assemblers complain at attempts to put -1 into a byte. -4. At 2094 the DB -1 is changed to DB 0FFH. -.sp -.ti -4 -5. In the subroutine DREM the locals are renamed -DR2, DR3 and DR4 (locations 2145-2164). -In FACTOR the local WHERE is now FWHERE (2773-2828). -In COLD the local DONE is now DONEMSG (2cd8, 2d00). -Thus no symbols are used twice, and the entire -interpreter can be assembled in one bunch. -.sp -.ti -4 -6. All $+n address are removed, and changed to labels. -This is a big non-standard area; the meaning of $. -It's use is poor practice anyway. -.sp -.ti -4 -7. The comment on line 260d is removed. -My "latest and best" assembler didn't like it. -.sp -.ti -4 -8. These mods to the installation area are compatible -with the CP/M (*) installation code: -ECHO is 1 (not 0). -MSTACK is 1a00 (not 0). -There are addresses for INCH, etc. -The memory address allocations are realistic ones for -a 24K CP/M installation. -.sp -.ti -4 -9. The origin is at 600h. -.sp 2 -.in -Assembling tc.asm will give a working tiny-c compatible -with the installation code ctc.asm. -However the listing in Appendix A will not be valid, as -noted above. -To generate a TC.COM from the TC.ASM: -.in 5 -.sp -assemble TC.ASM -assemble CTC.ASM -enter DDT -input (and read)TC.HEX -input (and read) CTC.HEX -follow lower case instructions below, if needed. -leave DDT (type ^C). -save 23 segments under any name you want for this version -.ti 5 -and with type COM. -the result should work just like the TC.COM file, but -.ti 5 -see CAVEAT at the top. -.in -.sp -LOWER CASE PROBLEM -.sp -The standard CP/M 1.4 assembler maps all literals from -lower to upper case. -You may have an assembler that doesn't do this, in -which case skip this step. -Or you may want an upper case version of tiny-c, -in which case you are left with the exercise of -modifying PPS to upper case literals. -But most likely you will have to change these bytes -to undo the unwanted case mapping. -The following addresses are for the new assembled version, -not the Appendix A listings. -.sp -.ti 5 -Change all alphabetics (all but the nulls) in -addresses 663 through 2093. -(Note the FF at the end. It signals to stop.) -.sp -Change the four letters 'main' starting at 1326. -.sp -change the x at 1373. -.sp -Change the a at 88e -and at 891 is 'z'+1 which must be changed. -All changes are simple. -.sp -.in -Just add hex 20, i.e. change -leading 4's to 6's and leading 5's to 7's. -After making the changes use the D command to dump -them, and verify your work. -Note that all this can be done using DDT, before leaving -it to do the save. -Incidentally, it only takes 5 minutes or so. -.sp 2 -AND NOW, WHY IT ALL DOESN'T WORK. -.sp -The CTC code cheats, by calling a few subroutines -in TC. -To do this it needs to know the subroutine's addresses. -There are several EQU statements in CTC.ASM with addresses -from Appendix A. -These have to be changed to addresses produced by the -reassembly. -These are the EQU's to change: -.in 5 -.sp -tcorg -inst -move -hlneg -pzero - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/TELNET.C b/software/CPM/CPM_MC_C1/TELNET.C deleted file mode 100644 index 8ae7412..0000000 --- a/software/CPM/CPM_MC_C1/TELNET.C +++ /dev/null @@ -1,859 +0,0 @@ - - -#define TITLE "BDS Telnet version 2.3 (July 1980)" - -/* - - Written by Leor Zolman and Leo Kenen - December 1979, March 1980, May 1980, July 1980 - - This version has been modified to obtain all hardware- - dependent information from bdscio.h, which must contain - the correct hardware specifications for your modem port. - It is also no longer necessary to alter #define statements - in this file to reflect CP/M system size; the "topofmem()" - function is now used to determine the amount of memory - available for the text collection buffer. - - If you intend to use this program for high speed - (i.e, greater than 300 baud) data transfers, such as - maybe over RS232 lines between two machines directly, - then the speed of transfer will be limited by the - processors involved instead of the baud rate; - UNDER SUCH CIRCUMSTANCES, A TRANSFER WILL ONLY WORK IF - THESE TWO CONDITIONS ARE MET: - - 1) The transfer must always performd in BINARY - mode, never in TEXT mode, and - 2) The receiving processor must be as fast or - FASTER than the transmitting processor. That - is, a 2 MHz machine may transmit to a 4 MHz - machine at, say, 9600 baud, BUT NOT VICE- - VERSA. - - See the write up by Leo for more details than are - presented here. - - ****************************************** - * Telnet assumes that your CP/M console * - * I/O device is much faster than your * - * modem. On a 2MHz 8080, the modem can * - * be receiving at up to 300 baud as long * - * as your console whips along (at the * - * very least) at about 1200. 4 MHz mach- * - * ines might be able to get away with * - * slower terminals, but not much slower. * - ****************************************** - -"Telnet" is a program which interacts with a modem to turn - your microcomputer into a very versatile terminal. Special - commands are entered to the program by typing the character - you designate as "SPECIAL", i.e, some character (such as the - null or ^A ) which you wouldn't be likely to need transmitted, - and then entering the appropriate command letter. Incoming - data may be buffered up in RAM memory and dumped to disk - whenever you desire (via the "o", "d", "c" and "k" commands), - data may be transmitted from disk to modem (via "t" and "a"), - or files can be formally transferred in an alternate - "checksum" mode which handles handshaking and buffering - automatically when interacting with the same program on - the other end of the line. During file transfers, you - may temporarily pause and later resume the transmission - (via the "p" and "r" commands.) There are also various - options you can control (see "n", "7", "h" and "l") to - adapt operation toward the type of file you wish to - transfer. The "q" command closes the output file (if open) - and quits to CP/M. The "s" command displays the status of - the program. "z" clears the console screen. Any other - command letter (such as, for example, "?") causes a list - of legal commands to be displayed. - -In order to transmit or receive files in the checksum -mode, both parties must make sure that their modems are -operating in FULL-DUPLEX. When you are in full duplex, -then what you type will NOT come right back at you from the -modem; the only input you see from the modem is the data -transmitted by the machine on the OTHER end of the line. - -This program considers "half duplex" to be any situation -in which the data you transmit comes right back at you; -whether it is your modem that is performing the ehoing -or a computer system far away doesn't really matter. In any -case, checksumming and handshaking is not allowed under half- -duplex operation, since erroneous characters would be received. -When you run telnet, it will ask you whether -or not you are in half-duplex, and perform accordingly. If -you switch from half to full or vice-versa while running the -program, use the "h" option to inform telnet of the fact. - -To perform checksummed file transfer, a connection must -first be established between the two parties. If both -parties are operating in full duplex, one originating and the -other answering, then telnet will both display what each -types to the console and send it to the modem. If a file -then needs to be transferred, then one user would give the -"t" command (to transmit) and the other would give the "o" -command (to open an output file.) If both users indicate -checksum mode (rather than only one specifing checksum mode -which will abort almost immediatly), then telnet will take -it from there and perform the transfer. If the sender -(transmitter) wants to suspend the transfer temporarily and -continue later, he can use the "p" command. When the receiver -sees that transmission has been suspended (when no data has -been sent for a long time), then HE gives the "p" command also, -and both users may type to each other. When ready to resume, -the "r" command must be given by the RECEIVER first, and -then the sender, to prevent data from being lost. - -*/ - -#include "bdscio.h" /* System, h'ware constants */ - -#define SPECIAL 0x1e /* The character you type to - signal a Telnet command - (should be obscure...I use - a "control-shift-uparrow") */ - - -/* - The following #defines need not be changed: -*/ - -#define ACK 0x06 /* Ascii ACK for handshaking */ -#define NAK 0x15 -#define EOT 0x04 /* End of transmission */ -#define ETX 0x03 /* Abort Transmission */ - - -/* - External variable declarations: -*/ - -char rflag; /* receiving file open flag */ -char tflag; /* transmitting file open flag */ -char chflag; /* checksumming enabled flag */ -char cflag; /* text-collection enabled flag */ -char pflag; /* pausing flag */ -char spflag; /* stripping parity bit flag */ -char lflag; /* list device enabled flag */ -char nflag; /* recognizing nulls flag */ -char fflag; /* true if changing CR-LF's into - just CR when transmitting */ -char lastc; /* last char xmitted */ -char dodflag; /* true if displaying outging - data */ -char didflag; /* true if displaying incoming - data */ -char hdflag; /* true if effectively working - in half-duplex */ -char abortf; /* true when file I/O aborted */ -char rbuf[BUFSIZ]; /* file I/O buffer for incoming - data file */ -char tbuf[SECSIZ]; /* sector buffer for file being - transmitted */ -char rname[20]; /* name of receiving file */ -char tname[20]; /* name of transmitting file */ -int rfd, tfd; /* file descriptors */ - -char *cptr; /* pointer to free space in buf */ -unsigned free; /* number of bytes free in buf */ -int bcount; /* counts bytes in current block - when checksumming */ -int scount; /* Number of sectors - sent/received */ -int checksum; /* the checksum value itself */ -char timoutf; /* true if time-out happens - while waiting for modem data */ -char *i; /* odd-job char pointer */ - -int dod_sav, did_sav; /* scratch variables */ - -unsigned bufspace; /* # of bytes available for text - collection buffer in ram */ - -char *buf; /* text collection pointer; will - point to the location just - after itself */ - -char toupper(); /* This makes for better code - than if we let it default - to "int" */ - -/* - Routine to return true if input is present on - the modem: -*/ - -miready() -{ - return (inp(MSTAT) & MIMASK) == (MAHI ? MIMASK : 0); - } - - -/* - Routine to return true if modem is ready to output - a byte: -*/ - -moready() -{ - return (inp(MSTAT) & MOMASK) == (MAHI ? MOMASK : 0); -} - - -main() -{ - char c, c2; - int n; - - init(); - - loop: if (abortf) { - if (rflag) rclose(); - if (tflag) tabort(); - abortf = 0; - } - - if (tflag && xmit()) { - printf("\nTransmission complete.\n"); - close(tfd); - reset(); - } - if (abortf) goto loop; - if (miready()) { - c = c2 = getmod(); - if (spflag) c &= 0x7f; - if (tflag && (c == ETX)) { - printf("Reciever has aborted;\n"); - abortf = 1; - goto loop; - } - if (didflag && (c || nflag) && (c != CPMEOF)) - display(c); - if (cflag && !pflag) { - if (c || nflag) - if (!free) printf("**BUFFER FULL**\007\007"); - else { *cptr++ = c; free--; } - if (chflag) { - checksum += c2; - bcount++; - if (bcount == SECSIZ) { - bcount = 0; - outmod(checksum >> 8); - outmod(checksum); - checksum = 0; - c = getmod(); - if (c == EOT) { - rdump(0); rclose(); - printf("\n%s recieved OK\n",rname); - } - else if (c == ACK) { - if (cptr > buf+1000) rdump(0); - if (!didflag) printf("Good sector <%d>\n",++scount); - outmod(0xFD); - } - else { - cptr -= SECSIZ; - free += SECSIZ; - printf("\nChecksum error. Retrying <%d>\n",scount+1); - outmod(0xFD); - timoutf = 0; - } - - } - } - } - } - - if (kbready()) { - c = getch(); - if (c != SPECIAL) { - if (pflag || (!tflag && !(rflag && chflag))) { - outmod(c); - if (dodflag) display(c); - } - } - else special(); - } - goto loop; -} - - -/* - Handle special Telnet command: -*/ - -special() -{ - char c; - int n; - - printf("\nSpecial: "); - if ( (c = getchar()) != '\n') printf(" "); - switch (toupper(c)) { - case '\n': return; - case SPECIAL: outmod(SPECIAL); - printf("Special char sent\n"); - break; - - case '7': spflag = ask("Strip parity"); - break; - - case 'N': nflag = ask("Recognize incoming nulls"); - break; - - case 'F': fflag = ask("Transmit CR-LF pairs as CR only"); - break; - - case 'H': if (rflag || tflag) { printf( - "Must abort transfer first\n"); - break; - } - printf("\nAre you either at half"); - printf("-duplex or getting an "); - hdflag = ask ("echo"); - reset(); - break; - - case 'L': lflag = ask("List incoming data"); - break; - - case 'Z': printf(CLEARS); - break; - - case 'P': if (pflag) printf("Already pausing"); - else if (!(tflag || rflag)) - printf("Not transmitting or receiving"); - else { - pflag = 1; - dod_sav = dodflag; - did_sav = didflag; - dodflag = !hdflag; - didflag = 1; - printf("Ok, pausing from %s", tflag ? - "transmission" : "collection"); - } - goto lf; - - case 'R': if (!pflag) printf("Not pausing"); - else { - pflag = 0; - dodflag = dod_sav; - didflag = did_sav; - printf("%s now enabled again.", tflag ? - "transmission" : "collection"); - } - goto lf; - - case 'K': printf("Text buffer !ZAPPED!"); - free = bufspace; - cptr = buf; - goto lf; - - case 'V': if (rflag) { - putchar('\n'); - i = buf; - while (i < cptr) putchar(*i++); - printf("\n%u bytes free",free); - } - else printf("No recieving file open"); - goto lf; - - case 'O': if (rflag) rclose(); - if (tflag) tabort(); - printf("\nOutput filename? "); - gets(rname); - rflag = 1; - if (!askstuff()) { - rflag = 0; - return; - } - printf("Creating %s...",rname); - rfd = fcreat(rname,rbuf); - if (rfd == ERROR) { - printf("Cannot create %s\n",rname); - reset(); - break; - } - putchar('\n'); - cptr = buf; - free = bufspace; - rflag = cflag = 1; - pflag = checksum = bcount = 0; - if (chflag) { - printf("Trying to link..."); - do { - c = getmod(); - if (abortf) { - printf("aborting...\n"); - unlink(rname); - reset(); - return; - } - timoutf = 0; - } while (c & 0x7f); - printf("linked.\n"); - outmod(0); - } - break; - - case 'D': if (rflag) rdump(1); - else printf("No output file"); - goto lf; - - case 'C': if (rflag) rclose(); - else printf("No output file"); - goto lf; - - case 'Q': if (tflag) tabort(); - if (rflag) rclose(); - exit(); - - case 'A': if (tflag || rflag) { - if (chflag) outmod(ETX); - abortf = 1; - break; - } - printf("No transfer to abort.\n"); - goto lf; - - case 'T': if (tflag) tabort(); - if (rflag) rclose(); - printf("\nFile to transmit? "); - gets(tname); - tflag = 1; - if (!askstuff()) { - tflag = 0; - return; - } - tfd = open(tname,0); - if (tfd == ERROR) { - printf("Cannot open %s\n",tname); - reset(); - goto lf; - } - pflag = checksum = bcount = 0; - if (read(tfd,tbuf,1) <=0) { - printf("Read error from %s\n", - tname); - abortf = 1; - return; - } - if (chflag) { - printf("Trying to link..."); - while (1) { - outmod(0); - for (n=0; n<5000; n++) - if (miready()) { - if( !(getmod() & 0x7f)) { - printf("linked.\n"); - return; - } - } - else if (kbabort()) { - printf("aborting.\n"); - return; - } - } - } - break; - - case 'S': dostat(); - goto lf; - - default: prcoms(); - - lf: putchar('\n'); - } -} - -/* - Print out legal Telnet commands: -*/ - -prcoms() -{ - printf("\nBDS Telnet commands are:\n"); - printf("Double SPECIAL: send SPECIAL\n"); - printf("o: Open output file, start collection\n"); - printf("p: Pause (suspend collection or transmission)\n"); - printf("r: Resume after pausing\n"); - printf("d: Dump (append) text buffer to output file\n"); - printf("c: Close output file (after dumping buffer)\n"); - printf("v: View contents of text buffer\n"); - printf("k: Kill (erase) contents of text buffer\n"); - printf("t: Transmit a file to modem\n"); - printf("a: Abort transfer of file\n"); - printf("n: accept or ignore Nulls\n"); - printf("7: select policy regarding Parity bits\n"); - printf("f: select whether to transmit CR-LF as just CR\n"); - printf("h: set Half/full duplex mode\n"); - printf("l: control CP/M List device\n"); - printf("z: clear console terminal screen\n"); - printf("s: display Status of Telnet\n"); - printf("q: dump & close output file (if open) and Quit to CP/M"); -} - - - -/* - Print opening message and initialize program: -*/ - -init() -{ - printf(TITLE); - timoutf = cflag = nflag = lflag = pflag = abortf = fflag = 0; - spflag = 1; - lastc = 0; - buf = &buf + 1; - bufspace = buf + 500 - topofmem(); /* compute space available */ - bufspace = -bufspace; /* for text collection buf */ - printf("\n\nAnswer `y' if either your modem is set to half-duplex,\n"); - printf("or you expect an echo from the system on the"); - printf(" other end\n"); - printf("of the line; else answer `n':\n"); - hdflag = ask("Do you expect an echo"); - reset(); - printf("OK; you're on line...\n\n"); -} - - -/* - Get all the info pertinent to a file transfer; i.e, - whether or not the file is text (and needs parity - stripped, nulls ignored, echoing to console, etc.), - whether or not checksumming and handshaking are - required (they always go together), and make sure - the user is in full duplex mode. -*/ - -askstuff() -{ - printf("\n%s ",rflag ? "recieving" : "transmitting"); - if (ask("text (y) or binary data (n) ")) { - nflag = 0; - spflag = didflag = 1; - dodflag = !hdflag; - printf("Stripping parity, ignoring nulls,\n"); - printf(" %sdisplaying %s data.\n", - (rflag ? didflag : dodflag) ? "" : "not ", - rflag ? "incoming" : "outgoing"); - } - else { - spflag = didflag = dodflag = 0; - nflag = 1; - printf("%s all data verbatim, and not\n", - rflag ? "Recieving" : "Sending"); - printf("displaying it on the console.\n"); - } - - putchar('\n'); - printf("Handshaking & checksumming can only happen\n"); - printf("if the other computer has this same program\n"); - printf("running. Do you want handshaking & checksumming"); - chflag = ask(""); - if (chflag && hdflag) { - printf("Can't do it unless you can eliminate"); - printf(" the echo! Aborting.\n"); - return 0; - } - scount = 0; - return ask("OK...type y to begin, n to abort:"); -} - -/* - Routine to print out a string and return true - if the user responds positively -*/ - -int ask(s) -char *s; -{ - char c; - while (1) - { - printf("%s ",s); - printf("(y/n)? "); - c = toupper(getchar()); - if (c == 'Y') - { - printf("es\n"); - return 1; - } - else if (c == 'N') - { - printf("o\n"); - return 0; - } - else putchar('\n'); - } -} - - -/* - Print out state of Telnet program: -*/ - -dostat() -{ - - putchar('\n'); - - if (rflag) { - printf("Output file = %s\n",rname); - printf("Text buffer has %u bytes free", - free); - printf("\nText collection: "); - if (cflag) if (pflag) printf("on, but pausing\n"); - else printf("on\n"); - else printf("off\n"); - } - else printf("No output file\n"); - - if (tflag) { - printf("Transmitting: %s ", - tname); - if (pflag) printf("(but pausing)"); - putchar('\n'); - } - else printf("Not transmitting any file\n"); - - printf("Incoming nulls are being %s\n", - nflag ?"collected" : "ignored"); - - printf("Parity bits are being %s\n", - spflag ?"stripped" : "preserved"); - - printf("Half-duplex mode: %s", - hdflag ? "on" : "off"); -} - - -/* - Routine to dump contents of the memory text buffer - to the output file and clear the buffer for more - data: - (Note that the "else putchar('\0');" clause may not - be necessary on your system; this is here only to - make up for a strange "feature" of Lifeboat's - Northstar CBIOS where disk polling happens during - console output, potentially causing bytes to be - missed from the modem.) -*/ - -rdump(n) -{ - for (i=buf; i\n",++scount); - outmod(ACK); - } - else { outmod(EOT); return 1; } - - checksum = 0; - if (getmod() != 0xFD) { - printf("\nPhase error; aborting..."); - abortf = 1; - } - return 0; -} - - -/* - Read a sector of the transmission file: -*/ - -read1() -{ - int i; - i = read(tfd, tbuf, 1); - if ( i == ERROR) { - printf("\nRead error from %s; Aborting.\n", - tname); - tabort(); - } - return i; -} - -tabort() -{ - if (chflag) while (bcount++ != 133) outmod(ETX); - printf("\nTransmission of %s aborted.\n",tname); - close(tfd); - reset(); -} - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/UCSD2CPM.C b/software/CPM/CPM_MC_C1/UCSD2CPM.C deleted file mode 100644 index 35ae4af..0000000 --- a/software/CPM/CPM_MC_C1/UCSD2CPM.C +++ /dev/null @@ -1,504 +0,0 @@ -/* ------------------------------------------------------- - *** Template for Procedure Heading *** - - Name: - Result: - Errors: - Globals: - Macros: - Procedures: - - Action: - - ------------------------------------------------------- */ - -/* : : : : : : : : : : : : : : : : : : : : : : : : : : : : - - ucsd2cpm -- Transfer '.TEXT' files from a UCSD directory - formatted disk to a CP/M directory formatted - disk. - - 1) header blocks removed - 2) linefeeds added after carriage returns - 3) indents converted to appropriate # of spaces - 4) filler nulls removed - 5) control-A's removed (added 2/13/80 hrm) - - : : : : : : : : : : : : : : : : : : : : : : : : : : : : */ - - - - - -/* : : : : : : : : : : : : : : : : : : : : : : : : : : : : - - Constants - - : : : : : : : : : : : : : : : : : : : : : : : : : : : : */ - - -#define DLE 0x10 /* Data Link Escape -- indent flag */ -#define CR 0x0D /* carriage return */ -#define LF 0x0A /* linefeed */ -#define NULL 0 /* ascii null */ -#define CPM_EOF 0X1A /* CP/M ascii endfile mark */ - -#define TRUE 1 /* booleans */ -#define FALSE 0 - -#define SEL_DSK 14 /* bdos function number */ -#define SET_DMA 26 /* bdos function number */ - -#define SET_TRK 9 /* bios index number */ -#define SET_SEC 10 /* bios index number */ -#define READ 12 /* bios index number */ - -#define DUMMY 0 /* dummy parameter for bios routine */ - -#define EOF_F 0xFFFF /* end of file flag */ -#define D_ENT_SZ 26 /* UCSD directory entry size */ -#define D_TITLE 6 /* offset to entry title */ -#define UCSD_NAM_SZ 20 /* size of the name part of ucsd dir entry */ -#define UCSD_DIR_SZ 2048 /* size of UCSD directory in bytes */ - -#define SECT_SIZE 128 /* bytes per physical sector */ -#define BLOK_SIZE 512 /* bytes per UCSD logical block */ -#define SECT_PER_BLOK 4 /* physical sectors per logical block */ - - - - -/* : : : : : : : : : : : : : : : : : : : : : : : : : : : : - - Globals -- these would be static if it were available - - : : : : : : : : : : : : : : : : : : : : : : : : : : : : */ - -int lsn; /* logical sector number */ -int lstlsn; /* last logical sector number */ -int nbytes; /* number of bytes remaining in ucsd file buffer */ -char ucsdbuf[BLOK_SIZE]; /* 1 block buffer for ucsd file */ -char *ptr; /* pointer to current byte in ucsd file buffer */ - - - - -/* : : : : : : : : : : : : : : : : : : : : : : : : : : : : - - Global structure type - - : : : : : : : : : : : : : : : : : : : : : : : : : : : : */ - - struct buf { - int fd; - int nleft; - char *nextp; - char buff[SECT_SIZE]; - }; - - /* ------------------------------------------------------- - - Name: main(argc,argv) - Result: --- - Errors: invocation syntax - Globals: lsn,lstlsn,nbytes,ptr,ucsdbuf - Macros: CPM_FILE,UCSD_FILE,UCSD_NAM_SZ - - Procedures: puts(),exit(),force_upr(),printf() - putchar(),close(),unlink(),strcpy() - strcat(),getchar(),open(),copy() - tolower() - - Action: Call copy() to copy a '.TEXT' file - from a UCSD formatted disk in drive B - to a user specified file name in - drive A - - Handle invocation errors - Handle case of already existing - destination file - - ------------------------------------------------------- */ - -#define CPM_FILE argv[1] -#define UCSD_FILE argv[2] - -main(argc,argv) - int argc; - char *argv[]; - { - int file_id; - char ucsdname[UCSD_NAM_SZ]; - - lsn = lstlsn = nbytes = 0; /* init globals */ - ptr = ucsdbuf; - - if( argc != 3 ) { - puts("Proper invocation form is:\n\n"); - puts("UCSD2CPM \n"); - puts("This copies B:.TEXT to A:\n"); - exit(1); - } - force_upr(UCSD_FILE); /* make upper case */ - if( (file_id = open(CPM_FILE,0)) >= 0 ) { - printf("%s already exists. Delete it ? ",CPM_FILE); - if( tolower(getchar()) != 'y' ) { - puts("\naborted\n"); - exit(1); - } - putchar('\n'); - close(file_id); - unlink(CPM_FILE); - } - else - close(file_id); - strcpy(ucsdname,UCSD_FILE); - strcat(ucsdname,".TEXT"); - if(copy(ucsdname,CPM_FILE)) - printf("\n\nno such file %s .. aborted\n",ucsdname); - exit(0); - } - - /* ------------------------------------------------------- - - Name: copy (ucsd_file,cpm_file) - Result: TRUE if error , FALSE if transfer ok - - Errors: no such '.TEXT' file - - Globals: struct buf, - Macros: TRUE,EOF_F,CR,DLE,NULL,CPM_EOF,FALSE - - Procedures: find_file(),fcreat(),getbyte() - putc(),fflush(),fclose() - - Action: Find '.TEXT' file in UCSD directory - on drive B - Create user specified file on - drive A - copy file content from UCSD to CP/M - car by char translating: - Skip header block - Ignore NULL's - Add LF after CR - Convert DLE to - appropriate number of spaces - close output file - - ------------------------------------------------------- */ - -copy(ucsd_file,cpm_file) - char *ucsd_file,*cpm_file; - { - struct buf tofile; - int c; - - if( ! find_file(ucsd_file) ) /* no such file */ - return TRUE; - fcreat(cpm_file,&tofile); - while( (c = getbyte()) != EOF_F ) - switch(c) { - - case CR: putc(CR,&tofile); /* LF after CR */ - putc(LF,&tofile); - break; - - case DLE: for( c = (getbyte() - 32); c; c-- ) - putc(' ',&tofile); /* fill spaces */ - break; - - case '\1': /* ignore ^A's */ - case NULL: break; /* ignore nulls */ - - default: putc(c,&tofile); /* pass char unmodified */ - break; - } - putc(CPM_EOF,&tofile); /* send cp/m ascii endfile */ - fflush(&tofile); - fclose(&tofile); - return FALSE; /* signal transfer ok */ - } - - /* ------------------------------------------------------- - - Name: getbyte() - Result: next sequential byte from UCSD '.TEXT' file - Errors: - Globals: lsn,lstlsn,nbytes,ptr,ucsdbuf[] - Macros: EOF_F,BLOK_SIZE,SECT_PER_BLOK - Procedures: read_ucsd() - - Action: read block at a time - pass along byte at a time - return EOF_F if end of UCSD file - - ------------------------------------------------------- */ - - -getbyte() - { - if( lsn > lstlsn) - return EOF_F; - if( nbytes-- ) - return *ptr++; - read_ucsd(ucsdbuf,lsn,1); - nbytes = (BLOK_SIZE-1); - ptr = ucsdbuf; - lsn += SECT_PER_BLOK; - return *ptr++; - } - - - /* ------------------------------------------------------- - - Name: fclose(file) - Result: status of closing action - Errors: --- - Globals: struct buf - Macros: --- - Procedures: close() - - Action: file open for buffered input - or output is closed - - ------------------------------------------------------- */ - - -fclose(file) - struct buf *file; - { - return close( file->fd ); - } - - /* ------------------------------------------------------- - - Name: find_file(ucsd_name) - Result: TRUE if found, FALSE if not found - Errors: - Globals: lsn,lstlsn - Macros: D_ENT_SZ,SECT_PER_BLOK,D_TITLE - TRUE,FALSE,UCSD_DIR_SZ - - Procedures: read_ucsd() - - Action: --- - - ------------------------------------------------------- */ - - -find_file(ucsd_name) - char *ucsd_name; - { - char ucsd_dir[UCSD_DIR_SZ]; - char *dir,*saved_dir,*name; - int name_len; - - name = ucsd_name; - read_ucsd(ucsd_dir,(2*SECT_PER_BLOK),4); - dir = &ucsd_dir[D_TITLE + D_ENT_SZ]; /* skip title block */ - while ( dir < &ucsd_dir[UCSD_DIR_SZ] ) { - saved_dir = dir; - if( (name_len = *dir++) <=0 || name_len > 19 ) - return FALSE; - while( *dir++ == *name++ ) { - if( --name_len ) /* continue comparison check */ - ; - else { /* entry found */ - dir = saved_dir - D_TITLE; /* point to alloc. info. */ - lsn = *dir++; - lsn += *dir++ << 8; /* lsn = starting logical block number */ - lsn += 2; /* bypass header blocks */ - lsn *= SECT_PER_BLOK; /* 1'st logical sector number */ - - lstlsn = *dir++; - lstlsn += *dir++ << 8; /* lstlsn = ending logical block # */ - lstlsn *= SECT_PER_BLOK; /* lstlsn = last logical sector # */ - return TRUE; /* indicate file found */ - } - } - name = ucsd_name; /* reset comparison name pointer */ - dir = saved_dir + D_ENT_SZ; /* point at next entry name */ - } - return FALSE; /* no such file */ - } - - /* ------------------------------------------------------- - - Name: read_ucsd() - Result: status of selecting drive A - Errors: sector read error - Globals: --- - Macros: SEL_DSK,SET_DMA,SET_TRK,SET_SEC - READ,DUMMY,SECT_SIZE - Procedures: bios(),bdos(),printf(),exit() - - Action: Read count blocks from drive B - into buf starting at UCSD logical - record number rn - - ------------------------------------------------------- */ - - -read_ucsd(buf,rn,count) - char *buf; - unsigned rn; - int count; - { - char bios(); - int seccnt; seccnt = count*4; - - bdos(SEL_DSK,1); - while( seccnt-- ) { - bdos(SET_DMA,buf); - bios(SET_TRK,track(rn)); - bios(SET_SEC,sector(rn)); - if( bios(READ,DUMMY) ) { - printf("read error @ track %2d sector %2d",track(rn),sector(rn)); - exit(1); - } - buf += SECT_SIZE; - rn++; - } - return bdos(SEL_DSK,0); - } - - /* ------------------------------------------------------- - - Name: sector(rn) - Result: absolute sector number - Errors: --- - Globals: --- - Macros: --- - Procedures: --- - - Action: convert logical record number - to absolute sector - - maps logical records to physical sectors - by selecting every second sector in order - (accounting for the modulo 26 process) - on the diskette except that at a track - switchover point there is an additional - 'gap' of 6 sectors (total of 7) to allow - for the drive to seek. This is UCSD's - attempt to minimize disk access time. - - ------------------------------------------------------- */ - -sector(rn) - unsigned rn; - { - unsigned t1,t2,trk,t3,sect; - - t1 = rn % 26; - t2 = t1 << 1; - if(t1 > 12) - t2++; - trk = rn/26; /* zero based absolute track */ - t3 = t2 + 6*trk; /* new logical sector number */ - sect = t3 % 26; /* new zero based absolute sector */ - return ++sect; /* one based absolute sector */ - } - -/* ------------------------------------------------------- - - Name: track(rn) - Result: absolute track number - Errors: --- - Globals: --- - Macros: --- - Procedures: --- - - Action: convert logical sector number to - absolute track This is simply the modulo - 26 process except that track 0 is not - considered part of the logical - sector space. - - ------------------------------------------------------- */ - - -track(rn) - unsigned rn; - { - return rn/26 + 1; - } - - /* ------------------------------------------------------- - - Name: index(str,sstr) - Result: position of string sstr in string str - -1 if not a substring - Errors: --- - Globals: --- - Macros: --- - Procedures: --- - - Action: --- - - ------------------------------------------------------- */ - - -index(str,sstr) - char *str,*sstr; - { - int first_match; - - if( *sstr == 0 ) /* null string is a substring of all strings */ - return 0; - for( first_match=0; *str != *sstr; first_match++) - if( *str == 0 ) - return -1; - else - str++; - while( *sstr ) - if( *str++ != *sstr++ ) - return -1; - return first_match; - } - -/* ------------------------------------------------------- - - Name: force_upr(string) - Result: --- - Errors: --- - Globals: --- - Macros: --- - Procedures: --- - - Action: force each char of string to upper case - - ------------------------------------------------------- */ - -force_upr(string) - char *string; - { - while(*string) - *string = *string++; - return; - } - -/* ------------------------------------------------------- - - Name: print(string,n) - Result: --- - Errors: --- - Globals: --- - Macros: --- - Procedures: putchar() - - Action: print n chars to console starting - at char pointer string - - ------------------------------------------------------- */ - -print(string,n) - char *string; - int n; - { - while(n--) - putchar(*string++); - return; - } - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/UCSDIR.C b/software/CPM/CPM_MC_C1/UCSDIR.C deleted file mode 100644 index e474b96..0000000 --- a/software/CPM/CPM_MC_C1/UCSDIR.C +++ /dev/null @@ -1,255 +0,0 @@ - -/* : : : : : : : : : : : : : : : : : : : : : : : : : : : : - ucsdir -- List the directory of a UCSD Pascal diskette - - H.Moran 10/27/79 - - column labels added 2/13/80 - quick and dirty sort added 2/14/80 - - : : : : : : : : : : : : : : : : : : : : : : : : : : : : */ - - - - -/* : : : : : : : : : : : : : : : : : : : : : : : : : : : : - Constants - : : : : : : : : : : : : : : : : : : : : : : : : : : : : */ - -#define SEL_DSK 14 /* bdos function number */ -#define SET_DMA 26 /* bdos function number */ - -#define SET_TRK 10 /* bios index number */ -#define SET_SEC 11 /* bios index number */ -#define READ 13 /* bios index number */ - -#define DUMMY 0 /* dummy parameter for bios routine */ - -#define D_ENT_SZ 26 /* UCSD directory entry size */ -#define D_TITLE 6 /* offset to entry title */ -#define UCSD_NAM_SZ 17 /* size of the name part of ucsd dir entry */ -#define UCSD_DIR_SZ 2048 /* size of UCSD directory in bytes */ - -#define SECT_SIZE 128 /* bytes per physical sector */ -#define BLOK_SIZE 512 /* bytes per UCSD logical block */ -#define SECT_PER_BLOK 4 /* physical sectors per logical block */ - - -/* : : : : : : : : : : : : : : : : : : : : : : : : : : : : - Globals -- these would be static if it were available - : : : : : : : : : : : : : : : : : : : : : : : : : : : : */ - -int lsn; /* logical sector number */ -int lstlsn; /* last logical sector number */ -int nbytes; /* number of bytes remaining in ucsd file buffer */ -char ucsdbuf[BLOK_SIZE]; /* 1 block buffer for ucsd directory */ -char *ptr; /* pointer to current byte in ucsd buffer */ - - - -main(argc,argv) - int argc; - char *argv[]; - { - - lsn = lstlsn = nbytes = 0; /* init globals */ - ptr = ucsdbuf; - - if( argc != 1 ) { - printf("Proper invocation form is:\n\n"); - printf("ucsdir\n"); - printf("Will list the directory of the UCSD disk on drive B\n"); - exit(1); - } - ucsdir(); - exit(0); - } - - - - -/* ------------------------------------------------------- - - Name: ucsdir() - Result: --- - Errors: sector read error (aborts) - Globals: lsn,lstlsn - Macros: D_TITLE,UCSD_NAM_SZ,UCSD_NAM_SZ - D_ENT_SZ,SECT_PER_BLOK - Procedures: read_ucsd(),putchar(),puts() - - Action: Read from the diskette on drive B - and print on the console - the directory of a presumed - UCSD Pascal formatted disk - - ------------------------------------------------------- */ - - -ucsdir() - { - char ucsd_dir[UCSD_DIR_SZ]; - char *dir,*saved_dir; - int name_len,colct,entries,dunno; - int cmpare(),i; - - read_ucsd(ucsd_dir,(2*SECT_PER_BLOK),4); /* get entire directory */ - - dir = &ucsd_dir[D_TITLE]; /* print volume label */ - puts("\nDirectory of : "); - name_len = *dir++; - while ( name_len-- ) - putchar(*dir++); - puts("\n\n"); - - dir = &ucsd_dir[(D_TITLE + D_ENT_SZ)]; /* point to 1'st entry */ - i = 0; - while( *(dir+i) != 0 && (dir+i) < &ucsd_dir[UCSD_DIR_SZ] ) - i += D_ENT_SZ; - qsort((dir-D_TITLE),(i)/D_ENT_SZ,D_ENT_SZ,&cmpare); - entries = 0; - puts("\nFilename locn len type"); - puts(" Filename locn len type"); - puts("\n---------------- ---- ---- ----"); - puts(" ---------------- ---- ---- ----\n"); - while ( dir < &ucsd_dir[UCSD_DIR_SZ] ) {/* print directory entries */ - saved_dir = dir; - colct = 1; - name_len = *dir++; - if( name_len <= 0 || name_len > (UCSD_NAM_SZ-1) ) - break; - while( name_len-- ) { /* print the file name */ - putchar(*dir++); - colct++; - } - while( colct++ 12) - t2++; - trk = rn/26; /* zero based absolute track */ - t3 = t2 + 6*trk; /* new logical sector number */ - sect = t3 % 26; /* new zero based absolute sector */ - return ++sect; /* one based absolute sector */ - } - -/* ------------------------------------------------------- - - Name: track(rn) - Result: physical track number - Errors: --- - Globals: --- - Macros: --- - Procedures: --- - - Action: convert logical sector number to - absolute track number. This is simply - the modulo 26 process except that - track 0 is not considered part of the - logical sector space. - - ------------------------------------------------------- */ - - -track(rn) - unsigned rn; - { - return rn/26 + 1; - } - - -/* tacked on compare of filenames */ - - -cmpare(x,y) - char *x,*y; - { - int i,j,k; - - x += D_TITLE; - y += D_TITLE; - for( i = *x++, j = *y++; j & i; i--, j--, x++, y++ ) { - if( *x > *y ) - return -1; - if( *x < *y ) - return 1; - } - if( i && ! j ) - return 1; - if( j && ! i ) - return -1; - return 0; - } - - - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/UTIL-WP.C b/software/CPM/CPM_MC_C1/UTIL-WP.C deleted file mode 100644 index f2e6aec..0000000 --- a/software/CPM/CPM_MC_C1/UTIL-WP.C +++ /dev/null @@ -1,257 +0,0 @@ -/* - Utility functions for word processor -*/ - -#include -#include - -#define fputc putc /* I keep getting it wrong */ - -/* - copy title from buf to ttl -*/ - -gettl(buf,ttl) - char *buf; - char *ttl; - { - - while ( ! isspace(*buf) ) - buf++; - while ( isspace(*buf) ) - buf++; - if ( *buf == '\'' || *buf == '"' ) - buf++; - strcpy(ttl,buf); - } - - -/* - space n lines or to bottom of page -*/ - -space(n) - int n; - { - - brk(); - if ( lineno > bottom ) - return; - if( lineno == 0 ) - phead(); - skip(min(n,bottom+1-lineno)); - lineno += n; - if ( lineno > bottom ) - pfoot(); - } - - -/* - put out a line with proper spacing and indenting -*/ - -put(buf) - char buf[]; - { - int i; - - if ( lineno == 0 || lineno > bottom ) - phead(); - for ( i=0; i < tival; i++ ) - fputc(' ',outfile); - tival = inval; - fputs(buf,outfile); - skip(min(lsval-1,bottom-lineno)); - lineno += lsval; - if ( lineno > bottom ) - pfoot(); - } - - -/* - delete leading blanks and set tival -*/ - -leadbl(buf) - char buf[]; - { - int i; - - brk(); - for ( i = 0; buf[i] == ' '; i++ ) - ; - if ( buf[i] != '\n' ) - tival = i; - strcpy(buf,&buf[i]); - } - - - - -/* - put out page header -*/ - -phead() - { - - curpag = newpag++; - if ( m1val > 0 ) { - skip(m1val-1); - puttl(header,curpag); - } - skip(m2val); - lineno = m1val + m2val + 1; - } - - - -/* - put out page footer -*/ - -pfoot() - { - - skip(m3val); - if ( m4val > 0 ) - puttl(footer,curpag); - skip(m4val-1); - lineno = 0; - } - - - -/* - put out title line with optional page number -*/ - -puttl(buf,pageno) - char *buf; - int pageno; - { - char c; - - while ( c = *buf++ ) - if ( c == '#' ) - fprintf(outfile,"%4d",pageno); - else - fputc(c,outfile); - } - -/* - get a non-blank word from in[i] to out[] - and advance i - return length of out[] -*/ - -getwrd(in,i,out) - char in[]; - int *i; - char out[]; - { - int ii; - int j; - char c; - - ii = *i; - while ( (c=in[ii]) == ' ' || c == '\t' ) - ++ii; - j = 0; - while ( (c=in[ii]) != ' ' && c != '\t' && c != '\n' && c != '\0' ) - out[j++] = in[ii++]; - out[j] = '\0'; - *i = ii; - return j; - } - - -/* - output n blank lines -*/ - -skip(n) - int n; - { - int i; - - for ( i = 0; i < n; i++ ) { - putc('\r',outfile); - putc('\n',outfile); - } - } - - - -/* - minimum of two arguments -*/ - -min(a,b) - int a; - int b; - { - return a < b ? a : b; - } - - - -/* - maximum of two arguments -*/ - -max(a,b) - int a; - int b; - { - return a > b ? a : b; - } - - -/* - compare strings for equality - make upper and lower case equivalent -*/ - -samestr(str1,str2) - char *str1,*str2; - { - while ( *str1 ) - if ( toupper(*str1++) != toupper(*str2++) ) - return 0; - if ( *str2 != '\0' ) - return 0; - return 1; - } - - -/* ------------------------------------------------------- - - Name: index(s,t) - Result: position of s in t - Errors: notfound - Globals: --- - Macros: --- - Procedures: - - Action: Return the position (index) in the - string s where string t begins, - or -1 if s doesn't contain t. - Uses 0 as starting position in s - - ------------------------------------------------------- */ - -index(s, t) - char s[], t[]; - { - int i, j, k; - - for (i = 0; s[i] != '\0'; i++) { - for (j=i, k=0; t[k]!='\0' && s[j]==t[k]; j++, k++) - ; - if (t[k] == '\0') - return(i); - } - return -1; - } - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/WDZITDO.C b/software/CPM/CPM_MC_C1/WDZITDO.C deleted file mode 100644 index 39c0b8d..0000000 --- a/software/CPM/CPM_MC_C1/WDZITDO.C +++ /dev/null @@ -1,145 +0,0 @@ -/* - WADUZITDO - - Mini-interpreter from Byte Magazine, The Byte Book of -Pascal, by Larry Kheriaty. WADUZITDO is a PILOT-like little -language, that actually seems to be fairly useful. My 8-year -old nephew took to it right away. I wrote this version to -prove to myself how easy it is to translate Pascal to C; I -think Pascal is vastly over-rated. This version I can -understand; the Pascal version I can't even get to run. - - Syntax as follows: - - T:string Type string on console - A: Accept character from console - M:character Match 'character' against last - character Accepted, set Y if the - same, N if not - J:0 Jump back to last ACCEPT statement - J:n Jump forward to the nth program - marker from here. A program marker - is a '*' at the beginning of a - statement. 1<= n <=9. - S: Stop execution of program. - MUST BE LAST STATEMENT IN PROGRAM!!!!! - -In addition, any statement may have a 'Y' or 'N' attached to it -(after a '*', if one is present) for conditional execution. -The status of the last 'M' executed is tested; if this status -and the conditional match, the statment is executed, otherwise -the statement is skipped. All key chaaracters may be upper or -lower case. - - Controls are as follows: - - '\' Moves the 'cursor' to the beginning - of the program - BACKSPACE Backs 'cursor' up one position - '/' Lists current program line - '$' Begin execution - '%' Deletes from current 'cursor' to EOL - (a newline); actually replaces all - characters with nulls. This gives a - sort of 'insert' capability. - - Anything else simply goes into the buffer as a program - character. Of course, feel free to change any damn - thing you please. - -Very small, but kinda fun... - -*/ - -#include - -#define CLEAR 0x0c /* Clear screen on my video */ -#define BACKSPACE '\010' -#define do_forever for(;;) -#define BUFFSIZE 5000 /* Program buffer size */ -#define TRUE 1 -#define FALSE 0 - -char *p_cntr; -char cbuf; -char program[BUFFSIZE]; - -main() -{ -char i; -putchar(CLEAR); -puts("\t\t\tWADUZITDO V.1.1\n\n>"); -setmem(program,BUFFSIZE,'\0'); -cbuf='\\'; -do_forever{ - switch(cbuf){ - case '\\':p_cntr=program; - break; - case BACKSPACE:if(p_cntr!=program)--p_cntr; - break; - case '/' :putchar('\n'); - list(); - break; - case '$' :putchar('\n'); - execute(); - break; - case '%' :for(i=0;(i<64)&&(*p_cntr!='\n');++i) - *p_cntr++ = '\0'; - *p_cntr++ = '\n'; - puts("\n"); - break; - default :*p_cntr++ = cbuf; - } - if((cbuf = getchar()) == '\n')putchar('>'); - } -} - -execute() -{ -char done,flg,lchr,i,*lst; -p_cntr=program; -done=FALSE; -while(done != TRUE){ - cbuf = *p_cntr; - if(cbuf<'*')cbuf='*'; - switch(toupper(cbuf)){ - case '*':++p_cntr; - break; - case 'Y':case 'N':if(toupper(cbuf)==flg)++p_cntr; - else while((cbuf = *p_cntr++) != '\n'); - break; - case 'A':lst=p_cntr; - lchr=getchar(); - puts("\n"); - p_cntr += 3; - break; - case 'M':p_cntr += 2; - flg = ((lchr == *p_cntr++) ? 'Y' : 'N'); - break; - case 'J':if(*(p_cntr+2) == '0')p_cntr=lst; - else { - i = *(p_cntr+2)-'0'; - while(i) - if(*++p_cntr=='*')--i; - } - break; - case 'T':p_cntr+=2; - list(); - break; - case 'S':done=TRUE; - p_cntr=program; - break; - default: list(); - } - } -} - -list() -{ -char i; -i=0; -do { - putchar(cbuf = *p_cntr++); - } while((++i<=64) && (cbuf != '\n')); -} - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/WP.C b/software/CPM/CPM_MC_C1/WP.C deleted file mode 100644 index 4d57b69..0000000 --- a/software/CPM/CPM_MC_C1/WP.C +++ /dev/null @@ -1,516 +0,0 @@ -/* - Word processor - Translated from the 'format' program in 'Software Tools' -*/ - -#include -#include - -#define fputc putc /* I keep getting it wrong */ - - - -/* - Initialize global variables -*/ - - -initialize() - { - lineno = curpag = 0; - newpag = 1; - plval = PAGELEN; - m1val = m2val = m3val = m4val = 2; - bottom = plval - m3val - m4val; - strcpy(header,"\n"); - strcpy(footer,"\n"); - *outbuf = '\0'; /* initially empty output buffer */ - - fill = YES; - lsval = 1; - rmval = PAGEWIDTH; - inval = tival = ceval = ulval = 0; - - outp = outw = outwds = 0; - - dir = 0; - } - - -/* - Word processing main program -*/ - -main(argc,argv) - int argc; - char *argv[]; - { - char *fgets(); - char ifile[134]; - char ofile[134]; - int ofd; - char inbuf[INSIZE]; /* input line buffer */ - - if( argc != 3 ) - exit(puts("\nusage: WP ")); - if( fopen(argv[1],ifile) == NOFILE ) - exit(printf("\nNo such file : %s",argv[1])); - if( samestr(argv[2],"CON:") ) - outfile = 1; - else if( samestr(argv[2],"LST:") ) - outfile = 2; - else if( samestr(argv[2],"PUN:") ) - outfile = 3; - else { /* output sent to disk */ - if( (ofd = fcreat(argv[2],ofile)) == NOFILE ) - exit(printf("\nCan't open : %s",argv[2])); - else - outfile = ofile; - } - initialize(); - while( fgets(inbuf,ifile) ) { - xpndtab(inbuf); - if( inbuf[0] == COMMAND ) - command(inbuf); - else - text(inbuf); - } - brk(); /* flush any remaining text */ - if( lineno > 0 ) - space(HUGE); - if( outfile == 2 ) /* lineprinter */ - fputc('\f',outfile); - else if( outfile > 3 ) { /* diskfile */ - fputc(0x1a,outfile); - fflush(outfile); - if( close(ofd) == NOFILE ) - printf("\nCan't close : %s",argv[2]); - } - } - - - - -/* - Command handler - - Defined commands: - - BP .bp {+,-} {} * begin page and set page number - BR .br * break - CE .ce {} * center n lines (default 1) - FI .fi * fill - FO .fo {} footer title - HE .he {} header title - IN .in {+,-} indent n co - LS .ls {+,-} line spacing - NF .nf * no fill - PL .pl {+,-} page length of n lines - RM .rm {+,-} right margin n columns - SP .sp {} * space n lines (default 1 ) - TI .ti {+.-} * temporary indent n columns - UL .ul {} underline n lines (default 1) - - note: * => causes a break - -*/ - -command(buf) - char *buf; - { - int comtyp(),getval(),max(); - char argtyp; - int ct; - int spval; - int val; - - val = getval(buf,&argtyp); - switch( ct = comtyp(buf) ) { - case BP: if( lineno > 0 ) - space(HUGE); - set(&curpag,val,argtyp,curpag+1,-HUGE,HUGE); - newpag = curpag; - break; - - case BR: brk(); - break; - - case CE: brk(); - set(&ceval,val,argtyp,1,0,HUGE); - break; - - case FI: brk(); - fill = YES; - break; - - case FO: gettl(buf,footer); - break; - - case HE: gettl(buf,header); - break; - - case IN: set(&inval,val,argtyp,0,0,rmval-1); - tival = inval; - break; - - case LS: set(&lsval,val,argtyp,1,1,HUGE); - break; - - case NF: brk(); - fill = NO; - break; - - case PL: set(&plval,val,argtyp,PAGELEN, - (m1val+m2val+m3val+m4val+1),HUGE); - bottom = plval - m3val - m4val; - break; - - case RM: set(&rmval,val,argtyp,PAGEWIDTH,tival+1,HUGE); - break; - - case SP: set(&spval,val,argtyp,1,0,HUGE); - space(spval); - break; - - case TI: brk(); - set(&tival,val,argtyp,0,0,rmval); - break; - - case UL: set(&ulval,val,argtyp,0,1,HUGE); - break; - - default: break; /* ignore unknown commands */ - } - } - -/* - process Text -*/ - -text(inbuf) - char inbuf[]; - { - int i; - - if( inbuf[0] == ' ' || inbuf[0] == '\n' ) - leadbl(inbuf); - if( ulval > 0 ) { /* underlining */ - underl(inbuf,wrdbuf,INSIZE); - ulval--; - } - if( ceval > 0 ) { /* centering in effect */ - center(inbuf); - put(inbuf); - ceval--; - } - else if( inbuf[0] == '\n' ) /* all blank line */ - put(inbuf); - else if( fill == NO ) /* un-filled text */ - put(inbuf); - else /* filled text */ - for( i=0; getwrd(inbuf,&i,wrdbuf) > 0; ) - putwrd(wrdbuf); - } - - - -/* - Command type -*/ - - -comtyp(buf) - char *buf; - { - int index(); - char cmd[2]; - int i; - - for(i=0; i < 2; i++ ) - cmd[i] = tolower(buf[i+1]); - cmd[2] = '\0'; - if( samestr(cmd,"bp") ) - return BP; - else if( samestr(cmd,"br") ) - return BR; - else if( samestr(cmd,"ce") ) - return CE; - else if( samestr(cmd,"fi") ) - return FI; - else if( samestr(cmd,"fo") ) - return FO; - else if( samestr(cmd,"he") ) - return HE; - else if( samestr(cmd,"in") ) - return IN; - else if( samestr(cmd,"ls") ) - return LS; - else if( samestr(cmd,"nf") ) - return NF; - else if( samestr(cmd,"pl") ) - return PL; - else if( samestr(cmd,"rm") ) - return RM; - else if( samestr(cmd,"sp") ) - return SP; - else if( samestr(cmd,"ti") ) - return TI; - else if( samestr(cmd,"ul") ) - return UL; - else - return UNKNOWN; - } - - - -/* - Get a parameter value from a command line - and whether it is an absolute or relative value -*/ - -getval(buf,argtyp) - char *buf; - char *argtyp; /* pointer to single char */ - { - int abs(),atoi(); - - while( ! isspace(*buf) ) /* skip command */ - buf++; - while( isspace(*buf) ) /* skip whitespace separator */ - buf++; - *argtyp = *buf; /* argument type: +, - or digit */ - if( isdigit(*argtyp) ) - *argtyp = '0'; - if( *argtyp == '+' ) - ++buf; - return abs(atoi(buf)); - } - - - -/* - Set parameter and saturate on out of valid range -*/ - -set(param,val,argtyp,defval,minval,maxval) - int *param; /* address of parameter to be set */ - int val; /* value from command line */ - char argtyp; /* +, -, or 0 */ - int defval; /* default value */ - int minval; /* minimum allowable value */ - int maxval; /* maximum allowable value */ - { - - switch( argtyp ) { - case '+': *param += val; - break; - - case '-': *param -= val; - break; - - case '0': *param = val; - break; - - default: *param = defval; - } - if( *param > maxval ) - *param = maxval; - if( *param < minval ) - *param = minval; - } - - - - - - -/* - Underline - Replace non-whitespace chars with '_','\b',char -*/ - -underl(buf,tbuf,size) - char buf[]; - char tbuf[]; - int size; - { - int i,j; - char c; - - j = 0; - for( i = 0; buf[i] != '\n' && j < size-1; i++ ) { - tbuf[j++] = buf[i]; - if( buf[i] != ' ' && buf[i] != '\t' && buf[i] != '\b' ) { - c = tbuf[--j]; - tbuf[j++] = '_'; - tbuf[j++] = '\b'; - tbuf[j++] = c; - } - } - tbuf[j++] = '\n'; - tbuf[j] = '\0'; - strcpy(buf,tbuf); - } - - - -/* - Center -- fakeout by setting temporary indent -*/ - -center(buf) - char *buf; - { - int width(); - int temp; - - temp = (rmval + tival - width(buf))/2; - tival = max(temp,0); - } - - -/* - Spread words to justify right margin -*/ - -spread(buf,outp,nextra,outwds) - char buf[]; - int outp; - int nextra; - int outwds; - { - int i,j,nb,nholes; - int kk; - - if( nextra <= 0 || outwds <= 1 ) - return; - dir = ++dir & 1; /* toggle bias direction */ - nholes = outwds - 1; - i = outp - 1; /* point at final non-blank */ - j = min(i + nextra,(MAXOUT-2)); - while( i < j ) { - buf[j] = buf[i]; - if( buf[i] == ' ' ) { - if( dir ) - nb = nextra / nholes; /* truncated */ - else - nb = (nextra - 1) / nholes + 1; /* rounded */ - nextra -= nb; - nholes--; - for( ; nb > 0; nb-- ) - buf[--j] = ' '; - } - --i; - --j; - } - } - - - - -/* - put a word in outbuf including margin justification -*/ - -putwrd(wrdbuf) - char *wrdbuf; - { - int width(); - int last; - int llval; - int nextra; - int w; - int i; /* debug only */ - - w = width(wrdbuf); /* printable width of wrdbuf[] */ - last = strlen(wrdbuf) + outp; - llval = rmval - tival; /* printable line length */ - if( outp > 0 && ( (outw+w) > llval || last >= (MAXOUT-2) ) ) { - last -= outp; /* too big */ - nextra = llval - (outw - 1); /* # blanks needed to pad */ - if( nextra > 0 && outwds > 1 ) { - outp--; /* back up to final blank */ - spread(outbuf,outp,nextra,outwds); - outp += nextra; - } - brk(); /* flush previous line */ - } - strcpy(outbuf+outp,wrdbuf); /* add new word to outbuf[] */ - outp = last; - outbuf[outp++] = ' '; /* add a blank behind it */ - outw += (w + 1); /* update output width */ - outwds++; /* increment the word count */ - } - - - - -/* - brk -- end current filled line -*/ - -brk() - { - - if( outp > 0 ) { - outbuf[outp] = '\n'; - outbuf[++outp] = '\0'; - put(outbuf); - } - outp = outw = outwds = 0; - } - - - -/* - width of a printed line -*/ - -width(buf) - char *buf; - { - int wid; - char c; - - wid = 0; - while ( c = *buf++ ) - if( c == '\b' ) - wid--; - else if( c != '\n' ) - wid++; - return wid; - } - - - -/* - expand tabs in the input buffer since - the word processor doesn't really know how - to handle them -*/ - -xpndtab(inbuf) - char *inbuf; - { - char tbuf[300]; - char *i,*t; - int col; - char c; - - col = 0; - i = inbuf; - t = tbuf; - while( c=*i++ ) { - if( c == '\t' ) - do { - *t++ = ' '; - } while( ++col & 7 ); - else - *t++ = c; - } - *t = '\0'; - strcpy(inbuf,tbuf); - } - - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/WP.DOC b/software/CPM/CPM_MC_C1/WP.DOC deleted file mode 100644 index 70cb9e0..0000000 --- a/software/CPM/CPM_MC_C1/WP.DOC +++ /dev/null @@ -1,92 +0,0 @@ -.in 10 set the normal indent at column number 10 -.rm 70 set the right margin at column number 70 -.he WP (word processor) description -.fo ' page # -.sp 3 space 3 lines -.ce 2 center the next two lines -The WP word processor ---------------------- -.ti +4 set a temporary indent 4 columns to the right of indent -WP is a batch mode word processor. It is invoked as: -.sp 2 - WP -.sp 2 -This means accept text with embedded commands from file name - and send the processed text to . These files -are normally CP/M disk files however if the output file is specified -to be: LST: or CON: or PUN: then the output is sent to the List device -(printer), the Console device (crt), or the Punch device respectively. -An example invocation is: -.sp 2 - WP WP.DOC LST: -.sp 2 -.ti +4 -The word processor accepts several commands to justify, center or simply -pass thru text. In addition it allows both a header title at the beginning -of each page and a footer title at the bottom of each page. These both -default to an empty line. -.ti + 4 -Each WP command consists of 3 characters in -the leftmost column and (in most cases) an optional parameter. -Parameters are strings in the case of header and footer titles and -numbers in all other cases. -.ti +4 -In the header and footer strings, leading spaces -are ignored and all occurrences of # are replaced in the output text -by the current page number. If the first non space or tab character in -a header or footer string is " or ' it will be discarded, this is a means -to allow leading spaces in the string since all spaces after the " or ' -are significant. -.bp -.ti +4 -The numeric parameters can be in one of two forms, -an absolute number sets the associated to that number or if out of -legal range, to its limit. A signed (+ or -) number sets the parameter -to its current value + or - the value of the number. This allows setting -for example a paragraph indent margin to be inset from the normal indent -without being required to remember where the current indent is set. -.ti +4 -The default mode is -"fill" i.e. fit as many words as possible on a line to fill out the -line width, however any input lines of text which start with space or -tab maintain that number of columns of leading space. -In any case these lines with leading whitespace cause a "break" i.e. -they cause the following text to begin on a new line. Several commands -also cause a break (see table below). -.ti +4 -In the function categories below -the lines referred to in centering and underlining are input lines, therefore -to cause a single word to be underlined,for instance, simply place it -on a separate input line. Likewise, to avoid the need to count lines, -centering and underlining may be -made continous by setting the number of lines to something huge e.g. 4000 -until it is wished to disable them again at which point specifing 0 -will cause an immediate disable. -.sp 10 -.ce 2 -List of defined commands ------------------------- -.sp 4 -.nf - Command Function Default Break - ------- -------- ------- ----- - .bp n begin page numbered n n = +1 yes - .br cause a break yes - .ce n center the next n lines n = 1 yes - .fi enable filling yes - .fo s set footer title to s empty no - .he s set header title to s empty no - .in n set indent to n n = 0 no - .ls n set line spacing to n n = 1 no - .nf disable filling yes - .pl n set page length to n n = 66 no - .rm n set right margin to n n = 60 no - .sp n space n lines n = 1 yes - .ti n set temporary indent to n n = 0 yes - .ul n underline the next n lines n = 1 yes -.sp 2 -.ti -6 -note: -underlining works only for printers which can back up the print -head one char position at a time - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/WP.OUT b/software/CPM/CPM_MC_C1/WP.OUT deleted file mode 100644 index 63b0be2..0000000 --- a/software/CPM/CPM_MC_C1/WP.OUT +++ /dev/null @@ -1,199 +0,0 @@ - -WP (word processor) description - - - - - - The WP word processor - --------------------- - WP is a batch mode word processor. It is invoked as: - - - WP - - - This means accept text with embedded commands from file name - and send the processed text to . - These files are normally CP/M disk files however if the - output file is specified to be: LST: or CON: or PUN: then - the output is sent to the List device (printer), the Console - device (crt), or the Punch device respectively. An example - invocation is: - - - WP WP.DOC LST: - - - The word processor accepts several commands to justify, - center or simply pass thru text. In addition it allows both - a header title at the beginning of each page and a footer - title at the bottom of each page. These both default to an - empty line. - Each WP command consists of 3 characters in the leftmost - column and (in most cases) an optional parameter. Parameters - are strings in the case of header and footer titles and - numbers in all other cases. - In the header and footer strings, leading spaces are - ignored and all occurrences of # are replaced in the output - text by the current page number. If the first non space or - tab character in a header or footer string is " or ' it will - be discarded, this is a means to allow leading spaces in the - string since all spaces after the " or ' are significant. - - - - - - - - - - - - - - - - - - - - - - - page 1 - - -WP (word processor) description - - - The numeric parameters can be in one of two forms, an - absolute number sets the associated to that number or if out - of legal range, to its limit. A signed (+ or -) number sets - the parameter to its current value + or - the value of the - number. This allows setting for example a paragraph indent - margin to be inset from the normal indent without being - required to remember where the current indent is set. - The default mode is "fill" i.e. fit as many words as - possible on a line to fill out the line width, however any - input lines of text which start with space or tab maintain - that number of columns of leading space. In any case these - lines with leading whitespace cause a "break" i.e. they - cause the following text to begin on a new line. Several - commands also cause a break (see table below). - In the function categories below the lines referred to - in centering and underlining are input lines, therefore to - cause a single word to be underlined,for instance, simply - place it on a separate input line. Likewise, to avoid the - need to count lines, centering and underlining may be made - continous by setting the number of lines to something huge - e.g. 4000 until it is wished to disable them again at which - point specifing 0 will cause an immediate disable. - - - - - - - - - - - List of defined commands - ------------------------ - - - - - Command Function Default Break - ------- -------- ------- ----- - .bp n begin page numbered n n = +1 yes - .br cause a break yes - .ce n center the next n lines n = 1 yes - .fi enable filling yes - .fo s set footer title to s empty no - .he s set header title to s empty no - .in n set indent to n n = 0 no - .ls n set line spacing to n n = 1 no - .nf disable filling yes - .pl n set page length to n n = 66 no - .rm n set right margin to n n = 60 no - .sp n space n lines n = 1 yes - .ti n set temporary indent to n n = 0 yes - .ul n underline the next n lines n = 1 yes - - - note: - underlining works only for printers which can back up the print - - - page 2 - - -WP (word processor) description - - - head one char position at a time - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - page 3 - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C1/~TINY#C1.010 b/software/CPM/CPM_MC_C1/~TINY#C1.010 deleted file mode 100644 index e69de29..0000000 diff --git a/software/CPM/CPM_MC_C2/ACOS.ACO b/software/CPM/CPM_MC_C2/ACOS.ACO deleted file mode 100644 index 1f15afd..0000000 Binary files a/software/CPM/CPM_MC_C2/ACOS.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/ACOSH.ACO b/software/CPM/CPM_MC_C2/ACOSH.ACO deleted file mode 100644 index 6ee0314..0000000 Binary files a/software/CPM/CPM_MC_C2/ACOSH.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/APL-SVAR.DOC b/software/CPM/CPM_MC_C2/APL-SVAR.DOC deleted file mode 100644 index 7097763..0000000 --- a/software/CPM/CPM_MC_C2/APL-SVAR.DOC +++ /dev/null @@ -1,37 +0,0 @@ -Shared Variable System Functions -(taken from IBM VS APL Reference Summary #SX26-3712-6) - -Descriptive Name/ Result -General Form - -access control query Access control vector for the shared -quad SVCy variable named y. - -set access control Access control vector for shared -x quad SVCy variable y is set based on x. New - access control vector is displayed. - -incoming offer query A matrix of variable names offered -quad SVQy by any of the processors named in y. - If y is empty, the result is a vector - of processor numbers making unmatched - offers. - -outgoing offer query A matrix of variable names offered -x quad SVQy to y having a degree of coupling of - x. If y is empty, the result is a - vector of processor numbers offered - variables with that degree of - coupling. - -shared variable offer Variable named y is offered for -x quad SVOy sharing with processor x. Resulting - degree of coupling is returned. - -shared variable Offer of variable named y is retracted. -retraction Degree of coupling of y before -quad SVRy retraction is returned. - -shared variable status Degree of coupling of variable named -quad SVOy y is returned. - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C2/APL.COM b/software/CPM/CPM_MC_C2/APL.COM deleted file mode 100644 index 525657e..0000000 Binary files a/software/CPM/CPM_MC_C2/APL.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/APL.DOC b/software/CPM/CPM_MC_C2/APL.DOC deleted file mode 100644 index b53885b..0000000 Binary files a/software/CPM/CPM_MC_C2/APL.DOC and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/APL.NOT b/software/CPM/CPM_MC_C2/APL.NOT deleted file mode 100644 index d66baa7..0000000 --- a/software/CPM/CPM_MC_C2/APL.NOT +++ /dev/null @@ -1,507 +0,0 @@ - - - APL/Z - by - S. Gownowicz - - - Programming Introduction - for - CP/M - - - - - by - Kevin Smathers - - - - - - - - - - - - - - - - - - - - -Document: APL/Z.1 -Initial release: 8/87 -Update history: - -A short introduction - - This document is tailored for the typical CP/M programmer, -who has never used APL before. It is written to complement S. -Gownowicz's public domain programming language, APL/Z. - The APL programming language was originally defined in a -book by Kenneth Iverson, _A_Programming_Language_, published in -1962. Iverson's intention was to create a symbolic language -which would be adequate for describing concisely, many important -algorithms in mathematics. As a result, the original APL used a -myriad of special symbols including subscripts, superscripts and -two-dimensional program format with arrows to show flow of -control. - A modified version of the original APL, termed APL/360 was -implemented in the late 60's by Iverson and a group at IBM. -Since then APL has been implemented on a variety of machines, all -based largely on the APL/360 design. APL has two distinguishing -characteristics which set it apart from other languages. - -1. It is designed to be interpreted. As such it enjoys all of -the unique capabilities that interactive programming languages -have. APL includes a number of special features designed -exclusively for an interactive environment, inluding immediate -execution of expressions entered at the terminal, and entering -and editing facilities for subprograms that are associated with a -workspace. Workspaces in APL/Z can be saved and restored in part -or in whole. - -2. APL directly processes entire data structures. In APL the -primitive operations accept entire arrays as arguments, and -produce arrays as results. Thus in APL the basic unit of data -tends to be an array rather than a single array element as in -other languages. This emphasis on array-processing gives APL -programs a unique appearance quite different from other -languages. - - The specialized character set of APL lends it enough power -that a typical one line program can result in a surprising amount -of computation. APL is ideally suited for the user who wishes to -avoid key-board heavy languages. It is well suited to the -interactive environment, because only a few lines of input are -required to get the results you might typically be looking for. -On the other hand, APL is poorly suited for long programs, or -programs which are meant to be maintained over a long period of -time. - - ----- - Programming languages specialist Daniel McCracken [1970] - notes that it once took him four hours to decode a four- - line APL program. - - -Introduction to the APL:ASCII keyboard - - APL (A Programming Language) is an unstructured language, -with a specialized character set devoted to performing the -functions of the programming language. In APL there are no -lowercase alphabetic symbols. Unshifted letters produce their -uppercase counterparts, while shifted letters produce the special -APL symbols. To avoid confusion, we will use lowercase symbols -for unshifted APL characters. - Since CP/M machines typically don't have APL character sets, -we will be using some special conventions. They fall into four -categories. - - 1. characters which must be remapped - 2. characters which are common to both APL and ASCII - 3. characters which cannot be remapped - 4. extra characters - -1. The characters listed below have been remapped for ascii: -_________________________________________________________________ - APL ASCII -_____________ - .. - Dieresis (Umlaut) is unmapped (unused in APL) -_____________ - __ - _ High-minus becomes underline -_____________ - - <= { Less-than-or-equal becomes open-brace -_____________ - - >= } Greater-than-or-equal becomes close-brace -_____________ - - /= # Not-equal becomes pound-sign -_____________ - - \/ ! Logical-or becomes exclamation-point -_____________ - - /\ & Logical-and becomes ampersand -_____________ - - x * Times becomes asterisk -_____________ - . - - % Divided-by becomes percent-sign -__.__________ - - <- ` Left-arrow becomes grave-accent -_____________ - - -> @ Right-arrow becomes at-sign -__________________________________________________________________ -2. Certain keys on the APL keyboard also appear on the ascii -keyboard. These are not remapped. They are: -__________________________________________________________________ - -[ Open bracket -] close bracket -( open paren -) close paren -/ stroke -\ back-stroke -, comma -. period -; semi-colon -: colon -+ plus -- minus -< less-than -> greater-than -= Equals -__________________________________________________________________ - - -3. Apl also uses additional symbols which we won't be mapping. -These correspond to the shifted keyboard keys. -__________________________________________________________________ - -Q Question mark see (?) in pt. 4 -W Omega the greek symbol -E Element epsilon -R Rho the greek symbol -T Invert (tilde`) see (~) in pt. 4 -Y Up-arrow -U Down-arrow -I iota the greek symbol -O circle a large open circle -P power see (^) in pt. 4 -A alpha the greek symbol -S cieling an upside-down 'L' -D floor a right-side-up 'L' -F underline -G del an upside-down delta -H delta the greek symbol -J little-circle a small open circle -K single quote see (') in pt. 4 -L quad a large open square -Z subset an open semi-circle -X superset a close semi-circle -C intersection an upside-down 'U' -V union a right-side-up 'U' -B encode an upside-down 'T' -N decode a right-side-up 'T' -M vertical bar see (|) in pt. 4 -__________________________________________________________________ - - - -4. That leaves us with several ASCII symbols which haven't yet -been used, so in order to simplify reading and typing in -programs, the rest of the ascii set has been assigned to the -characters on the shifed alpha APL keyboard which they most -resemble, or whose function they most closely match. -__________________________________________________________________ - -| M -~ T -$ H -^ P -' K -" K -? Q -__________________________________________________________________ - - -Delving into the APL interpreter - - APL lines begin tabbed in 8 spaces. Here you will type you -command, and the interpreter will respond on the next line. - - 2 -2 - 2+2 -4 - - Here are four dyadic (meaning with two operands) operators -you should recognize. - - 2*3 multiply -6 - 4%2 divide -2 - 51 subract -4 - 2+1 add -3 - - An important feature to remember about APL is that dyadic -operators always use whatever they find immediately on their left -side, and the result of evaluating everything on their right. -This means that '+' has no precedence over '*'. -.___________________. -. . -. 2*3+16%3 . -. + . -. + . -. + . -. + . -.___________________. - - So that this equation would produce: - - 2*3+16%3 -4 - - This holds true for all operators, not just mathematical -ones. However, this sequence can be altered in APL when -neccessary, by grouping the term which are to be evaluated first -within parentheses. - - (2*3)+1(6%3) -5 - - Produces the expected result. These operators can also be -applied to lists. A list is simply a sequence of numbers -separated by spaces. Try typing - - 1+1 2 3 -2 3 4 - - 2*3 2 1 -6 4 2 - - APL also makes reals available to you, simply by putting a -decimal point within the number. Exponential notation can also -be used as you would expect. - - 3.14159*2 -6.28318 - - 6.22e12%1000 -6.022e9 - - Remember that uppercase letters are reserved for APL -functions. Another operator you will need to know is the unary -minus. - - _3+5 -2 - - And the single quote which is used to create arrays of ASCII -data. - - 'abcde' -abcde - - abcde is a 5 element list. - - Dyadic operators can also be used on two arrays. In this -case, their shapes must be equal. (More on shapes later.) - - 1 2 3*4 5 6 -4 8 10 - - Operands are paired two at a time, to produce the result. -Since arrays are used so frequently in APL, a simple method is -provided for creating arrays which count up. In general, the -monadic iota function will produce an array starting at 1 and -counting up to the argument on it's right side. Iota expects to -find a scalar, or a vector of at most one element on it's right -side. - - Monadic Iota: - - I5 -1 2 3 4 5 - - I5 5 -rank error - I5 5 - ^ - - Attempting to feed iota a higher degree vector will result -in the error shown. APL is complaining that the right hand value -is not of the proper rank, also known as dimension. - Another dyadic function is the assignment function, left -arrow. We will use the grave-accent (`) to represent this -character. Values, such as arrays, character arrays, and scalars -can be freely assigned to variables using the left-arrow. -Variables must be alphabetic, or may additionally start with the -symbol delta ($). - - $hello`'Hi there' - hello -Hi there - - 'hello' is an example of a character vector (its shape has -one dimension, arrays have more than one dimension in the general -case). Remember, variables cannot be uppercase, as those are -reserved for the APL functions. - The assignment statement introduced above, is another -example of a dyadic function. This particular function, however, -must use a variable as it's left side. In all other respects, it -fits the normal perception of what a dydadic function should be. -For example, you might type a line like this: - - a`1+b`3 - - Evaluated right to left, this resolves to ( b`3 ),( a`b+1 ). -In other words, a will have the value 4 and b will have the value -3. But now that we have these fine variables defined, we will -need a way to save and recall them for later use. - For this purpose, there are the so called system commands. -Basically, system commands are used to make enquiries about the -status of the environment or work_space. Here are a few to start -with: - - )VARS list all defined variables - )ERASE var_list deallocate a list of variables - )SAVE ws_name save the current workspace as ws_name - )LOAD ws_name load a workspace from ws_name - )FNS list all defined functions - - Additionally, it should now be high time to go over some of -the errors that you may encounter within APL - - CHARACTER ERROR - an unknown character has appeared out of place. - SYNTAX ERROR - a badly formed expression was typed - DOMAIN ERROR - the function is not defined for the value given. - LENGTH ERROR - a binary function was used with unmatched vector shapes - VALUE ERROR - the indicated variable has not been assigned a value - RANK ERROR - the number of dimensions of the input is not allowed - WS FULL - the last function used up all of the unused workspace - DEFN ERROR - your definition was illegal, one of the variable names - was probably at fault. - - In APL, the standard way of editing is to backspace until -you are over the character in error, press ATTN and type the tail -of the string again. Otherwize, backspace will not remove -characters from the line. - Back to functions now, here is another diadic function. The -function catenation is represented by a comma (,). For example, - - a`'hi' - b`' there' - a,b -hi there - - This is an example of the catenation of two character -vectors. Refreshing your memory, a dyadic function is one which -acts on two values. A monadic function works with just one -value. A niladic function is one which requires no values for -input at all. - This all leads to user defined functions. The great power -of APL is most closely linked with its ability to define -functions on the fly which can be used in the same way that all -of the system defined functions are. - - As with all identifiers, function names must begin with an -alphabetic (unshifted) letter or delta ($), and may continue with -any other alpha or numeric characters, but not APL character set -characters. S$ and T$ are reserved variables which will be -discussed later. - - A function is defined as follows: - - G function_name - equations - G - - The surrounding del's (G) are the function definition -characters. They open and close the function editor. The -function above would have no explicit results, and no input -variables. The function would be niladic. A common use for -niladic functions without explicit results is to list all of the -member functions of a workspace. A niladic function would be -written which included that documentation in print statements, -and would have a name you could remember such as 'menu'. - - G menu - 'This is a file of useless functions:' - 'GRIK: experimental nothing function' - 'GRAK: same as above' - 'YICK: pretty boring huh?' - G - menu -This is a file of useless functions: -GRIK: experimental nothing function -GRAK: same as above -YICK: pretty boring huh? - - Non-explicit functions always return each of the results -generated on a separate line, as though they had been typed at -the keyboard in that sequence. Non-explicit functions do not -pass values to other functions. That is the job of the explicit -function. - - G z`pi - z`3.1415 - G - pi -3.1415 - 2*pi -6.2830 - - Before exiting the function, the explicit variable in the -explicit function declaration must be given a value to return to -the next function. The next form of the function declaration is -the monadic function. For instance, the following function -would change temperatures from Fahrenheit to Celsius. - - G c ` temp f - c ` (f-32) * 5 / 9 - G - temp 32 -0 - - The full fledged form of the function is a dyadic, explicit -function. Listed below are all of the possible combinations -which can be used to create a function - -Argl Explicit Non Explicit - 0 Niladic G z`fn G fn - 1 Monadic G z`fn a G fn a - 2 Dyadic G z`a fn b G a fn b - - I'd like to take just a moment to digress. When talking -about functions in any language, it is important to talk about -scoping rules. In basic, where there are no local variables, -scoping is global. In Pascal, where a variable name refers to -the name most closely linked to its own structural shell, scoping -is termed static. In general scoping means, "If I define two -variables, both with the name 'x' which one will I be referring -to in this procedure?" APL uses a concept of scoping which it -has in common with LISP. If the variable is not defined locally, -it is checked for locality to the procedure which called it, and -if not there, the process is repeated until the variable is found -by unwinding the calling stack. This type of scoping is named -'dynamic'. - As you must assume from the preceding discussion, APL has -its own way of declaring internal variables. These variables are -available to all functions called by the function which defined -them, until the name is redefined. - - The form for the declaration of a local variable is as -follows: - - G fn ; lv1 ; lv2 ; lv 3 - - There may be as many local variables as necessary, each -appended to the list with a new semicolon. Old values for the -variables named are restored when the function finally returns. -The local values are not retained. - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C2/ASIN.ACO b/software/CPM/CPM_MC_C2/ASIN.ACO deleted file mode 100644 index aeea297..0000000 Binary files a/software/CPM/CPM_MC_C2/ASIN.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/ASINH.ACO b/software/CPM/CPM_MC_C2/ASINH.ACO deleted file mode 100644 index 44ac7f3..0000000 Binary files a/software/CPM/CPM_MC_C2/ASINH.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/ATAN.ACO b/software/CPM/CPM_MC_C2/ATAN.ACO deleted file mode 100644 index 2c05bd5..0000000 Binary files a/software/CPM/CPM_MC_C2/ATAN.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/ATANH.ACO b/software/CPM/CPM_MC_C2/ATANH.ACO deleted file mode 100644 index caa3919..0000000 Binary files a/software/CPM/CPM_MC_C2/ATANH.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/CN.ACO b/software/CPM/CPM_MC_C2/CN.ACO deleted file mode 100644 index 9275f72..0000000 Binary files a/software/CPM/CPM_MC_C2/CN.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/COMPLEX.AWS b/software/CPM/CPM_MC_C2/COMPLEX.AWS deleted file mode 100644 index 6bcdbe1..0000000 Binary files a/software/CPM/CPM_MC_C2/COMPLEX.AWS and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/COSECH.ACO b/software/CPM/CPM_MC_C2/COSECH.ACO deleted file mode 100644 index 33485ec..0000000 Binary files a/software/CPM/CPM_MC_C2/COSECH.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/COSH.ACO b/software/CPM/CPM_MC_C2/COSH.ACO deleted file mode 100644 index 8eb15bb..0000000 Binary files a/software/CPM/CPM_MC_C2/COSH.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/COTH.ACO b/software/CPM/CPM_MC_C2/COTH.ACO deleted file mode 100644 index f9ded30..0000000 Binary files a/software/CPM/CPM_MC_C2/COTH.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/CRCKLIST.CRC b/software/CPM/CPM_MC_C2/CRCKLIST.CRC deleted file mode 100644 index 87fd290..0000000 --- a/software/CPM/CPM_MC_C2/CRCKLIST.CRC +++ /dev/null @@ -1,44 +0,0 @@ - ---> FILE: ACOS .ACO CRC = D3 82 ---> FILE: ACOSH .ACO CRC = 7C 85 ---> FILE: APL .COM CRC = 2D D3 ---> FILE: APL .DOC CRC = 65 33 ---> FILE: APL .NOT CRC = D3 AD ---> FILE: APL-SVAR.DOC CRC = F4 E5 ---> FILE: ASIN .ACO CRC = 6A F7 ---> FILE: ASINH .ACO CRC = 5F 8F ---> FILE: ATAN .ACO CRC = C2 30 ---> FILE: ATANH .ACO CRC = AF E5 ---> FILE: CN .ACO CRC = D9 CF ---> FILE: COMPLEX .AWS CRC = E0 06 ---> FILE: COSECH .ACO CRC = 9F 1D ---> FILE: COSH .ACO CRC = A1 51 ---> FILE: COTH .ACO CRC = E7 98 ---> FILE: DN .ACO CRC = 2A B0 ---> FILE: DROP .ACO CRC = F9 9B ---> FILE: DTR .ACO CRC = CA 7F ---> FILE: FACT .ACO CRC = 94 8C ---> FILE: GAMMA .ACO CRC = AF 3C ---> FILE: GEN .ACO CRC = 71 BE ---> FILE: INNERPRO.ACO CRC = 1F A1 ---> FILE: IP .ACO CRC = 61 1F ---> FILE: J .ACO CRC = 99 B0 ---> FILE: JELF .ACO CRC = 8A 4A ---> FILE: LAMINATE.ACO CRC = EC C7 ---> FILE: LIFE .ACO CRC = 92 7D ---> FILE: MATDIV .ACO CRC = 38 A1 ---> FILE: MATINV .ACO CRC = 04 FB ---> FILE: NOTES .ACO CRC = C3 44 ---> FILE: PERM .ACO CRC = 9E D5 ---> FILE: REVERSE .ACO CRC = AC C1 ---> FILE: ROTATE .ACO CRC = B0 3D ---> FILE: RTD .ACO CRC = A8 F4 ---> FILE: SECH .ACO CRC = F8 23 ---> FILE: SINH .ACO CRC = FC D9 ---> FILE: SN .ACO CRC = A4 26 ---> FILE: TAKE .ACO CRC = BE 7D ---> FILE: TANH .ACO CRC = AB F6 ---> FILE: TRANSPOS.ACO CRC = 81 63 ---> FILE: TRIGFNS .AWS CRC = 30 4C ---> FILE: UNIMAT .ACO CRC = CB 4E ---> FILE: WSFNS .AWS CRC = 7F C7 \ No newline at end of file diff --git a/software/CPM/CPM_MC_C2/DN.ACO b/software/CPM/CPM_MC_C2/DN.ACO deleted file mode 100644 index b7706db..0000000 Binary files a/software/CPM/CPM_MC_C2/DN.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/DROP.ACO b/software/CPM/CPM_MC_C2/DROP.ACO deleted file mode 100644 index e2f242d..0000000 Binary files a/software/CPM/CPM_MC_C2/DROP.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/DTR.ACO b/software/CPM/CPM_MC_C2/DTR.ACO deleted file mode 100644 index b42c559..0000000 Binary files a/software/CPM/CPM_MC_C2/DTR.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/FACT.ACO b/software/CPM/CPM_MC_C2/FACT.ACO deleted file mode 100644 index 2b59087..0000000 Binary files a/software/CPM/CPM_MC_C2/FACT.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/GAMMA.ACO b/software/CPM/CPM_MC_C2/GAMMA.ACO deleted file mode 100644 index 562cd2c..0000000 Binary files a/software/CPM/CPM_MC_C2/GAMMA.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/GEN.ACO b/software/CPM/CPM_MC_C2/GEN.ACO deleted file mode 100644 index 9f768c1..0000000 Binary files a/software/CPM/CPM_MC_C2/GEN.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/INNERPRO.ACO b/software/CPM/CPM_MC_C2/INNERPRO.ACO deleted file mode 100644 index 7e2a70d..0000000 Binary files a/software/CPM/CPM_MC_C2/INNERPRO.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/IP.ACO b/software/CPM/CPM_MC_C2/IP.ACO deleted file mode 100644 index 15a9df6..0000000 --- a/software/CPM/CPM_MC_C2/IP.ACO +++ /dev/null @@ -1 +0,0 @@ - Gr^x ip ym^1 ;50[ inner>r^r,:/x;n<[-y;z^=z ;180[ ~+0%f{/ \ No newline at end of file diff --git a/software/CPM/CPM_MC_C2/J.ACO b/software/CPM/CPM_MC_C2/J.ACO deleted file mode 100644 index bb1c7f6..0000000 Binary files a/software/CPM/CPM_MC_C2/J.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/JELF.ACO b/software/CPM/CPM_MC_C2/JELF.ACO deleted file mode 100644 index 40e398e..0000000 Binary files a/software/CPM/CPM_MC_C2/JELF.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/LAMINATE.ACO b/software/CPM/CPM_MC_C2/LAMINATE.ACO deleted file mode 100644 index f0ac89f..0000000 --- a/software/CPM/CPM_MC_C2/LAMINATE.ACO +++ /dev/null @@ -1 +0,0 @@ - Gr^a laminate b matdiv ;20[ z^++Ib^1YRb{J.%I1YRb{matdiv:b G )}/1 2(RRb{/er1 ;20[ ~+++1YRa{(1YRb{)+m^1YRa{#n^1URa{/er2 ;30[ ~+v^1(RRb{/q1 ;40[ b^+m,1{R,b ;50[ q1>p^1URb ;60[ pp^In ;70[ factor^+"1YRa{R*n1^1 ;80[ mv^S/Ma ;90[ loo \ No newline at end of file diff --git a/software/CPM/CPM_MC_C2/NOTES.ACO b/software/CPM/CPM_MC_C2/NOTES.ACO deleted file mode 100644 index f2fc654..0000000 Binary files a/software/CPM/CPM_MC_C2/NOTES.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/PERM.ACO b/software/CPM/CPM_MC_C2/PERM.ACO deleted file mode 100644 index a2505ea..0000000 Binary files a/software/CPM/CPM_MC_C2/PERM.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/REVERSE.ACO b/software/CPM/CPM_MC_C2/REVERSE.ACO deleted file mode 100644 index f01a5b7..0000000 --- a/software/CPM/CPM_MC_C2/REVERSE.ACO +++ /dev/null @@ -1 +0,0 @@ - Gr^reverse xp^1URb ;60[ pp^In ;70[ factor^+"1YRa{R*n1^1 ;80[ mv^S/Ma ;90[ loo \ No newline at end of file diff --git a/software/CPM/CPM_MC_C2/ROTATE.ACO b/software/CPM/CPM_MC_C2/ROTATE.ACO deleted file mode 100644 index 1b9ab25..0000000 --- a/software/CPM/CPM_MC_C2/ROTATE.ACO +++ /dev/null @@ -1 +0,0 @@ - Gz^a rotate b~++1E0(xlbMa{}+1(-/xlb{}0(cb{/l2 ;70[ z^b ;80[ ~0 ;90[ l2>tcb^-/iURb ;100[ v^tcb-"1:Ixlb ;110[ e^tcb-"1:xlb ;120[ rvlz^cbR1Y0Rb ;130[ rvlb^,b ;140[ rvla^,a ;150[ j^m^1 ;160[ outer>k^1 ;170[ inner>rvlz;j:v[^rvla;m[rvlb;j:v[ ;180[ k^k:1 ;190[ j^j:1 ;200[ m^m:1 ;210[ ~+k$tcb{/inner ;220[ j^j:e ;230[ ~+j$cb{/outer ;240[ z^+Rb{Rrvlz G solve ;200[ mv \ No newline at end of file diff --git a/software/CPM/CPM_MC_C2/RTD.ACO b/software/CPM/CPM_MC_C2/RTD.ACO deleted file mode 100644 index b2af604..0000000 Binary files a/software/CPM/CPM_MC_C2/RTD.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/SECH.ACO b/software/CPM/CPM_MC_C2/SECH.ACO deleted file mode 100644 index de355f8..0000000 Binary files a/software/CPM/CPM_MC_C2/SECH.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/SINH.ACO b/software/CPM/CPM_MC_C2/SINH.ACO deleted file mode 100644 index 30c75e1..0000000 Binary files a/software/CPM/CPM_MC_C2/SINH.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/SN.ACO b/software/CPM/CPM_MC_C2/SN.ACO deleted file mode 100644 index 23f4be4..0000000 --- a/software/CPM/CPM_MC_C2/SN.ACO +++ /dev/null @@ -1 +0,0 @@ - Gr^k sn x ;10[ k0^k ;20[ x0^x ;30[ jelf ;40[ r^sn1 G 20[ y^x0 ;30[ ~++sck#0{,sck'0{/neg,pos ;40[ dn1^cn1^2=b^d:a^=d^Px0 ;50[ sn1^tanh x0 ;60[ ~0 ;70[ neg>cm^*sck=d^1*sck ;80[ d^dP0.5 ;90[ y^d:x0 ;100[ pos>a^dn1^1 ;110[ geo^ari^12R0 ;120[ i^1 ; \ No newline at end of file diff --git a/software/CPM/CPM_MC_C2/TAKE.ACO b/software/CPM/CPM_MC_C2/TAKE.ACO deleted file mode 100644 index 521af04..0000000 Binary files a/software/CPM/CPM_MC_C2/TAKE.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/TANH.ACO b/software/CPM/CPM_MC_C2/TANH.ACO deleted file mode 100644 index 3339469..0000000 Binary files a/software/CPM/CPM_MC_C2/TANH.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/TRANSPOS.ACO b/software/CPM/CPM_MC_C2/TRANSPOS.ACO deleted file mode 100644 index 9c12768..0000000 --- a/software/CPM/CPM_MC_C2/TRANSPOS.ACO +++ /dev/null @@ -1 +0,0 @@ - Gr^transpose x~++Rrx{(RRr^+Irx;i^i:1[{J.:rx;i:1[-r{/lp ;70[ rx^Rr ;80[ x^,x ;90[ r^,r ;100[ r^rxRx^x;r[ ;110[ Lo^o G 0[ l2>tcb^-/iURb ;100[ v^tcb-"1:Ixlb ;110[ e^ \ No newline at end of file diff --git a/software/CPM/CPM_MC_C2/TRIGFNS.AWS b/software/CPM/CPM_MC_C2/TRIGFNS.AWS deleted file mode 100644 index 57cf4ac..0000000 Binary files a/software/CPM/CPM_MC_C2/TRIGFNS.AWS and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/UNIMAT.ACO b/software/CPM/CPM_MC_C2/UNIMAT.ACO deleted file mode 100644 index 17d8356..0000000 Binary files a/software/CPM/CPM_MC_C2/UNIMAT.ACO and /dev/null differ diff --git a/software/CPM/CPM_MC_C2/WSFNS.AWS b/software/CPM/CPM_MC_C2/WSFNS.AWS deleted file mode 100644 index c5858ce..0000000 Binary files a/software/CPM/CPM_MC_C2/WSFNS.AWS and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/BIT.JRL b/software/CPM/CPM_MC_C3/BIT.JRL deleted file mode 100644 index fe1d474..0000000 Binary files a/software/CPM/CPM_MC_C3/BIT.JRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/BIT.LIB b/software/CPM/CPM_MC_C3/BIT.LIB deleted file mode 100644 index f02f311..0000000 --- a/software/CPM/CPM_MC_C3/BIT.LIB +++ /dev/null @@ -1,45 +0,0 @@ -Package Bit Is - -- Bit operations library - -- Last modified 3/27/83 - - - -- Copyright 1982,1983 RR Software, P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. - - - Subtype bit_num Is Integer Range 0..15; - - Procedure Setbit(Val : In Out Integer; Bit : In Bit_num); - -- Set bit number bit - Procedure Clrbit(Val : In Out Integer; Bit : In Bit_num); - -- Clear bit number bit - Function Tstbit(Val : In Integer; Bit : In Bit_num) Return Boolean; - -- Return the value of bit number bit (1 = True) - - Function Land(Val1,Val2 : In Integer) Return Integer; - -- Logical And - Function Lor(Val1,Val2 : In Integer) Return Integer; - -- Logical Or - Function Lxor(Val1,Val2 : In Integer) Return Integer; - -- Logical Xor - Function Lnot(Val : In Integer) Return Integer; - -- Logical Not - - Function Peek (Addr : In Integer) Return Byte; - -- Returns the byte at address in the data segment - Procedure Poke (Addr : In Integer; Val : In Byte); - -- Changes the byte at address in the data segment to Val - - Procedure InPort (Portnum : In Integer; Value : Out Byte); - -- Reads a byte from the port portnum, returns it in Value - -- Z80 Only! Would need self-modifying code for the 8080 - Procedure Outport (Portnum : In Integer; Value : In Byte); - -- Writes a byte (Value) to the port portnum - -- Z80 Only! Would need self-modifying code for the 8080 - -End Bit; -nteger; Bit : In Bit_num) Return Boolean; - -- Return the value of bit number bit (1 = True) - - Function Land(Val1,Val2 : In \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/BIT.SYM b/software/CPM/CPM_MC_C3/BIT.SYM deleted file mode 100644 index 66c4817..0000000 Binary files a/software/CPM/CPM_MC_C3/BIT.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/CHAINLIB.JRL b/software/CPM/CPM_MC_C3/CHAINLIB.JRL deleted file mode 100644 index 02ff104..0000000 Binary files a/software/CPM/CPM_MC_C3/CHAINLIB.JRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/CHAINLIB.LIB b/software/CPM/CPM_MC_C3/CHAINLIB.LIB deleted file mode 100644 index 22c511f..0000000 --- a/software/CPM/CPM_MC_C3/CHAINLIB.LIB +++ /dev/null @@ -1,31 +0,0 @@ -Package Chainlib Is - -- The program chaining and calling library - -- Last modified 9/ 9/82 - - -- Copyright 1982 RR Software, P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. - - Procedure Chain(Str : In String); - -- Chains a program, saving the data segment - -- Note: The Jlib80 library must be the same for both the chaining - -- and chained programs for this routine to work - Procedure Simple_Chain(Str : In String); - -- Chains a program, destroying the data segment - Procedure Prog_Call(Str : In String); - -- Calls a program (Not Implemented) - Procedure Prog_Return; - -- Returns from a called program (Not Implemented) - -End Chainlib; -e libraries. - - Procedure Chain(Str : In String); - -- Chains a program, saving the data segment - -- Note: The Jlib80 library must be the same for both the chaining - -- and chained programs for this routine to work - Procedure Simple_Chain(Str : Package Chainlib Is - -- The program chaining and calling library - -- Last modified 9/ 9/82 - - -- Copyright 1982 RR \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/CHAINLIB.SYM b/software/CPM/CPM_MC_C3/CHAINLIB.SYM deleted file mode 100644 index ed21b6f..0000000 Binary files a/software/CPM/CPM_MC_C3/CHAINLIB.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/CRCKLIST.CRC b/software/CPM/CPM_MC_C3/CRCKLIST.CRC deleted file mode 100644 index c5cd36c..0000000 --- a/software/CPM/CPM_MC_C3/CRCKLIST.CRC +++ /dev/null @@ -1,51 +0,0 @@ -JLINK .COM CRC = E2 48 -JLIB80 .JRL CRC = 28 9E -OPCODE .JRL CRC = CD 2C -UTIL .JRL CRC = 47 11 -BIT .JRL CRC = 7B 61 -SECT .LIB CRC = BA 2F -LONGOPS .JRL CRC = 44 B4 -LONGIO .JRL CRC = BF 41 -IO .JRL CRC = 58 97 -BLKIO .JRL CRC = 5E CE -RANDIO .PKG CRC = 45 72 -CHAINLIB.JRL CRC = 29 85 -LONGIO .SYM CRC = B0 25 -BLKIO .SYM CRC = 18 C8 -FLOATIO .SYM CRC = E5 29 -JLIB80 .SYM CRC = D0 2D -MATHLIB .SYM CRC = B0 F3 -STANDARD.SYM CRC = A7 96 -IO .SYM CRC = D0 42 -CHAINLIB.SYM CRC = 92 28 -TIMELIB .SYM CRC = 0D C4 -STRLIB .SYM CRC = 74 E1 -LONGOPS .SYM CRC = FB 7F -FLOATOPS.LIB CRC = 0E 83 -RANDOM .SYM CRC = BD 70 -BIT .SYM CRC = 50 41 -UTIL .SYM CRC = 22 1E -OPCODE .SYM CRC = DE 1D -FLOATOPS.SYM CRC = FD 91 -BLKIO .LIB CRC = 38 CD -JLIB80 .LIB CRC = F6 B5 -STRLIB .JRL CRC = 2D 69 -UTIL .LIB CRC = 23 D3 -TIMELIB .LIB CRC = BE 54 -BIT .LIB CRC = D9 25 -IO .LIB CRC = F9 AF -CHAINLIB.LIB CRC = 2B 1B -STRLIB .LIB CRC = 04 88 -LONGIO .LIB CRC = 10 57 -LONGOPS .LIB CRC = 67 D2 -RANDOM .JRL CRC = 33 28 -FLOATIO .JRL CRC = E0 D4 -FLOATIO .LIB CRC = 5A AD -RANDOM .LIB CRC = 6B 71 -RANDIO .LIB CRC = 82 10 -OPCODE .LIB CRC = C3 EF -MEMCHK .COM CRC = 7E F3 -FLOATOPS.JRL CRC = 15 29 -MATHLIB .JRL CRC = 37 9E -MATHLIB .LIB CRC = 1D 68 - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/ERROR.MSG b/software/CPM/CPM_MC_C3/ERROR.MSG deleted file mode 100644 index 0b3b3fe..0000000 --- a/software/CPM/CPM_MC_C3/ERROR.MSG +++ /dev/null @@ -1 +0,0 @@ -%This message (0) is unused - Call RRSoes not match that of a$Maximum Block nesting level exceeded Variant Type!Attempt to Index)Maximum Subprogram nesting level exceedednot match that of aSymbol table overflow does not match Variant Type!Attempt to IndexUndefined Forward Subprogramay'Type does not match that of aMultiply Defined Labeldoes not match Variant Type!Attempt to IndexUndefined Label for this Array'Type does not match that of a)Concatenation takes only String Argumentsant Type!Attempt to Index6More Code was generated than is allowed in a .JRL filet of a*Too many enumeration literals for one typent Type!Attempt to Index*Dynamic Range not allowed in Specificationot match that of a!Range of index type is not statictch Variant Type!Attempt to IndexIdentifier is not definedArray'Type does not match that of aRange Table Overflowg does not match Variant Type!Attempt to Index!Cannot be used in a Specificationpe does not match that of a.Version Number of this SYM file is Not currentype!Attempt to IndexMultiply defined Subprogramray'Type does not match that of a&Cannot use Dot notation with this nameariant Type!Attempt to Index-Return Type does not match that of Expressionmatch that of a&Procedures can not have a Return valueariant Type!Attempt to Index Functions require a Return valueype does not match that of aMultiply defined type does not match Variant Type!Attempt to Index5Expression Type does not match that of Type specifiedat of a.The enumeration constant has already been usedype!Attempt to Index$The Package STANDARD can't be WITHeddoes not match that of a Multiply defined record subfieldatch Variant Type!Attempt to IndexIndex type is not subrangerray'Type does not match that of a-Too many WITH's, The Package table overflowedType!Attempt to Index%This SYM file is internally incorrectoes not match that of a&Package number not found (* Sys Err *)ariant Type!Attempt to IndexMultiply defined Identifierray'Type does not match that of aMissing Constant Initializationmatch Variant Type!Attempt to IndexValue is not a constants Array'Type does not match that of a/Types of expresion and declaration do not matchpe!Attempt to Index"Cannot use this type in a subrangee does not match that of a-The STANDARD.SYM file is internally incorrectType!Attempt to IndexValue is not in Allowed Rangey'Type does not match that of a%Temporary Program Name File not foundVariant Type!Attempt to IndexExpression types do not matchy'Type does not match that of aThis does not name a recordnot match Variant Type!Attempt to Index This does not name a valid fieldype does not match that of a$Temporary file STRHASH.$$$ not found Variant Type!Attempt to Index$STANDARD Symbol Table file not founddoes not match that of a*Temporary Parsing file PARSE.$$$ not foundnt Type!Attempt to Index$Temporary file SYMTABS.$$$ not founddoes not match that of a,Temporary reduction file RINFO.$$$ not found Type!Attempt to Index+Expression cannot be qualified to this typet match that of a Cannot be used in a Package Bodyatch Variant Type!Attempt to Index#This feature is not in Standard Ada does not match that of a5Pragma List(); Not allowed when Listing Option is Offempt to Index$Only Discrete Types may be used heredoes not match that of a3 From own specification is not defined in this bodyttempt to Index7This type of declaration can only be used for constants of a!Cannot Modify a Constant Variabletch Variant Type!Attempt to Index/Privates must be defined in the Private sectiontch that of aCannot Modify an expressionnot match Variant Type!Attempt to IndexLabel Table Overflowthis Array'Type does not match that of a"Attempt to negate non-numeric typech Variant Type!Attempt to Index%Cannot Dispose of a Non-Access Objectoes not match that of a0Operand(s) not correct type for Boolean operatore!Attempt to IndexCannot Assign into a Constanty'Type does not match that of a'Cannot Assign into a Read-only Variableriant Type!Attempt to Index Cannot Assign into an expressionype does not match that of aIncompatable Assignment typest match Variant Type!Attempt to Index!Package Identifier does not Matchpe does not match that of a6Attempt to use Numeric Operator on Non-Numeric Type(s)mpt to IndexCannot Compare Different types'Type does not match that of a2Arrays and Records can only be tested for equalityAttempt to Index*Incompatible types for Membership Operatorot match that of a$Subprogram Identifier does not Match Variant Type!Attempt to Index,Operator cannot be used in a Real Expression match that of a USEd Identifier is not a Packageatch Variant Type!Attempt to IndexFeature not implementeds Array'Type does not match that of a Type of Condition is not Booleanatch Variant Type!Attempt to IndexBlock Identifier does not matchType does not match that of a.Return type does not match forward declarationype!Attempt to IndexCannot Get/Put this Type Array'Type does not match that of a4Mode of Parameter does not match forward declarationtempt to Index)No Inclosing Loop with this name (if any)not match that of aMust use Static Expression herematch Variant Type!Attempt to Index/Number of parameters does not match declarationtch that of a)Parameter type does not match declarationant Type!Attempt to Index6Only parameters of mode 'IN' are allowed for Functionst of a4Type of Parameter does not match forward declarationtempt to IndexMultiply defined parameterrray'Type does not match that of a6Cannot have constant records or arrays (** Sys Err **)mpt to Index5Cannot have a non-scalar on the stack (** Sys Err **)at of a,Type Conversion may only have one Paramenter Type!Attempt to IndexCannot do this ConversionArray'Type does not match that of aToo Many Indices for this Arraymatch Variant Type!Attempt to Index'Type does not match that of array indexs not match that of a'Variant Tag does not match Variant Typeriant Type!Attempt to Index!Attempt to Index a Non-Array Typepe does not match that of aConstant Out of Range does not match Variant Type!Attempt to IndexIllegal Range (** Sys Err **)y'Type does not match that of a$OTHERS Clause Must Be Last Case Limb Variant Type!Attempt to IndexOTHERS Clause used twice Array'Type does not match that of a(Constants cannot be Passed IN OUT or OUTiant Type!Attempt to Index*Expressions cannot be Passed IN OUT or OUTot match that of a2Read-Only Variables cannot be Passed IN OUT or OUTAttempt to Index'Relocation Error in Constant Expressions not match that of aThis attribute is unknowns not match Variant Type!Attempt to IndexWrong Type for Attribute Array'Type does not match that of aWrong Class for Attributes not match Variant Type!Attempt to Index'Wrong number of arguments for Attributes not match that of aParse Stack Overflowg does not match Variant Type!Attempt to Index%Package Name does not match File Nameoes not match that of aMultiply Defined Case Labelnot match Variant Type!Attempt to IndexCannot Have Variable Case LabelType does not match that of aWas never defined Tag does not match Variant Type!Attempt to Index.The Type of a Case Expression must be Discreteatch that of a9Type of Case Label does not match that of Case Expression to Index5Type of first parameter to Read or Write must be Fileat of a 8087 Required for Floating Pointatch Variant Type!Attempt to Index!Cannot Return from a Package Bodype does not match that of a$Cannot take the address of this item Variant Type!Attempt to Index6Internal error - call to eval_expr with non-scalar argt of aProcedure Table Overflowes not match Variant Type!Attempt to IndexParameter Table Overflow Array'Type does not match that of aType Table Overflowag does not match Variant Type!Attempt to IndexCase Table Overflow this Array'Type does not match that of a0The Code Segement Overlaps into the Data Segmente!Attempt to Index!Type Conflict of Numeric Operandspe does not match that of a5Private types may not be used before they are definedempt to Index#Exceeded Maximum Case nesting level does not match that of aWith-ed Package not founds not match Variant Type!Attempt to IndexMultiply Defined Package Array'Type does not match that of a Disk Full'Variant Tag does not match Variant Type!Attempt to IndexDirectory Fulls for this Array'Type does not match that of aThis must be an access variablematch Variant Type!Attempt to IndexProcedure used as a Functionay'Type does not match that of a5This must name a Variable, Constant, or Function Callempt to IndexThis must name a Typehis Array'Type does not match that of a'This type does not have any access typeriant Type!Attempt to Index5Incomplete types can only be used in Access Type Decsat of a0Cannot Assign or Compare Limited (Private) Typese!Attempt to IndexString Length must be Constant'Type does not match that of a'String Length must be between 1 and 255riant Type!Attempt to Index"Exponent must have an integer typee does not match that of aExponent must be positives not match Variant Type!Attempt to Index0Temporary Floating Point Constant File Not Foundch that of aare Mutually Dependentdoes not match Variant Type!Attempt to Index"String Usage is not Ada compatiblee does not match that of a6Strings of length one cannot be used as a private typempt to Index*Command Line Error - No Option after Slashot match that of a,Command Line Error - No Disk Name for Option Type!Attempt to Index,Command Line Error - Garbage on Command Line match that of a&Command Line Error - Illegal Disk Nameariant Type!Attempt to Index#Command Line Error - Unknown Option does not match that of a4Withed package name is too long for a .SYM file nametempt to Index+Parse table damaged - 2 reductions in a rowt match that of aBad Token Number (*Sys Error*) match Variant Type!Attempt to IndexHash Table Full for this Array'Type does not match that of aJanus1.Ovl MissingTag does not match Variant Type!Attempt to IndexInput File Not Foundthis Array'Type does not match that of aInclude File Not Founddoes not match Variant Type!Attempt to Index0Logical End of Program found before Physical Endch that of a4Program unit found in impossible place (*Sys Error*)tempt to IndexCannot nest include filesArray'Type does not match that of aPremature End-of-File foundnot match Variant Type!Attempt to IndexValue larger than can be storedType does not match that of aBase not between 2 and 16s not match Variant Type!Attempt to Index This is not a digit of this baseype does not match that of aMissing '#' after based number match Variant Type!Attempt to Index#String must not cross line boundary does not match that of a$Must have numeric exponent after 'E' Variant Type!Attempt to IndexValue Missing in based numbery'Type does not match that of a0Error writing temporary file, disk probably fulle!Attempt to IndexString Space Overflowhis Array'Type does not match that of aIdentifier Expected, Insertedt match Variant Type!Attempt to IndexLeft Paren Expected, Insertedy'Type does not match that of aRight Paren Expected, Inserted match Variant Type!Attempt to IndexSemicolon Expected, Inserteday'Type does not match that of aEnd of File Expected, Inserted match Variant Type!Attempt to Index"Number Expected, Zero (0) Insertede does not match that of a%Data size for a Demo package exceededVariant Type!Attempt to IndexExpression too complexis Array'Type does not match that of a,Multiple or Trailing Underscores not allowed Type!Attempt to Index)Control characters not allowed in stringsnot match that of a6Ambiguous due to multiple definitions in USEd packagesmpt to Index5Unable to Match this call with any defined subprogramat of a-Parameter may not be a Constant or ExpressionType!Attempt to Index-Use clause conflicts have made this undefinedmatch that of a Attempt to call a non-subprogramatch Variant Type!Attempt to IndexWidth Must be an Integer Array'Type does not match that of aSubprogram Call Stack Overflow match Variant Type!Attempt to Index#This type cannot be Read or Written does not match that of aFunction used as a Procedureot match Variant Type!Attempt to Index= NOS; Toss both operands - Function Fcmp_GT Return Boolean; - -- Return TOS > NOS; Toss both operands - - Procedure FXCHG; - -- Exchange TOS with NOS. - Procedure FADD; - -- NOS := TOS + NOS; Toss TOS - Procedure FSUB; - -- NOS := TOS - NOS; Toss TOS - Procedure FMUL; - -- NOS := TOS * NOS; Toss TOS - Procedure FDIV; - -- NOS := TOS / NOS; Toss TOS - Procedure FABS; - -- TOS := ABS TOS - Procedure FNEG; - -- TOS := - TOS - Procedure FRNDINT; - -- TOS := Integer(TOS) [Integer Round] - Procedure FEXP(cnt : Integer); - -- TOS := TOS ** cnt - Procedure Finit; - -- Clear the unit (generally used after an exception) - - Function Float_OK Return Boolean; - -- Returns true if the floating point library can be executed. - -- Mainly intended for use with Hardware libraries - will return - -- False if the Hardware is missing or does not work. - -- [Replaces Have_8087!] - - -- Errors: - -- Stack Overflow. - -- Bad Operand. - -- Overflow. - -- Underflow (result is rounded to zero). - - -- To call these externally, would use something like: - -- Floatops.FLD_Short_Float(Value'Address); - -End FloatOps; - point library can be executed. - -- Mainly intended for use with Hardware libraries - will return - -- False if the Hardware i- NOS := TOS / NOS; Toss TOS - Procedure FABS; - -- TOS := ABS TOS - Procedure FNEG; - -- TOS := - TOS - Procedure FRND \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/FLOATOPS.SYM b/software/CPM/CPM_MC_C3/FLOATOPS.SYM deleted file mode 100644 index 4046d33..0000000 Binary files a/software/CPM/CPM_MC_C3/FLOATOPS.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/IO.JRL b/software/CPM/CPM_MC_C3/IO.JRL deleted file mode 100644 index cb09904..0000000 Binary files a/software/CPM/CPM_MC_C3/IO.JRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/IO.LIB b/software/CPM/CPM_MC_C3/IO.LIB deleted file mode 100644 index c14dd74..0000000 --- a/software/CPM/CPM_MC_C3/IO.LIB +++ /dev/null @@ -1,63 +0,0 @@ -Package IO Is - --- The I/O package for JANUS V. 1.4.6 --- Last Modified 5/ 5/83 --- Keypress & Purge added 2/13/83, with Get_Line bug correction --- Mode, Putw, and Second Get_Line added 3/27/83 --- Put_Line(s) added 5/ 5/83 - - -- Copyright 1982,1983 RR Software, P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. - - -Type File_Mode Is (No_Access,Read_Only,Write_Only,Read_Write); - -IOresult : Integer; -- The result of the IO operation -Subtype LString Is String(255); - -Procedure Open(Fyle : In Out File; Name : In String; Mode : In File_Mode); - -- Open the file name and give it the mode mode -Procedure Create(Fyle : In Out File; Name : In String; Mode : In File_Mode); - -- Create the file name and give it the mode mode -Procedure Delete(Name : In String); - -- Delete the file name -Procedure Close(Fyle : In Out File); - -- Close the file fyle -Function Name(Fyle : In File) Return String; - -- Return the name of the Open file -Function Mode(Fyle : In File) Return File_Mode; - -- Return the file mode of the Open file -Function Is_open(Fyle : In File) Return Boolean; - -- Is the file fyle open? -Function Get_Line Return LString; - -- Get a line from Current_Input -Function Get_Line(Fyle : In File) Return LString; - -- Get a line from the file fyle -Procedure Put_Line(Fyle : In File; Str : In Lstring); - -- Put a line to the file, with a New_line -Procedure Put_Line(Str : In Lstring); - -- Put a line to Current_Output, with a new_line -Procedure Put_Hex(Fyle : In File; val : In Integer); - -- Write the integer in hexidecimal (no special format) -Procedure Putw(str : In LString; width : In Integer); - -- Write the string to the default file, with blank padding to fill width -Procedure Putw(Fyle : In File; Str : In LString; width : In Integer); - -- Write the string to fyle, with blank padding to fill width. -Function End_of_file(fyle : In File) Return Boolean; - -- End of File Reached (in a text file)? -Function EOF(fyle : In File) Return Boolean; - -- End of File Reached (in a binary file)? -Function Disk_full(fyle : In File) Return Boolean; - -- Is the Disk full ? -Function End_of_Line(fyle : In File) Return Boolean; - -- End of Line Reached? -Function Keypress Return Boolean; - -- Returns True if a character is ready (a key has been pressed) -Procedure Purge (str : In String); - -- Delete the file named str, without an error if str exists - -End IO; - a line to Current_Output, with a new_line -Procedure Put_Hex(Fyle : In File; val : In Integer); - -- Write the integer in he \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/IO.SYM b/software/CPM/CPM_MC_C3/IO.SYM deleted file mode 100644 index af8b683..0000000 Binary files a/software/CPM/CPM_MC_C3/IO.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/JANUS.COM b/software/CPM/CPM_MC_C3/JANUS.COM deleted file mode 100644 index 8eba6cf..0000000 Binary files a/software/CPM/CPM_MC_C3/JANUS.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/JANUS1.OVL b/software/CPM/CPM_MC_C3/JANUS1.OVL deleted file mode 100644 index dc6253d..0000000 Binary files a/software/CPM/CPM_MC_C3/JANUS1.OVL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/JANUS2.COM b/software/CPM/CPM_MC_C3/JANUS2.COM deleted file mode 100644 index cefea6d..0000000 Binary files a/software/CPM/CPM_MC_C3/JANUS2.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/JANUS2A.COM b/software/CPM/CPM_MC_C3/JANUS2A.COM deleted file mode 100644 index 50be519..0000000 Binary files a/software/CPM/CPM_MC_C3/JANUS2A.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/JANUS2B.COM b/software/CPM/CPM_MC_C3/JANUS2B.COM deleted file mode 100644 index 04b4829..0000000 Binary files a/software/CPM/CPM_MC_C3/JANUS2B.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/JANUS3.COM b/software/CPM/CPM_MC_C3/JANUS3.COM deleted file mode 100644 index 8aea593..0000000 Binary files a/software/CPM/CPM_MC_C3/JANUS3.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/JANUS4.COM b/software/CPM/CPM_MC_C3/JANUS4.COM deleted file mode 100644 index a54c72b..0000000 Binary files a/software/CPM/CPM_MC_C3/JANUS4.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/JLIB80.JRL b/software/CPM/CPM_MC_C3/JLIB80.JRL deleted file mode 100644 index 192d4bc..0000000 Binary files a/software/CPM/CPM_MC_C3/JLIB80.JRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/JLIB80.LIB b/software/CPM/CPM_MC_C3/JLIB80.LIB deleted file mode 100644 index 5783ee9..0000000 --- a/software/CPM/CPM_MC_C3/JLIB80.LIB +++ /dev/null @@ -1,153 +0,0 @@ -Package Jlib80 Is - -- These are the External declarations for JLib80 - - -- Copyright (c) 1982,84 - -- RR Software, Inc., P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. - - -- The specifications below cannot be changed or deleted. - -- The user may add entries to the end of the table - - -- The Procedures below cannot be called from a JANUS program (they - -- can be used in a Assembly language program) unless they are marked - -- by an asterisk (*) - -- The Entry Point Table - Idnum - - Procedure NotUsed1; -- 1 - Procedure NotUsed2; -- 2 - Procedure Mul2; -- 3 - Procedure Div2; -- 4 - Procedure Rem2; -- 5 - Procedure Mod2; -- 6 - Procedure Lt1; -- 7 - Procedure Le1; -- 8 - Procedure Eq1; -- 9 - Procedure Neq1; --10 - Procedure Ge1; --11 - Procedure Gt1; --12 - Procedure Lt2; --13 - Procedure Le2; --14 - Procedure Eq2; --15 - Procedure Neq2; --16 - Procedure Ge2; --17 - Procedure Gt2; --18 - Procedure Member1; --19 - Procedure Member2; --20 - Procedure SMember1; --21 - Procedure SMember2; --22 - Procedure NotUsed23; --23 - Procedure NotUsed24; --24 - Procedure NotUsed25; --25 - Procedure NotUsed26; --26 - Procedure NotUsed27; --27 - Procedure NotUsed28; --28 - Procedure NotUsed29; --29 - Procedure LnoCode; --30 - Procedure Sour_Err; --31* - Procedure Range1; --32 - Procedure Range2; --33 - Procedure SRange1; --34 - Procedure SRange2; --35 - Procedure EErr_Exit; --36* - Procedure Null_Ptr; --37 - Procedure Str_Bound; --38 - Procedure CaseErr; --39 - Procedure GetInt; --40 - Procedure EPut_Str; --41 - Procedure EClose; --42 - Procedure RplcByte; --43 - Procedure CRange1; --44 - Procedure EPutInt; --45 - Procedure PutHex; --46 - Procedure EPutIntW; --47 - Procedure EPutEnum; --48 - Procedure EPutEnumW; --49 - Procedure NotUsed50; --50 - Procedure ProcInit; --51 - Procedure ProcFin; --52 - Procedure Exp2; --53 - Procedure NotUsed54; --54 - Procedure SLt; --55 - Procedure SLe; --56 - Procedure SEq; --57 - Procedure SNeq; --58 - Procedure SGe; --59 - Procedure SGt; --60 - Procedure Sassign; --61 - Procedure Concat; --62 - Procedure EVWrite; --63 - Procedure ERead; --64 - Procedure EWrite; --65 - Procedure ENew_Line; --66 - Procedure ESkip_Line; --67 - Procedure Func_Release; --68 - Procedure Func_Ret; --69 - Procedure EFile_Name; --70 - Procedure New_Ptr; --71 - Procedure EMemAvail; --72 - Procedure EMaxAvail; --73 - Procedure EDispose; --74 - Procedure EHalt; --75* - Procedure PChain; --76 - Procedure Bool_Tab; -- This is not a Procedure at all, - -- rather, it is the enumeration - -- table for Boolean - - -- File Type definitions - - BUFFER_SIZE : Constant := 256; -- Must be a multiple of 128 - -- and less than 32768 - Type Disk_fcb Is Record - Disk_num : Byte; -- Offset 0 - File_name : Array(1..11) Of Character; -- Offset 1 - Extent : Byte; -- Offset 12 - Not_Used : Integer; -- Offset 13 - Rec_count : Byte; -- Offset 15 - Disk_Map : Array (16..31) Of Byte; -- Offset 16 - Rec_num : Byte; -- Offset 32 - Random_rec1 : Integer; -- Offset 33 - Random_rec2 : Integer; -- Offset 35 - End Record; - - Type File_mask; - Type File_ptr Is Access File_Mask; - Type File_mask Is Record - ftype:Byte; -- 0-Disk_File; 1-Con; 2-Rdr; 3-Pun; 4-Lst; - -- 5-Kbd -- Offset 0 - fmode:Byte; -- Offset 1 (Really of type file_mode, see - -- IO.LIB) - fcb:disk_fcb; -- Offset 2 - buff:Array(0..BUFFER_SIZE-1) Of Byte; -- Offset 39 - buf_ptr : Integer; -- Pointer into buff -- Offset 167 - eof_flag : Boolean; -- Offset 169 - link : File_ptr; -- Offset 170 - -- Chain link so JANUS can keep track of all - -- open files. - End Record; - - -- JLib80 Data Area - DispStart : Integer; -- Display 'Registers' (0 and 1 unused) - Display1 : Integer; - Display2 : Integer; - Display3 : Integer; - Display4 : Integer; - Display5 : Integer; - Display6 : Integer; - Display7 : Integer; - Display8 : Integer; - Display9 : Integer; - Display10 : Integer; - LineNo : Integer; -- Current Line Number being executed - Input_File : Integer; -- Standard Input (Cannot be used directly) - Output_File : Integer; -- Standard Output (ditto) - File_Chain : File_Ptr; -- Chain of files (so they can be closed if - -- the user forgets) - - -- Other user defined routines may be added here -Pragma sybdump(On); - -End Jlib80; -ff:Array(0..BUFFER_SIZE-1) Of Byte; -- Offset 39 - buf_ptr : Integer; -- Pointer into buff -- Offset 167 - eof_flag : Bo \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/JLIB80.SYM b/software/CPM/CPM_MC_C3/JLIB80.SYM deleted file mode 100644 index 9682c75..0000000 Binary files a/software/CPM/CPM_MC_C3/JLIB80.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/JLINK.COM b/software/CPM/CPM_MC_C3/JLINK.COM deleted file mode 100644 index 40b254a..0000000 Binary files a/software/CPM/CPM_MC_C3/JLINK.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/KALAHA.PKG b/software/CPM/CPM_MC_C3/KALAHA.PKG deleted file mode 100644 index 1f72009..0000000 --- a/software/CPM/CPM_MC_C3/KALAHA.PKG +++ /dev/null @@ -1,521 +0,0 @@ -With Util; -package body kalaha is - --- kalaha game. marcus wagner --- translation PASCAL -> Janus (Subset of Ada) 30.6.1982. --- revision of type player (introducing variable other) and --- implementation of a short summary with node counts 1.7.1982. --- Converted to separate compilation version 1.4.5 Janus 20.8.1982 --- Changed I/O to use line buffered. --- Conditional compiled debugging information --- Added instructions and game scoring. --- R.L.Brukardt - RR Software - - Use Util; - - pragma arithcheck(off); pragma debug(off); - pragma enumtab(off); pragma rangecheck(off); -@ Pragma arithcheck(On); Pragma debug(on); -@ Pragma enumtab(On); Pragma rangecheck(On); - --- constants. - - maximum : constant := 9999; - infimum : constant := 11000; - --- types. - - type player is (machine,man); - - subtype field is integer range 0..7; - - type movekind is (normal,kalaha,winn,lost); - - type halfboard is - record - total : integer; -- assert total = sum of hole(all fields). - hole : array (field) of integer; - end record; - - type board is array (player) of halfboard; - --- variables. - - depth : integer; - value : integer; - ch : character; - place : field; - kind : movekind; - result : movekind; - a : board; - tab : array (0..72) of integer; -- for easier evaluation, contains - -- predefined values. - other : array (player) of player; -- to determine other side. - nodes : integer; -- node count. - evcount : integer; -- count for static evaluations. - - games,iwon : Integer := 0; - -procedure check_break is - - begin - if ch = character'val(3) then -- Control c -> abort. - new_line; - put("Kalaha aborted, it is a pity that you don't want to continue"); - halt; - end if; - end check_break; - -procedure init_board (a: out board) is - - begin - for j in machine..man loop - for i in 1..6 loop - a(j).hole(i) := 6; - end loop; - a(j).hole(7) := 0; - a(j).total := 36; - end loop; - end init_board; - -procedure init_other is -- can be replaced by an aggregate, then - -- this procedure is superfluous and the - -- variable other becomes a structured constant. - - begin - other(machine) := man; - other(man) := machine; - end init_other; - -procedure print_board (a: in board) is - - begin - put(" "); - for i in reverse 1..7 loop - put(a(machine).hole(i),4); - end loop; - new_line; - put(" "); - for i in 1..7 loop - put(a(man).hole(i),4); - end loop; - new_line; - end print_board; - -procedure instructions is - -- print intstructions - begin - Put("Welcome to Kalaha"); New_Line; - New_Line; - Put("The object of the game is to collect more stones than your"); - New_Line; - Put("opponent (the computer). Collecting 37 stones is enough to win.") - ; New_Line; - Put("The board looks like this:"); New_Line; - New_Line; - Put(" Computer's Holes"); New_Line; - Put(" E 6 5 4 3 2 1"); New_Line; - Put(" 1 2 3 4 5 6 E"); New_Line; - Put(" Your Holes"); New_Line; - New_Line; - Put("The object of the game is to collect stones in the 'E' hole."); - New_Line; - Put("The game is very simple. A move consists of picking up a pile"); - New_Line; - Put("of stones from one of your holes, and distributing them"); - New_Line; - Put("counter-clockwise, one in each hole until they run out. You"); - New_Line; - Put("Must put one in your 'E' hole, but cannot put one in your"); - New_Line; - Put("opponent's 'E' hole. Three added rules make the game") - ; New_line; - Put("interesting. First, if the last stone you place is put into"); - New_Line; - Put("your 'E' hole, it is called a 'Kalaha Move' and you may make"); - New_Line; - Put("another move. If the next move is also a Kalaha Move, you may"); - New_Line; - New_Line; - Put("Type return to continue"); Get(ch); Skip_Line; - - Put("make yet another move, and so on. This rule fills the game"); - New_Line; - Put("with surprises. The second rule is that of capture. If the"); - New_Line; - Put("last stone placed is placed in an empty hole on your side of"); - New_Line; - Put("the board, a capture occurs. You may then pick you all of your"); - New_Line; - Put("opponent's stones in the hole opposite the capture hole, and"); - New_Line; - Put("the capturing stone, and place them directly in your 'E' hole."); - New_Line; - Put("This is the easy way to win! The last rule is that you lose if"); - New_Line; - Put("there are no stones on your side of the board (Holes 1..6)."); - New_Line; - New_Line; - Put("If you are stumped for a move, you may ask the machine for its"); - New_Line; - Put("advice by typing a question mark ('?')"); New_Line; - New_Line; - Put("How good a player the computer is, and how long a game will"); - New_Line; - Put("take, is determined by the strength factor you enter at the"); - New_Line; - Put("start of the game. 1 is the weakest, 6 is the strongest"); - New_Line; - New_Line; - Put("Have Fun!"); New_Line; - New_Line; - Put("Type Return to Continue"); Get(ch); Skip_Line; - end instructions; - -function score (a : in board; jj : in player) return integer is - - n, k, s : integer; - q : array(player) of integer; - - begin - evcount := evcount + 1; - for j in machine..man loop - s := 0; - for i in 1..6 loop - n := a(j).hole(i); - if n > 0 then - k := n + i - 7; - if k < 0 then - s := s + n + 7; - else - s := s + tab(k) - i; - end if; - end if; - end loop; - q(j) := s * a(j).hole(7); - end loop; - return q(jj) - q(other(jj)); - end score; - -procedure make_move (a : in board; - b : in out board; - jj : in player; - iii : in field) is - - n : integer; - i,lim,ii,i1 : integer; - j,j1 : player; - extra : integer; - - begin - ii := iii; - b := a; - n := b(jj).hole(ii); - b(jj).hole(ii) := 0; - b(jj).total := b(jj).total - n; - j := other(jj); - lim := 6; - while n > 0 loop - i := ii; - j := other(j); - lim := 13 - lim; - i1 := i + n; - if i1 > lim then - i1 := lim; - end if; - n := n - i1 + i; - b(j).total := b(j).total + i1 - i; - while i < i1 loop - i := i + 1; - b(j).hole(i) := b(j).hole(i) + 1; - end loop; - ii := 0; - end loop; - if i = 7 then - kind := kalaha; - else - kind := normal; - if j = jj and then b(j).hole(i) = 1 and then - b(other(j)).hole(7-i) /= 0 then -- capture move. - extra := b(other(j)).hole(7-i); - b(j).hole(7) := b(j).hole(7) + extra + 1; - b(j).total := b(j).total + extra; - b(j).hole(i) := 0; - b(other(j)).total := b(other(j)).total - extra; - b(other(j)).hole(7-i) := 0; - end if; - end if; - if b(jj).hole(7) > 36 then - kind := winn; - elsif b(other(jj)).hole(7) > 36 then - kind := lost; - elsif b(jj).total = b(jj).hole(7) then - kind := lost; - elsif b(other(jj)).total = b(other(jj)).hole(7) then - kind := winn; - end if; - end make_move; - -procedure analysis (a : in board; - j : in player; - depth : in integer; - value : out integer; - place : out field; - alpha, beta : in integer) is - - m, t, v : integer; - p : field; - b : board; - - begin - m := alpha; - for i in 1..6 loop - if a(j).hole(i) /= 0 then -- can move from this field. - nodes := nodes + 1; - make_move(a,b,j,i); - case kind is - when normal => - if depth = 1 then -- terminal node, evaluate statically. - t := score (b,j); - else -- nonterminal, recursive evaluation. - analysis(b,other(j),depth-1,t,p,-beta,-m); - t := -t; - end if; - when kalaha => - analysis(b,j,depth,t,p,m,beta); - -- try next move for this side. - when winn => - t := maximum+depth; - when lost => - t := - maximum-depth; - end case; - if t > m then -- new best. - m := t; - place := i; - end if; - exit when m >= beta; -- alpha - beta cutoff. - end if; - end loop; - value := m; -- the value of our position. - end analysis; - -procedure iteration (a : in board; - j : in player; - d : in integer; - oldval : in integer) is - - alpha, beta : integer; - - begin - alpha := oldval - 30; - beta := oldval + 30; - if alpha < -infimum then - alpha := -infimum; - end if; - if beta > infimum then - beta := infimum; - end if; - loop - analysis(a,j,d,value,place,alpha,beta); -@ put("Alpha "); -@ put(alpha,6); -@ put(" Beta "); -@ put(beta,6); -@ put("valuation "); -@ put(value,6); -@ new_line; - exit when value > alpha and value < beta; -@ put("alpha-beta window too small -> new iteration"); -@ new_line; - if value <= alpha then - alpha := -infimum; - end if; - if value >= beta then - beta := infimum; - end if; - end loop; - end iteration; - -@procedure summary is -@ -- Print summary of Alpha-Beta Search -@ begin -@ put(" valuation "); put(value,6); new_line; -@ put(" valuated positions "); put(evcount,6); new_line; -@ put(" investigated positions "); put(nodes,6); new_line; -@ end summary; - -procedure man_move is - - d : integer; - - begin - loop - loop - put("What is your choice (1..6)?"); - get(ch); - check_break; - skip_line; -- Toss input line (console input is line buffered - -- in Janus/Ada) - new_line; - if ch = '?' then -- make a proposal for depth d. - nodes := 0; - evcount := 0; - iteration(a,man,depth,score(a,man)); - put("Proposed move "); - put(place,1); - new_line; -@ summary; - else - d := character'pos(ch) - character'pos('0'); - If d in 1..6 Then -- Valid move - place := d; -- Can't do this until move is valid - exit when a(man).hole(place) /= 0; - End If; - put("invalid move "); - new_line; - end if; - end loop; - make_move(a,a,man,place); - print_board(a); - exit when kind /= kalaha; -- now other side moves. - put("Kalaha move"); - new_line; - end loop; - if kind = winn then - result := lost; - else - result := winn; - end if; - end man_move; - -procedure machine_move is - - oldval : integer; - - begin - oldval := score(a,machine); - loop - nodes := 0; - evcount := 0; - iteration(a,machine,depth,oldval); - put("I choose "); - put(place,1); - new_line; -@ summary; - make_move(a,a,machine,place); - print_board(a); - exit when kind /= kalaha; - oldval := value; - put("Kalaha move"); - new_line; - end loop; - result := kind; - end machine_move; - -procedure init_table is - - begin - for k in 0..72 loop - tab(k) := abs(6 - k mod 13) + 7; - end loop; - end init_table; - -begin -- main program. - - init_table; - init_other; - put("Do you need instructions? "); - Get(ch); - Skip_Line; - New_Line; - If (ch /= 'N') and (ch /= 'n') Then - instructions; - End If; - loop - init_board(a); - put("Start Position "); - new_line; - new_line; - print_board(a); - loop - put("Machine Strength (1..6)? "); - get(ch); - check_break; - skip_line; -- Toss input line - console input is line buffered - -- in Janus/Ada - new_line; - depth := character'pos(ch) - character'pos('0'); - exit when depth in 1..6; - put("Illegal Strength"); - new_line; - end loop; - loop - put("Who shall start ?"); - new_line; - put("man = M or computer = C "); - get(ch); - check_break; - skip_line; - new_line; - exit when ch = 'M' or ch = 'm' or ch = 'C' or ch = 'c'; - put("Must be M or C"); - new_line; - end loop; - if ch = 'C' or ch = 'c' then - machine_move; - end if; - loop - man_move; - if kind = normal then - machine_move; - end if; - exit when kind /= normal; - end loop; - - games := games + 1; - if result = lost then - put("Congradulations, you won."); - new_line; - If iwon + 1 > games Then - Put("That's the first game you won today. Lucky!"); New_Line; - Elsif iwon < games/2 Then - Put("You really play well."); New_Line; - Else - Put("I want a re-match"); New_Line; - End If; - else - put("Hurra! I won."); - new_line; - iwon := iwon + 1; - If iwon = 1 And Then games > 2 Then - Put("I finally beat you."); New_Line; - Elsif iwon + 3 > games Then - Put("You need more pratice."); New_Line; - End If; - end if; - - Put("I have won "); Put(iwon); Put(" games, out of "); - Put(games); Put(" games played"); New_Line; - - put("Do you want to play again? "); - get(ch); - Skip_line; - New_Line; - Exit When (ch = 'N') Or (ch = 'n'); - end loop; -end kalaha; -."); New_Line; - Elsif iwon + 3 > games Then - Put("You need more pratice."); New_Line; - End If; - end if; - - Put("I have won "); Put(iwon); Put(" games, out of "); - Put(games); Put(" games played"); New_Line; - - put("Do you want to play again? "); - get(ch); - Skip_line; - New_Line; - Exit When (ch = 'N') Or (ch = 'n'); - end lo \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/LONGIO.JRL b/software/CPM/CPM_MC_C3/LONGIO.JRL deleted file mode 100644 index 1c32c90..0000000 Binary files a/software/CPM/CPM_MC_C3/LONGIO.JRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/LONGIO.LIB b/software/CPM/CPM_MC_C3/LONGIO.LIB deleted file mode 100644 index f0216f0..0000000 --- a/software/CPM/CPM_MC_C3/LONGIO.LIB +++ /dev/null @@ -1,34 +0,0 @@ -With Longops; -Package Longio Is - - -- Copyright 1983 RR Software, Inc., P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. All Other rights reserved. - - -- Long Integer I/O - -- Do not USE (use clause) this package until the built-in procedure - -- bug is fixed. - -- Last Modified 3/27/83 - - Use Longops; - - Procedure Get(Item : Out Long_Integer); - Procedure Get(Fyle : In File; Item : Out Long_Integer); - - Procedure Put(Item : In Long_Integer); - Procedure Put(Fyle : In File; Item : In Long_Integer); - Procedure Put(Item : In Long_Integer; Width : In Integer); - Procedure Put(Fyle : In File; Item : In Long_Integer; Width : - In Integer); - -End Longio; -27/83 - - Use Longops; - - Procedure Get(Item : Out Long_Integer); - Procedure Get(Fyle : In File; Item : Out Long_Integer); - - Procedure Put(Item : In Long_Integer); - Procedure Put(Fyle : In File; Item : In Long_Integer); - Procedure \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/LONGIO.SYM b/software/CPM/CPM_MC_C3/LONGIO.SYM deleted file mode 100644 index 40f91f4..0000000 Binary files a/software/CPM/CPM_MC_C3/LONGIO.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/LONGOPS.JRL b/software/CPM/CPM_MC_C3/LONGOPS.JRL deleted file mode 100644 index d2c5df5..0000000 Binary files a/software/CPM/CPM_MC_C3/LONGOPS.JRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/LONGOPS.LIB b/software/CPM/CPM_MC_C3/LONGOPS.LIB deleted file mode 100644 index fd89b53..0000000 --- a/software/CPM/CPM_MC_C3/LONGOPS.LIB +++ /dev/null @@ -1,62 +0,0 @@ -Package Longops Is - - -- Copyright 1983 RR Software, Inc., P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. All Other rights reserved. - - -- Long Integer Operations - -- Last Modified 3/27/83 - -- The names of these routines will be changed when operator overloading - -- is implemented. - - Type Long_Integer Is Private; - - -- Normal Assignment and Equality operators are used - - Function Labs (Item : In Long_Integer) Return Long_Integer; - -- Operator "ABS" - Take the absolute value of operand - Function Lneg (Item : In Long_Integer) Return Long_Integer; - -- Operator "-" - Negate the Operand - Function Lint (Item : In Integer) Return Long_Integer; - -- Type Conversion Integer => Long_Integer - Function L_to_int (Item : In Long_Integer) Return Integer; - -- Type Conversion Long_Integer => Integer - - Function Ladd (Item,Item2 : In Long_Integer) Return Long_Integer; - -- Operator "+" - Long Integer addition - Function Lsub (Item,Item2 : In Long_Integer) Return Long_Integer; - -- Operator "-" - Long Integer subtraction - Function Lmul (Item,Item2 : In Long_Integer) Return Long_Integer; - -- Operator "*" - Long Integer multiply - Function Ldiv (Item,Item2 : In Long_Integer) Return Long_Integer; - -- Operator "/" - Long Integer division - Function Lrem (Item,Item2 : In Long_Integer) Return Long_Integer; - -- Operator "REM" - Long Integer remainder - Function Lmod (Item,Item2 : In Long_Integer) Return Long_Integer; - -- Operator "MOD" - Long Integer modulus - - Function Lgt (Item,Item2 : In Long_Integer) Return Boolean; - -- Operator ">" - Long Integer greater than - Function Lge (Item,Item2 : In Long_Integer) Return Boolean; - -- Operator ">=" - Long Integer greater than or equals - Function Llt (Item,Item2 : In Long_Integer) Return Boolean; - -- Operator "<" - Long Integer less than - Function Lle (Item,Item2 : In Long_Integer) Return Boolean; - -- Operator "<=" - Long Integer less than or equals - -Private - Type Long_Integer Is Record - hi,lo : Integer; - End Record; -End Longops; -) Return Boolean; - -- Operator ">" - Long Integer greater than - Function Lge (Item,Item2 : In Long_Integer) Return Boolean; - -- Operator ">=" - Long Integer greater than or equals - Function Llt (Item,Item2 : In Long_Integer) Return Boolean; - -- Operator "<" - Long Integer less than - Function Lle (Item,Item2 : In Long_Integer) Return Boolean; - -- Operator "<=" - Lonn Long_Integer) Return Long_Integer; - -- Operator "MOD" - Long Integer modulus - - Function Lgt (Item,Item2 : In Long_Intege \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/LONGOPS.SYM b/software/CPM/CPM_MC_C3/LONGOPS.SYM deleted file mode 100644 index c8e6591..0000000 Binary files a/software/CPM/CPM_MC_C3/LONGOPS.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/MATHLIB.JRL b/software/CPM/CPM_MC_C3/MATHLIB.JRL deleted file mode 100644 index 0bdcf9a..0000000 Binary files a/software/CPM/CPM_MC_C3/MATHLIB.JRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/MATHLIB.LIB b/software/CPM/CPM_MC_C3/MATHLIB.LIB deleted file mode 100644 index 2e5703a..0000000 --- a/software/CPM/CPM_MC_C3/MATHLIB.LIB +++ /dev/null @@ -1,70 +0,0 @@ -Package Mathlib Is - -- Double Precision Mathematic functions library - -- Last modified 2/21/84 - - -- Copyright 1983,84 RR Software, Inc., P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. All Other rights reserved. - - - PI : Constant := 3.14159_26535_89793_23846; - E : Constant := 2.71828_18284_59045_23536; - LOG10_E : Constant := 0.43429_44819_03251_82765; -- Log10(e) - - Function Sqrt (Val : In Long_Float) Return Long_Float; - -- Returns the sqrt of val - - Function Round (Val : In Long_Float) Return Long_Float; - -- Rounds val to an integer value, and returns it as a float - - Function Trunc (Val : In Long_Float) Return Long_Float; - -- Truncate val to its integer part, and returns it as a float - - Function Exp (Val : In Long_Float) Return Long_Float; - -- Returns e ** Val - -- To get 10 ** val, divide by LOG10_E. - - Function Log (Val : In Long_Float) Return Long_Float; - -- Returns the natural logarithm of Val. Val must be > 0. - -- To get Log10, multiply by LOG10_E. - - Function Power (Val,Exp : In Long_Float) Return Long_Float; - -- Returns Val ** Exp - - -- All angles are in radians! - Function Sin (Angle : In Long_Float) Return Long_Float; - -- Returns the Sine of the angle - - Function Cos (Angle : In Long_Float) Return Long_Float; - -- Returns the Cosine of the angle - - Function Tan (Angle : In Long_Float) Return Long_Float; - -- Returns the Tangent of the Angle - - Function ArcTan (Val : In Long_Float) Return Long_Float; - -- Returns the ArcTangent of the Value - - Function ArcCos (Val : In Long_Float) Return Long_Float; - -- Returns the ArcCosine of the Value - - Function ArcSin (Val : In Long_Float) Return Long_Float; - -- Returns the ArcSine of the Value - - Function ArcTan2(X,Y : In Long_Float) Return Long_Float; - -- Returns the ArcTangent of X / Y - - Function Deg_to_Rad (Angle : In Long_Float) Return Long_Float; - -- Converts the Angle in Degrees to the same angle in Radians - - Function Rad_to_Deg (Angle : In Long_Float) Return Long_Float; - -- Converts the Angle in Radians to the same angle in Degrees - -End Mathlib; -urn Long_Float; - -- Returns the ArcSine of the Value - - Function ArcTan2(X,Y : In Long_Float) Return Long_Float; - -- Returns the ArcTangent of X / Y - - Function Deg_to_Rad (Angle : In Long_Float) Return Long_Float; - -- Converts the Angle in Deg \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/MATHLIB.SYM b/software/CPM/CPM_MC_C3/MATHLIB.SYM deleted file mode 100644 index ebdeb75..0000000 Binary files a/software/CPM/CPM_MC_C3/MATHLIB.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/MATMUL.PKG b/software/CPM/CPM_MC_C3/MATMUL.PKG deleted file mode 100644 index d6f0dec..0000000 --- a/software/CPM/CPM_MC_C3/MATMUL.PKG +++ /dev/null @@ -1,97 +0,0 @@ -With Floatio,Floatops,Util; -Package Body Matmul Is - -- Jerry Pournelle's Floating Point Benchmark - -- October 1982 Byte, pages 254 - 270 - -- Translated from Pascal into Janus/Ada, 3/13/83 - - MAXSIZE : Constant := 45; - M : Constant := 20; - N : Constant := 20; - - Subtype Real Is Float; -- Also can use Long_Float for comparision - Subtype Dim1 Is Integer Range 1..M; - Subtype Dim2 Is Integer Range 1..N; - - -- The following mess since Janus/Ada does not yet have multi-dim. - -- arrays. - Type Col1 Is Array (Dim2) Of Real; - Type Col2 Is Array (Dim1) Of Real; - Type Mat1 Is Array (Dim1) Of Col1; - Type Mat2 Is Array (Dim2) Of Col2; - Type Mat3 Is Array (Dim1) Of Col2; - - -- Effect is: - -- Type Mat1 Is Array (Dim1,Dim2) Of Real; - -- Type Mat2 Is Array (Dim2,Dim1) Of Real; - -- Type Mat3 Is Array (Dim1,Dim1) Of Real; - - A : Mat1; - B : Mat2; - C : Mat3; - - Summ : Real; - - - Procedure Fill_A Is - Begin - For i In Dim1 Loop - For j In Dim2 Loop - A(i)(j) := Real(i + j); - End Loop; - End Loop; - End Fill_A; - - Procedure Fill_B Is - Begin - For i In Dim2 Loop - For j In Dim1 Loop - B(i)(j) := Real((i + j) / j); - End Loop; - End Loop; - End Fill_B; - - Procedure Fill_C Is - Begin - For i In Dim1 Loop - For j In Dim1 Loop - C(i)(j) := 0.0; - End Loop; - End Loop; - End Fill_C; - - Procedure Matrix_Multiply Is - Begin - For i In Dim1 Loop - For j In Dim2 Loop - For k In Dim1 Loop - C(i)(k) := C(i)(k) + A(i)(j) * B(j)(k); - End Loop; - End Loop; - End Loop; - End Matrix_Multiply; - - Procedure Summit Is - Begin - For i In Dim1 Loop - For j In Dim1 Loop - Summ := Summ + C(i)(j); - End Loop; - End Loop; - End Summit; - -Begin - Summ := 0.0; - Put("J.E. Pournelle's Matrix Multiply Benchmark"); New_line; - Fill_A; -@ Put(" A filled. "); New_line; - Fill_B; -@ Put(" B filled. "); New_line; - Fill_C; -@ Put(" C filled. "); New_line; - Matrix_Multiply; -@ Put("Multiplied."); New_line; - Summit; -@ Put("Summ is : "); Floatio.Put(Summ); New_Line; - Put("Checksum is : "); Floatio.Put(Summ); New_line; -End Matmul; - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/MEMCHK.COM b/software/CPM/CPM_MC_C3/MEMCHK.COM deleted file mode 100644 index 8e3b60d..0000000 Binary files a/software/CPM/CPM_MC_C3/MEMCHK.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/OPCODE.JRL b/software/CPM/CPM_MC_C3/OPCODE.JRL deleted file mode 100644 index 276ee63..0000000 Binary files a/software/CPM/CPM_MC_C3/OPCODE.JRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/OPCODE.LIB b/software/CPM/CPM_MC_C3/OPCODE.LIB deleted file mode 100644 index 5376e06..0000000 --- a/software/CPM/CPM_MC_C3/OPCODE.LIB +++ /dev/null @@ -1,293 +0,0 @@ -Package Opcode Is - -- 8080/Z80 opcodes - -- Not all Z80 opcode are defined. - -- Z-80 Opcodes are based on the TDL mnenomics. - - -- Copyright 1982, 1984 - -- RR Software, Inc., P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. - - LXIB : Constant := 16#01#; - LXID : Constant := 16#11#; - LXIH : Constant := 16#21#; - LXISP: Constant := 16#31#; - INRB : Constant := 16#04#; - INRC : Constant := 16#0C#; - INRD : Constant := 16#14#; - INRE : Constant := 16#1C#; - INRH : Constant := 16#24#; - INRL : Constant := 16#2C#; - INRM : Constant := 16#34#; - INRA : Constant := 16#3C#; - DCRB : Constant := 16#05#; - DCRC : Constant := 16#0D#; - DCRD : Constant := 16#15#; - DCRE : Constant := 16#1D#; - DCRH : Constant := 16#25#; - DCRL : Constant := 16#2D#; - DCRM : Constant := 16#35#; - DCRA : Constant := 16#3D#; - MVIB : Constant := 16#06#; - MVIC : Constant := 16#0E#; - MVID : Constant := 16#16#; - MVIE : Constant := 16#1E#; - MVIH : Constant := 16#26#; - MVIL : Constant := 16#2E#; - MVIM : Constant := 16#36#; - MVIA : Constant := 16#3E#; - INXB : Constant := 16#03#; - INXD : Constant := 16#13#; - INXH : Constant := 16#23#; - INXSP: Constant := 16#33#; - DCXB : Constant := 16#0B#; - DCXD : Constant := 16#1B#; - DCXH : Constant := 16#2B#; - DCXSP: Constant := 16#3B#; - DADB : Constant := 16#09#; - DADD : Constant := 16#19#; - DADH : Constant := 16#29#; - DADSP: Constant := 16#39#; - LDAXB: Constant := 16#0A#; - LDAXD: Constant := 16#1A#; - STAXB: Constant := 16#02#; - STAXD: Constant := 16#12#; - LHLD : Constant := 16#2A#; - SHLD : Constant := 16#22#; - LDA : Constant := 16#3A#; - STA : Constant := 16#32#; - RLC : Constant := 16#07#; - RRC : Constant := 16#0F#; - RAL : Constant := 16#17#; - RAR : Constant := 16#1F#; - DAA : Constant := 16#27#; - CMA : Constant := 16#2F#; - STC : Constant := 16#37#; - CMC : Constant := 16#3F#; - NOP : Constant := 16#00#; - -- Z-80 Insts. - EXAF : Constant := 16#08#; - DJNZ : Constant := 16#10#; - JR : Constant := 16#18#; - JRNZ : Constant := 16#20#; - JRZ : Constant := 16#28#; - JRNC : Constant := 16#30#; - JRC : Constant := 16#38#; - -- 8080 Insts. - MOVBB: Constant := 16#40#; - MOVBC: Constant := 16#41#; - MOVBD: Constant := 16#42#; - MOVBE: Constant := 16#43#; - MOVBH: Constant := 16#44#; - MOVBL: Constant := 16#45#; - MOVBM: Constant := 16#46#; - MOVBA: Constant := 16#47#; - MOVCB: Constant := 16#48#; - MOVCC: Constant := 16#49#; - MOVCD: Constant := 16#4A#; - MOVCE: Constant := 16#4B#; - MOVCH: Constant := 16#4C#; - MOVCL: Constant := 16#4D#; - MOVCM: Constant := 16#4E#; - MOVCA: Constant := 16#4F#; - MOVDB: Constant := 16#50#; - MOVDC: Constant := 16#51#; - MOVDD: Constant := 16#52#; - MOVDE: Constant := 16#53#; - MOVDH: Constant := 16#54#; - MOVDL: Constant := 16#55#; - MOVDM: Constant := 16#56#; - MOVDA: Constant := 16#57#; - MOVEB: Constant := 16#58#; - MOVEC: Constant := 16#59#; - MOVED: Constant := 16#5A#; - MOVEE: Constant := 16#5B#; - MOVEH: Constant := 16#5C#; - MOVEL: Constant := 16#5D#; - MOVEM: Constant := 16#5E#; - MOVEA: Constant := 16#5F#; - MOVHB: Constant := 16#60#; - MOVHC: Constant := 16#61#; - MOVHD: Constant := 16#62#; - MOVHE: Constant := 16#63#; - MOVHH: Constant := 16#64#; - MOVHL: Constant := 16#65#; - MOVHM: Constant := 16#66#; - MOVHA: Constant := 16#67#; - MOVLB: Constant := 16#68#; - MOVLC: Constant := 16#69#; - MOVLD: Constant := 16#6A#; - MOVLE: Constant := 16#6B#; - MOVLH: Constant := 16#6C#; - MOVLL: Constant := 16#6D#; - MOVLM: Constant := 16#6E#; - MOVLA: Constant := 16#6F#; - MOVMB: Constant := 16#70#; - MOVMC: Constant := 16#71#; - MOVMD: Constant := 16#72#; - MOVME: Constant := 16#73#; - MOVMH: Constant := 16#74#; - MOVML: Constant := 16#75#; - HLT : Constant := 16#76#; - MOVMA: Constant := 16#77#; - MOVAB: Constant := 16#78#; - MOVAC: Constant := 16#79#; - MOVAD: Constant := 16#7A#; - MOVAE: Constant := 16#7B#; - MOVAH: Constant := 16#7C#; - MOVAL: Constant := 16#7D#; - MOVAM: Constant := 16#7E#; - MOVAA: Constant := 16#7F#; - ADDB : Constant := 16#80#; - ADDC : Constant := 16#81#; - ADDD : Constant := 16#82#; - ADDE : Constant := 16#83#; - ADDH : Constant := 16#84#; - ADDL : Constant := 16#85#; - ADDM : Constant := 16#86#; - ADDA : Constant := 16#87#; - ADCB : Constant := 16#88#; - ADCC : Constant := 16#89#; - ADCD : Constant := 16#8A#; - ADCE : Constant := 16#8B#; - ADCH : Constant := 16#8C#; - ADCL : Constant := 16#8D#; - ADCM : Constant := 16#8E#; - ADCA : Constant := 16#8F#; - SUBB : Constant := 16#90#; - SUBC : Constant := 16#91#; - SUBD : Constant := 16#92#; - SUBE : Constant := 16#93#; - SUBH : Constant := 16#94#; - SUBL : Constant := 16#95#; - SUBM : Constant := 16#96#; - SUBA : Constant := 16#97#; - SBBB : Constant := 16#98#; - SBBC : Constant := 16#99#; - SBBD : Constant := 16#9A#; - SBBE : Constant := 16#9B#; - SBBH : Constant := 16#9C#; - SBBL : Constant := 16#9D#; - SBBM : Constant := 16#9E#; - SBBA : Constant := 16#9F#; - ANAB : Constant := 16#A0#; - ANAC : Constant := 16#A1#; - ANAD : Constant := 16#A2#; - ANAE : Constant := 16#A3#; - ANAH : Constant := 16#A4#; - ANAL : Constant := 16#A5#; - ANAM : Constant := 16#A6#; - ANAA : Constant := 16#A7#; - XRAB : Constant := 16#A8#; - XRAC : Constant := 16#A9#; - XRAD : Constant := 16#AA#; - XRAE : Constant := 16#AB#; - XRAH : Constant := 16#AC#; - XRAL : Constant := 16#AD#; - XRAM : Constant := 16#AE#; - XRAA : Constant := 16#AF#; - ORAB : Constant := 16#B0#; - ORAC : Constant := 16#B1#; - ORAD : Constant := 16#B2#; - ORAE : Constant := 16#B3#; - ORAH : Constant := 16#B4#; - ORAL : Constant := 16#B5#; - ORAM : Constant := 16#B6#; - ORAA : Constant := 16#B7#; - CMPB : Constant := 16#B8#; - CMPC : Constant := 16#B9#; - CMPD : Constant := 16#BA#; - CMPE : Constant := 16#BB#; - CMPH : Constant := 16#BC#; - CMPL : Constant := 16#BD#; - CMPM : Constant := 16#BE#; - CMPA : Constant := 16#BF#; - POPB : Constant := 16#C1#; - POPD : Constant := 16#D1#; - POPH : Constant := 16#E1#; - POPPSW:Constant := 16#F1#; - PUSHB: Constant := 16#C5#; - PUSHD: Constant := 16#D5#; - PUSHH: Constant := 16#E5#; - PUSHPSW:Constant:= 16#F5#; - JNZ : Constant := 16#C2#; - JMP : Constant := 16#C3#; - JZ : Constant := 16#CA#; - JNC : Constant := 16#D2#; - JC : Constant := 16#DA#; - JPO : Constant := 16#E2#; - JPE : Constant := 16#EA#; - JP : Constant := 16#F2#; - JM : Constant := 16#FA#; - CALL : Constant := 16#CD#; - CNZ : Constant := 16#C4#; - CZ : Constant := 16#CC#; - CNC : Constant := 16#D4#; - CC : Constant := 16#DC#; - CPO : Constant := 16#E4#; - CPE : Constant := 16#EC#; - CP : Constant := 16#F4#; - CM : Constant := 16#FC#; - RET : Constant := 16#C9#; - RNZ : Constant := 16#C0#; - RZ : Constant := 16#C8#; - RNC : Constant := 16#D0#; - RC : Constant := 16#D8#; - RPO : Constant := 16#E0#; - RPE : Constant := 16#E8#; - RP : Constant := 16#F0#; - RM : Constant := 16#F8#; - ADI : Constant := 16#C6#; - ACI : Constant := 16#CE#; - SUI : Constant := 16#D6#; - SBI : Constant := 16#DE#; - ANI : Constant := 16#E6#; - XRI : Constant := 16#EE#; - ORI : Constant := 16#F6#; - CPI : Constant := 16#FE#; - OUTA : Constant := 16#D3#; - INA : Constant := 16#DB#; - XTHL : Constant := 16#E3#; - XCHG : Constant := 16#EB#; - DI : Constant := 16#F3#; - EI : Constant := 16#FB#; - PCHL : Constant := 16#E9#; - SPHL : Constant := 16#F9#; - RST0 : Constant := 16#C7#; - RST1 : Constant := 16#CF#; - RST2 : Constant := 16#D7#; - RST3 : Constant := 16#DF#; - RST4 : Constant := 16#E7#; - RST5 : Constant := 16#EF#; - RST6 : Constant := 16#F7#; - RST7 : Constant := 16#FF#; - -- Z-80 Inst.. - EXX : Constant := 16#D9#; - DSBCB: Constant := 16#42ED#; - DSBCD: Constant := 16#52ED#; - DSBCH: Constant := 16#62ED#; - DSBCSP:Constant := 16#72ED#; - DADCB: Constant := 16#4AED#; - DADCD: Constant := 16#5AED#; - DADCH: Constant := 16#6AED#; - DADCSP:Constant := 16#7AED#; - LBCD : Constant := 16#43ED#; - LDED : Constant := 16#53ED#; - LSPD : Constant := 16#73ED#; - SBCD : Constant := 16#4BED#; - SDED : Constant := 16#5BED#; - SSPD : Constant := 16#7BED#; - NEG : Constant := 16#44ED#; - RRD : Constant := 16#67ED#; - RLD : Constant := 16#6FED#; - LDI : Constant := 16#A0ED#; - CCI : Constant := 16#A1ED#; - LDD : Constant := 16#A8ED#; - CCD : Constant := 16#A9ED#; - LDIR : Constant := 16#B0ED#; - CCIR : Constant := 16#B1ED#; - LDDR : Constant := 16#B8ED#; - CCDR : Constant := 16#B9ED#; - -End Opcode; - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/OPCODE.SYM b/software/CPM/CPM_MC_C3/OPCODE.SYM deleted file mode 100644 index 3bde179..0000000 Binary files a/software/CPM/CPM_MC_C3/OPCODE.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/PRIME.PKG b/software/CPM/CPM_MC_C3/PRIME.PKG deleted file mode 100644 index e9e4dbf..0000000 --- a/software/CPM/CPM_MC_C3/PRIME.PKG +++ /dev/null @@ -1,32 +0,0 @@ -Pragma RangeCheck(off); Pragma Debug(off); Pragma Arithcheck(off); -@ Pragma Rangecheck(on); Pragma Debug(on); Pragma Arithcheck(on); -Package Body Prime Is --- From Byte Sept. 81 Benchmark evaluation - SIZE : Constant := 8190; - - Flags : Array(0..SIZE) Of Boolean; - Count,k,Prime : Integer; - -Begin - Put("10 Iterations"); New_line; -Ten : For Iter In 1..10 Loop - -- The Loop labels are optional - Count := 0; -Clear : For i In 0..SIZE Loop - Flags(i) := TRUE; - End Loop Clear; -Primes: For i In 0 .. SIZE Loop - If Flags(i) Then - Prime := i + i + 3; - k := i + Prime; - While k <= SIZE Loop - Flags(k) := FALSE; - k := k + Prime; - End Loop; - Count := Count + 1; -@ Put("Prime "); Put(Prime); New_line; - End If; - End Loop Primes; - End Loop Ten; - Put(Count); Put("Primes"); New_line; -End Prime; \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/QSORT.PKG b/software/CPM/CPM_MC_C3/QSORT.PKG deleted file mode 100644 index d7e5c94..0000000 --- a/software/CPM/CPM_MC_C3/QSORT.PKG +++ /dev/null @@ -1,208 +0,0 @@ -Package Body Qsort Is - --- Quicksort Benchmark Program --- Uses non-recursive Quicksort program written by I.R.P. for CS 467 --- Note that this program is only useful in that it shows some of the --- general syntax of ADA as compared to say Pascal --- A similar program is in Wirth's A + DS = P - --- **** Notes for Pascal programmers are noted by --** --- The conditionally compiled lines where for debuging the compiled code --- and may be useful if you wish to understand how the program works - - ZERO : Constant := 0; - NUMRECS : Constant := 200; -- max number of sortable records - Type item Is Record - data1,data2 : Character; - key1 : Integer; - End Record; - Type drecord Is Array (ZERO..NUMRECS) of item; - newrec,datrec : drecord; - total : Integer;-- total number of records - --** Declarations are like in Pascal - - ----------------------------------------------- - - Procedure getrecs (filrec : In Out drecord; sum : In Out integer) Is - -- Initializes the array of records -- - --** these are Like Pascal Var parameters - - aline : Integer; - Begin - For i In 1..100 Loop - Pragma Arithcheck(off); - aline := (i * 3377) Mod 97; - -- Use Overflow and Mod to generate pseudo random sequence - Pragma Arithcheck(on); - filrec(i).key1 := aline; - filrec(i).data1 := 'A'; - filrec(i).data2 := 'Z'; - Put(i); Put(": "); Put(aline); New_line; - End Loop; - sum := 100; - --** Procedure need not have return statements if you wish to - --** fall out the bottom like this one - End getrecs; - - ----------------------------------------------- - - Procedure fileout (outfil : In drecord; send : In Integer) Is - -- writes out sorted records to the screen - - tot : Integer; - Begin - tot := ZERO; - While tot /= send Loop - tot := tot + 1; - Put(tot); Put(": "); Put(outfil(tot).key1); New_line; - End Loop; - Put("TOTAL "); Put(send); New_line; - End fileout;-- fileout - - ----------------------------------------------- - Procedure quicksort (list : In Out drecord; numb : In integer) Is - - MAXSUB : Constant := 21; -- smallest subfile allowed in qsort - STACKDEP : Constant := 20; -- stack size - Type indicies Is Record -- records of partions for stack - beg,edn : Integer; - End Record; - stk,i,j,left,righ : Integer; - t1rec,t2rec : item; -- temp records - Subtype stackptr Is integer Range 1..stackdep; - Type temparr Is Array (stackptr) of indicies; - stack : temparr; - --** The order of declaration need only be in the order neccessary - --** so that types, and constants can be used by other declarations - - Function median (listnam : In drecord; lef,rit : In Integer) - Return Integer Is - --** Note that as compared to Pascal that the parameter passing mode - --** is indicated after the colon - --** Also unlike Pascal, parameters of mode IN need not be specified - --** as such as they are the default of the three kind - - med : Integer; - Begin - --** unlike Pascal, the function name can't be used as a temporary - -- ** variable, as a return is an immediate jump to the End - med := (lef + rit) / 2; -@ Put("med="); Put(med); Put(" lef="); Put(lef); Put(" rit="); -@ Put(rit); New_line; Put(" "); Put(listnam(med).key1); -@ Put(" "); Put(listnam(lef).key1); Put(" "); -@ Put(listnam(rit).key1);Put(" should return median value");New_line; - If (listnam(rit).key1 > listnam(med).key1) Then - If listnam(med).key1 > listnam(lef).key1 Then Return(med); - Elsif (listnam(rit).key1 > listnam(lef).key1) Then Return(lef); - Else Return(rit); - End If; - Elsif listnam(med).key1 < listnam(lef).key1 Then Return(med); - Elsif listnam(rit).key1 < listnam(lef).key1 Then Return(lef); - Else Return(rit); --** functions require Return statements - End If; - End median; - - Procedure stinsertsort (newrec : In Out drecord; m,n : Integer) Is - -- 'm' has starting position,'n' has ending position - -- straight insertion for number of records < 21 is - -- more efficent - - lft : Integer; -- left sorting stop - savrec,xrec : item; -- temporary records - Begin - savrec := newrec(m - 1); -- save the record before the sorting area - For rgt In (m + 1)..n Loop -- Right sorting stop - xrec := newrec(rgt); - newrec(m - 1) := xrec; - lft := rgt - 1; - While xrec.key1 < newrec(lft).key1 Loop -- switch records - newrec(lft + 1) := newrec(lft); - lft := lft - 1; - End Loop; - newrec(lft + 1) := xrec; - End Loop; - newrec(m - 1) := savrec; -- restore that saved record - End stinsertsort; - - Begin - If numb < MAXSUB Then - stinsertsort(list,1,numb); - Else -- file is larger than minimum subfile size - stk := 1; - stack(1).beg := 1; - stack(1).edn := numb; - Loop -- take top request from stack - left := stack(stk).beg; - righ := stack(stk).edn; -@ Put("Stk="); Put(stk); Put(" left="); Put(left); -@ Put(" right="); Put(righ); New_line; - stk := stk - 1;-- sort subfiles less than maxsub - -- by straight insertion sort - If (righ - left) < maxsub Then - stinsertsort(list,left,righ); - Else - Loop -- split intervals - i := left; - j := righ; -@ Put("i=left="); Put(i); Put(" j=righ="); Put(j); -@ Put(" low and high marks of current sort"); New_line; - t1rec := list(median(list,left,righ)); -@ Put("t1rec.key1="); Put(t1rec.key1); -@ Put(" should match median value"); New_line; - Loop - While list(i).key1 < t1rec.key1 Loop - i := i + 1; - End Loop; - While t1rec.key1 < list(j).key1 Loop - j := j - 1; - End Loop; - If i <= j Then - t2rec.key1 := list(i).key1; - list(i).key1 := list(j).key1; - list(j).key1 := t2rec.key1; - i := i + 1; - j := j - 1; - End If; - Exit When i > j; - End Loop; -- Repeat Loop -@ Put("Done Partition - i="); Put(i); Put(" j="); -@ Put(j); New_line; - If (j - left) < (righ - i) Then - If i < righ Then -- stack right partion req. -@ Put("Stack Right"); - stk := stk + 1; - stack(stk).beg := i; - stack(stk).edn := righ; - End If; - righ := j;-- continue sorting left partion - Else - If left < j Then -- stack left partion req. -@ Put("stack left"); - stk := stk + 1; - stack(stk).beg := left; - stack(stk).edn := j; - End If; - left := i; -- continue sorting right partion - End If; - Exit When left >= righ; - End Loop; --** A Repeat Loop in Pascal - End If; - Exit When stk = ZERO; - End Loop; -- Repeat Loop - End If; - End quicksort; - - ----------------------------------------------- - -Begin - getrecs(datrec,total); - Put("**** Sort Start ****"); New_line; - For i In 1..30 Loop - newrec := datrec; - quicksort(newrec,total); - End Loop; - Put("**** 30 Sorts Done ****"); New_line; - fileout(newrec,total); - Put("Qsort Finish"); New_line; -End Qsort; - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/RANDIO.LIB b/software/CPM/CPM_MC_C3/RANDIO.LIB deleted file mode 100644 index 813563e..0000000 --- a/software/CPM/CPM_MC_C3/RANDIO.LIB +++ /dev/null @@ -1,133 +0,0 @@ -With IO, - Sect; -- The Package in which the type sector is declared. -Package Randio Is - - -- Copyright 1984 RR Software, Inc., P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. All Other rights reserved. - - -- - -- JANUS/Ada Random I/O Package. - -- Modeled on Ada Direct_IO. - -- - -- How to use this Package - -- - -- This Package is designed as an Ada Generic Package. However, since - -- Generics are not yet available in JANUS/Ada, the method for using - -- this package is a bit awkward. The Type Sector must imported from - -- some other Package, by changing the With Clause, and the Subtype - -- declaration. Note that the name 'Sector' is used in only one place, - -- and thus can easily be changed to any other type. Then both the - -- Specification and Body of RandIO must be recompiled. - -- - -- The following classes of types must not be used as the type Sector - -- (cannot be output or input): - -- Limited Private Types - -- Access Types - -- Composite Types containing either of the above. - -- Any other type may be output or input. - -- - -- Io.IOResult can be tested for errors in this version. - -- - -- Records are numbered from 1, as per the 1983 Ada Standard. - - Subtype Element_Type Is Sect.Sector; --Replace Sect.Sector with your type - - Type File_Type Is Limited Private; - - -- Many routines below have two forms, one which is compatible with - -- current JANUS/Ada I/O, and the second which is compatible with the - -- 1983 Ada standard. We recommend using the Ada forms wherever - -- possible, as the JANUS/Ada forms will be phased out. - - Type File_Mode Is (IN_File,INOUT_File,OUT_File); - Type Count Is New Natural; - Subtype Positive_Count Is Count Range 1 .. Count'Last; - - Procedure Open (Fyle : In Out File_Type; Name : In String; - Mode : In IO.File_Mode); - -- Opens a file for I/O. JANUS/Ada version. - - Procedure Open (Fyle : In Out File_Type; Mode : In File_Mode; - Name : In String); - -- Opens a file for I/O. Ada 83 version. - - Procedure Create (Fyle : In Out File_Type; Name : In String; - Mode : In IO.File_Mode); - -- Creates a new file for I/O. JANUS/Ada version. - - Procedure Create (Fyle : In Out File_Type; Mode : In File_Mode; - Name : In String); - -- Creates a new file for I/O. Ada 83 version. - - Procedure Close (Fyle : In Out File_Type); - -- Closes a file. - - -- Procedure Delete (Fyle : In Out File_Type); - -- Deletes a file. Ada 83 version. ** Not implemented ** - - -- Procedure Delete (Name : In String); - -- Deletes a file. Janus/Ada version. Use the one in I/O. - - -- Procedure Reset (File : In Out File_Type; Mode : In File_Mode); - -- Resets a file. Ada 83 only. ** Not implemented ** - - Function Mode (Fyle : In File_Type) Return Io.File_Mode; - -- Returns the current mode of Fyle. Janus/Ada version. - - -- Function Mode (Fyle : In File_Type) Return File_Mode; - -- Returns the current mode of Fyle. Ada 83 version. - -- ** Not implemented because overloading on return types - -- is disallowed in Janus/Ada. - - Function Name (Fyle : In File_Type) Return String; - -- Returns the name of Fyle. - - Function Is_Open (Fyle : In File_Type) Return Boolean; - -- Return True if the file is Open. - - Procedure Read (Fyle : In File_Type; Item : Out Element_Type; Rec : In - positive_count); - -- Read the record at record number positive count. IOresult is - -- set to 255 if it does not exist. - - Procedure Read (Fyle : In File_Type; Item : Out Element_Type); - -- Read the record following the last one read or written. - -- IOresult is set to 255 if it does not exist. - - Procedure Write (Fyle : In File_Type; Item : In Element_Type; Rec : In - positive_count); - -- Write the record at record number positive count. IOresult is - -- set to 255 if an error occurs. (The disk is probably full). - - Procedure Write (Fyle : In File_Type; Item : In Element_Type); - -- Write the record following the last one read or written. - -- IOresult is set the same as above. - - Procedure Set_Index (Fyle : In File_Type; Rec : In Positive_Count); - -- Set the next record to be read or written, if a number is not - -- specified. - - Function Index (Fyle : In File_Type) Return Positive_Count; - -- Returns the number of the next record to be read or written. - - Function Size (Fyle : In File_Type) Return Count; - -- Returns the current size of the file, in records. - - Function End_of_File (Fyle : In File_Type) Return Boolean; - -- Returns True if the current index points past the end of the file. - -Private - Type File_Block; - Type File_Type Is Access File_Block; - Type File_Block Is Record - Fyle : File; - Index : Positive_Count; - End Record; -End RandIO; - the next record to be read or written. - - Function Size (Fyle : In File_Type) Return Count; - -- Returns the current size _Type; Item : In Element_Type); - -- Write the record following the last one read or written. - -- IOresult is set the same as a \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/RANDIO.PKG b/software/CPM/CPM_MC_C3/RANDIO.PKG deleted file mode 100644 index fb3dee6..0000000 --- a/software/CPM/CPM_MC_C3/RANDIO.PKG +++ /dev/null @@ -1,439 +0,0 @@ -With IO,Jlib80,Util,Opcode; -Package Body Randio Is - - -- Copyright 1984 RR Software, Inc., P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. All Other rights reserved. - - Pragma Debug(Off); Pragma Arithcheck(Off); Pragma Rangecheck(Off); -@ Pragma Debug(On); Pragma Arithcheck(On); Pragma Rangecheck(On); - - Use Opcode; - - -- - -- JANUS/Ada Random I/O Package. - -- Modeled on Ada Direct_IO. - -- - -- How to use this Package - -- - -- This Package is designed as an Ada Generic Package. However, since - -- Generics are not yet available in JANUS/Ada, the method for using - -- this package is a bit awkward. The Type Sector must imported from - -- some other Package, by changing the With Clause, and the Subtype - -- declaration. Note that the name 'Sector' is used in only one place, - -- and thus can easily be changed to any other type. Then both the - -- Specification and Body of RandIO must be recompiled. - -- - -- The following classes of types must not be used as the type Sector - -- (cannot be output or input): - -- Limited Private Types - -- Access Types - -- Composite Types containing either of the above. - -- Any other type may be output or input. - -- - -- Io.IOResult can be tested for errors in this version. - -- - -- Records are numbered from 1, as per the 1983 Ada Standard. - - -- Subtype Element_Type Is Private; - - -- Type File_Type Is Limited Private; - - -- Many routines below have two forms, one which is compatible with - -- current JANUS/Ada I/O, and the second which is compatible with the - -- 1983 Ada standard. We recommend using the Ada forms wherever - -- possible, as the JANUS/Ada forms will be phased out. - - -- Notes for CP/M-80 version: - -- You must be using CP/M 2.2 or greater. - -- Maximum # of records in a file = 32767. - -- Maximum file size = 8 MegaBytes. - -- Maximum record size = 4095. - -- If the record size is greater than 256 bytes, less than 32000 records - -- can be accessed. Max Records = 65536 / ((Rec_Size + 127)/128). - - -- Storage Method: - -- If the record size is greater than 128, as many 128 byte blocks as - -- necessary are allocated to hold each record. - -- Otherwise, as many records as possible are packed in a single 128 - -- byte record. - -- This allocation scheme means that certain record sizes are very - -- ineffiently stored, 65 and 129 bytes, for example. These sizes should - -- be avoided if possible. - -- Also, this allocation scheme means that Randio files cannot be - -- transfered to MS-DOS. (Sequential files can be transfered without - -- modification). - - -- Type File_Mode Is (IN_File,INOUT_File,OUT_File); - -- Type Count Is New Natural; - -- Subtype Positive_Count Is Count Range 1 .. Count'Last; - - -- Type File_Block; - -- Type File_Type Is Access File_Block; - -- Type File_Block Is Record - -- Fyle : File; - -- Index : Positive_Count; - -- End Record; - - Temp : File_Type; - - qqaddr : Integer; -- Temporaries used below - result : Integer; - fmask : Jlib80.file_ptr; - - REC_SIZE : Constant := Element_Type'Size / 8; - REC_PER_BLOCK : Constant := 128 / REC_SIZE; - BLOCK_PER_REC : Constant := (REC_SIZE + 127) / 128; - - Type Sector Is Array (0..127) Of Byte; - - Type Read_Rec Is Record - Case b:Boolean Is - When True => - buff : Array(1..BLOCK_PER_REC) Of Sector; - When False => - item : Array(0..REC_PER_BLOCK) Of element_type; - End Case; - End Record; - - buffer : Read_Rec; - blk_num : Integer; - - Procedure Open (Fyle : In Out File_Type; Name : In String; - Mode : In IO.File_Mode) Is - -- Opens a file for I/O. JANUS/Ada version. - Begin - Temp := New File_Block; - Io.Open(Temp.Fyle,name,Mode); - If IO.IOresult /= 0 Then -- an error occured - Dispose(Temp); - Fyle := Null; - Else - Fmask := Util.FConvert(Temp.Fyle); - Temp.Index := 1; - Fyle := Temp; - End If; - End Open; - - Function Convert_Mode (Mode : In File_Mode) Return Io.File_Mode Is - Begin - If Mode = IN_File Then - Return IO.Read_Only; - Elsif Mode = INOUT_File Then - Return IO.Read_Write; - Else - Return IO.Write_Only; - End If; - End Convert_Mode; - - Procedure Open (Fyle : In Out File_Type; Mode : In File_Mode; - Name : In String) Is - -- Opens a file for I/O. Ada 83 version. - Begin - Temp := New File_Block; - Io.Open(Temp.Fyle,name,Convert_Mode(Mode)); - If IO.IOresult /= 0 Then -- an error occured - Dispose(Temp); - Fyle := Null; - Else - Fmask := Util.FConvert(Temp.Fyle); - Temp.Index := 1; - Fyle := Temp; - End If; - End Open; - - Procedure Create (Fyle : In Out File_Type; Name : In String; - Mode : In IO.File_Mode) Is - -- Creates a new file for I/O. JANUS/Ada version. - Begin - Temp := New File_Block; - Io.Create(Temp.Fyle,name,Mode); - If IO.IOresult /= 0 Then -- an error occured - Dispose(Temp); - Fyle := Null; - Else - Fmask := Util.FConvert(Temp.Fyle); - Temp.Index := 1; - Fyle := Temp; - End If; - End Create; - - Procedure Create (Fyle : In Out File_Type; Mode : In File_Mode; - Name : In String) Is - -- Creates a new file for I/O. Ada 83 version. - Begin - Temp := New File_Block; - Io.Create(Temp.Fyle,name,Convert_Mode(Mode)); - If IO.IOresult /= 0 Then -- an error occured - Dispose(Temp); - Fyle := Null; - Else - Fmask := Util.FConvert(Temp.Fyle); - Temp.Index := 1; - Fyle := Temp; - End If; - End Create; - - Procedure Close (Fyle : In Out File_Type) Is - -- Closes a file. - Begin - If Fyle = Null Then - Put("** File Not Open"); Util.Err_Exit; - End If; - fmask := Util.FConvert(fyle.fyle); - fmask.fmode := Byte(1); -- Set mode to read_only - IO.Close(fyle.fyle); -- Close the file, without dumping the - -- (unused) buffer - Dispose(Fyle); - End Close; - - -- Procedure Delete (Fyle : In Out File_Type); - -- Deletes a file. Ada 83 version. ** Not implemented ** - - -- Procedure Delete (Name : In String); - -- Deletes a file. Janus/Ada version. Use the one in I/O. - - -- Procedure Reset (File : In Out File_Type; Mode : In File_Mode); - -- Resets a file. Ada 83 only. ** Not implemented ** - - Function Mode (Fyle : In File_Type) Return Io.File_Mode Is - -- Returns the current mode of Fyle. Janus/Ada version. - Begin - If Fyle = Null Then - Put("** File Not Open"); Util.Err_Exit; - End If; - Return IO.Mode(Fyle.Fyle); - End Mode; - - -- Function Mode (Fyle : In File_Type) Return File_Mode; - -- Returns the current mode of Fyle. Ada 83 version. - -- ** Not implemented because overloading on return types - -- is disallowed in Janus/Ada. - - Function Name (Fyle : In File_Type) Return String Is - -- Returns the name of Fyle. - Begin - If Fyle = Null Then - Put("** File Not Open"); Util.Err_Exit; - End If; - Return IO.Name(Fyle.Fyle); - End Name; - - Function Is_Open (Fyle : In File_Type) Return Boolean Is - -- Return True if the file is Open. - Begin - If Fyle = Null Then - Return False; - Else - Return IO.Is_Open(Fyle.Fyle); - End If; - End Is_Open; - - Procedure Read (Fyle : In File_Type; Item : Out Element_Type; Rec : In - positive_count) Is - -- Read the record at record number positive count. IOresult is - -- set to 255 if it does not exist. - Begin - If Fyle = Null Then - Put("** File Not Open"); Util.Err_Exit; - End If; - Fyle.Index := Rec; - Read(Fyle,Item); - End Read; - - Procedure Read (Fyle : In File_Type; Item : Out Element_Type) Is - -- Read the record following the last one read or written. - -- IOresult is set to 255 if it does not exist. - Begin - If Fyle = Null Then - Put("** File Not Open"); Util.Err_Exit; - End If; -@ Put("Read Block - "); Put(Fyle.index); New_Line; - fmask := Util.FConvert(Fyle.Fyle); - If REC_PER_BLOCK > 1 Then -- Calculate Block number - blk_num := Integer(Fyle.Index) / REC_PER_BLOCK; - fmask.fcb.random_rec1 := Integer(Fyle.index) / REC_PER_BLOCK; - Else - fmask.fcb.random_rec1 := Integer(Fyle.index) * BLOCK_PER_REC; - End If; - - If BLOCK_PER_REC > 1 Then -- Need Loop - For i In 1..BLOCK_PER_REC Loop - qqaddr := Buffer.buff(i)'address; -- Get the sector address - Asm LHLD,qqaddr'address; - Asm XCHG; - Asm MVIC,26; -- Set address of Buffer - Asm CALL,5,0; -- Call CP/M - - qqaddr := fmask.fcb'address; -- Fyle FCB address - Asm LHLD,qqaddr'address; - Asm XCHG; - Asm MVIC,33; -- Read Random Sector Opcode - Asm CALL,5,0; -- Call CP/M - Asm MOVLA,MVIH,0; - Asm SHLD,result'address; - - Exit When Result /= 0; -- Give up if some error occurred - End Loop; - Else -- Just read a single block. - qqaddr := Buffer.buff(1)'address; -- Get the sector address - Asm LHLD,qqaddr'address; - Asm XCHG; - Asm MVIC,26; -- Set address of Buffer - Asm CALL,5,0; -- Call CP/M - - qqaddr := fmask.fcb'address; -- Fyle FCB address - Asm LHLD,qqaddr'address; - Asm XCHG; - Asm MVIC,33; -- Read Random Sector Opcode - Asm CALL,5,0; -- Call CP/M - Asm MOVLA,MVIH,0; - Asm SHLD,result'address; - End If; - - Fyle.index := Fyle.index + 1; - If result /= 0 Then - IO.IOresult := 255; - Else - IO.IOresult := 0; - End If; - - -- Get the item to return - If REC_PER_BLOCK > 1 Then - Item := Buffer.item(blk_num); - Else - Item := Buffer.item(0); - End If; - - End Read; - - Procedure Write (Fyle : In File_Type; Item : In Element_Type; Rec : In - positive_count) Is - -- Write the record at record number positive count. IOresult is - -- set to 255 if an error occurs. (The disk is probably full). - Begin - If Fyle = Null Then - Put("** File Not Open"); Util.Err_Exit; - End If; - Fyle.Index := Rec; - Write(Fyle,Item); - End Write; - - Procedure Write (Fyle : In File_Type; Item : In Element_Type) Is - -- Write the record following the last one read or written. - -- IOresult is set the same as above. - junk : Element_type; - Begin - If Fyle = Null Then - Put("** File Not Open"); Util.Err_Exit; - End If; -@ Put("Write Block - "); Put(Fyle.Index); New_Line; - fmask := Util.FConvert(Fyle.Fyle); - If REC_PER_BLOCK > 1 Then -- Calculate Block number - -- Must read the block so that the other records in it are not - -- killed. - Read(fyle,junk); -- Buffer contains the current record, now - Fyle.index := Fyle.index - 1; - blk_num := Integer(Fyle.Index) / REC_PER_BLOCK; - fmask.fcb.random_rec1 := Integer(Fyle.index) / REC_PER_BLOCK; - Buffer.item(blk_num) := Item; -- Set the item to write. - Else - fmask.fcb.random_rec1 := Integer(Fyle.index) * BLOCK_PER_REC; - Buffer.item(0) := Item; -- Set the item to write. - End If; - - If BLOCK_PER_REC > 1 Then -- Need Loop - For i In 1..BLOCK_PER_REC Loop - qqaddr := Buffer.buff(i)'address; -- Get the sector address - Asm LHLD,qqaddr'address; - Asm XCHG; - Asm MVIC,26; -- Set address of Buffer - Asm CALL,5,0; -- Call CP/M - - qqaddr := fmask.fcb'address; -- Fyle FCB address - Asm LHLD,qqaddr'address; - Asm XCHG; - Asm MVIC,34; -- Write Random Sector Opcode - Asm CALL,5,0; -- Call CP/M - Asm MOVLA,MVIH,0; - Asm SHLD,result'address; - - Exit When Result /= 0; -- Give up if some error occurred - End Loop; - Else -- Just write a single block. - qqaddr := Buffer.buff(1)'address; -- Get the sector address - Asm LHLD,qqaddr'address; - Asm XCHG; - Asm MVIC,26; -- Set address of Buffer - Asm CALL,5,0; -- Call CP/M - - qqaddr := fmask.fcb'address; -- Fyle FCB address - Asm LHLD,qqaddr'address; - Asm XCHG; - Asm MVIC,34; -- Write Random Sector Opcode - Asm CALL,5,0; -- Call CP/M - Asm MOVLA,MVIH,0; - Asm SHLD,result'address; - End If; - - Fyle.index := Fyle.index + 1; - If result /= 0 Then - IO.IOresult := 255; - Else - IO.IOresult := 0; - End If; - End Write; - - Procedure Set_Index (Fyle : In File_Type; Rec : In Positive_Count) Is - -- Set the next record to be read or written, if a number is not - -- specified. - Begin - If Fyle = Null Then - Put("** File Not Open"); Util.Err_Exit; - End If; - Fyle.Index := Rec; - End Set_Index; - - Function Index (Fyle : In File_Type) Return Positive_Count Is - -- Returns the number of the next record to be read or written. - Begin - If Fyle = Null Then - Put("** File Not Open"); Util.Err_Exit; - End If; - Return Fyle.Index; - End Index; - - Function Size (Fyle : In File_Type) Return Count Is - -- Returns the current size of the file, in records. - Begin - If Fyle = Null Then - Put("** File Not Open"); Util.Err_Exit; - End If; - fmask := Util.FConvert(Fyle.Fyle); - - qqaddr := fmask.fcb'address; -- Fyle FCB address - Asm LHLD,qqaddr'address; - Asm XCHG; - Asm MVIC,35; -- Random File Size - Asm CALL,5,0; -- Call CP/M - Asm MOVLA,MVIH,0; - Asm SHLD,result'address; - - If REC_PER_BLOCK > 1 Then - Return Count(Fmask.FCB.Random_rec1-1) * REC_PER_BLOCK; - Else - Return Count((Fmask.FCB.Random_rec1-1) / BLOCK_PER_REC); - End If; - - End Size; - - Function End_of_File (Fyle : In File_Type) Return Boolean Is - -- Returns True if the current index points past the end - -- of the file. - Begin - blk_num := Integer(Size(Fyle)); - Return Fyle.index > Count(blk_num); - End End_of_File; - -End RandIO; - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/RANDOM.JRL b/software/CPM/CPM_MC_C3/RANDOM.JRL deleted file mode 100644 index 96a0f1d..0000000 Binary files a/software/CPM/CPM_MC_C3/RANDOM.JRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/RANDOM.LIB b/software/CPM/CPM_MC_C3/RANDOM.LIB deleted file mode 100644 index 11367dc..0000000 --- a/software/CPM/CPM_MC_C3/RANDOM.LIB +++ /dev/null @@ -1,18 +0,0 @@ -Package random Is - - -- - -- Simple random number generator - -- - - Procedure Set_Seed; - -- Initialize the random number generator to its default seeds - - Procedure Set_Seed(x,y,z : Integer); - -- Sets the seeds to any three arbitrary integers - - Function rand return long_float; - -- Returns a random number in the range 0..1 - -End random; - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/RANDOM.SYM b/software/CPM/CPM_MC_C3/RANDOM.SYM deleted file mode 100644 index 3c79f18..0000000 Binary files a/software/CPM/CPM_MC_C3/RANDOM.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/SECT.LIB b/software/CPM/CPM_MC_C3/SECT.LIB deleted file mode 100644 index c8201b2..0000000 --- a/software/CPM/CPM_MC_C3/SECT.LIB +++ /dev/null @@ -1,19 +0,0 @@ -Package Sect Is - -- Used to define an example Type for use with the standard JANUS/Ada - -- Package Randio. - - Type Sector Is Array (0..127) Of Byte; - -End Sect; - End End_of_File; - -End RandIO; - Return Count(Fmask.FCB.Random_rec1-1) * REC_PER_BLOCK; - Else - Return Count((Fmask.FCB.Random_rec1-1) / BLOCK_PER_REC); -ile, in records. - Begin - If Fyle = Null Then - Put("** File Not Open"); Util.Err_Exit; - End If; - fmask := Util.FConve \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/SFLOATIO.JRL b/software/CPM/CPM_MC_C3/SFLOATIO.JRL deleted file mode 100644 index c21da02..0000000 Binary files a/software/CPM/CPM_MC_C3/SFLOATIO.JRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/SFLOATIO.LIB b/software/CPM/CPM_MC_C3/SFLOATIO.LIB deleted file mode 100644 index a73275d..0000000 --- a/software/CPM/CPM_MC_C3/SFLOATIO.LIB +++ /dev/null @@ -1,42 +0,0 @@ -Package SFloatio Is - - -- Floating Point I/O Package - -- Written March 1983 - -- Last Modified 2/ 5/84 - - -- Copyright (c) 1982,1983,1984 - -- RR Software, Inc., P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. All Other rights reserved. - - Pragma Arithcheck(Off); Pragma Rangecheck(Off); - @ Pragma Arithcheck(On); Pragma Rangecheck(On); - - Procedure Get(Fyle : In File; Value : Out Float); - Procedure Get(Value : Out Float); - -- Gets a value from the file - - Procedure Put(Fyle : In File; Value : In Float); - Procedure Put(Value : In Float); - Procedure Put(Fyle : In File; Value : In Float; Fore : In Integer); - Procedure Put(Value : In Float; Fore : In Integer); - Procedure Put(Fyle:In File; Value : In Float; Fore,Aft : In Integer); - Procedure Put(Value : In Float; Fore,Aft : In Integer); - Procedure Put(Value : In Float; Fore,Aft,Exp : In Integer); - Procedure Put(Fyle : In File; Value : In Float; - Fore,Aft,Exp : In Integer); - -- Puts formatted value to file - - Function Float_to_String(Value : In Float) Return String; - Function Float_to_String(Value : In Float; fore,aft,exp : Integer) - Return String; - -- Formats value into a string - -End SFloatIo; -lue : In Float; Fore,Aft : In Integer); - Procedure Put(Value : In Float; Fore,Aft,Exp : In Integer); - Procedure Put(Fylrocedure Get(Value : Out Float); - -- Gets a value from the file - - Procedure Put(Fyle : In File; Value : In Float); - Pr \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/SFLOATIO.SYM b/software/CPM/CPM_MC_C3/SFLOATIO.SYM deleted file mode 100644 index 47ccded..0000000 Binary files a/software/CPM/CPM_MC_C3/SFLOATIO.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/SFLOATOP.JRL b/software/CPM/CPM_MC_C3/SFLOATOP.JRL deleted file mode 100644 index 3a6de90..0000000 Binary files a/software/CPM/CPM_MC_C3/SFLOATOP.JRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/SFLOATOP.LIB b/software/CPM/CPM_MC_C3/SFLOATOP.LIB deleted file mode 100644 index caa350a..0000000 --- a/software/CPM/CPM_MC_C3/SFLOATOP.LIB +++ /dev/null @@ -1,109 +0,0 @@ -Package SFloatop Is - - -- Floating Point Operations Package (Single Precision) - -- Written August 1983 - -- Last Modified 9/ 6/83 - - -- This module works on the same principle as the 8087. Not all 8087 - -- operations are supported, however, only those that are needed are - -- supported. Supported types are Short Float (4 Bytes), Long Float - -- (8 Bytes), Short Integer (2 Bytes), Long Integer (4 Bytes), and - -- Temporary Float (Size depends on implementation - Max. is 10 Bytes). - - -- Initialization is performed by the package body. - - -- This specification cannot be modified without modifying the compiler's - -- code generator. - - -- Copyright 1982,1983 RR Software, Inc., P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. All Other rights reserved. - - Pragma Syslib(2); -- Tell the compiler that this is the floating - -- point library. - - Procedure Ferror_chk; - -- Check for floating point errors. - Procedure FLD_Short_Float(addr : Integer); - -- Load a Short Float into the floating point unit. Addr is the - -- address of the value. - Procedure FST_Short_Float(addr : Integer); - -- Store a Short Float from the floating point unit, POPing the stack - Procedure FLD_Long_Float(addr : Integer); - -- Load a Long Float into the floating point unit - Procedure FST_Long_Float(addr : Integer); - -- Store a Long Float from the floating point unit, POPing the stack - Procedure FLD_Short_Integer(addr : Integer); - -- Load a Short Integer into the floating point unit - Procedure FST_Short_Integer(addr : Integer); - -- Store a Short Integer from the floating point unit, POPing the - -- stack. A error occurs if the number is not an integer. - Procedure FLD_Long_Integer(addr : Integer); - -- Load a Long Integer into the floating point unit - Procedure FST_Long_Integer(addr : Integer); - -- Store a Long Integer from the floating point unit, POPing the - -- stack. A error occurs if the number is not an integer. - Procedure FLD_Temp_Float(addr : Integer); - -- Load a Temp Float into the floating point unit. (Note: This is - -- not the same format as the 8087!). - Procedure FST_Temp_Float(addr : Integer); - -- Store a Temp Float fron the floating point unit, POPing the stack - - Function Fcmp_LT Return Boolean; - -- Return TOS < NOS; Toss both operands - Function Fcmp_LE Return Boolean; - -- Return TOS <= NOS; Toss both operands - Function Fcmp_EQ Return Boolean; - -- Return TOS = NOS; Toss both operands - Function Fcmp_NE Return Boolean; - -- Return TOS /= NOS; Toss both operands - Function Fcmp_GE Return Boolean; - -- Return TOS >= NOS; Toss both operands - Function Fcmp_GT Return Boolean; - -- Return TOS > NOS; Toss both operands - - Procedure FXCHG; - -- Exchange TOS with NOS. - Procedure FADD; - -- NOS := TOS + NOS; Toss TOS - Procedure FSUB; - -- NOS := TOS - NOS; Toss TOS - Procedure FMUL; - -- NOS := TOS * NOS; Toss TOS - Procedure FDIV; - -- NOS := TOS / NOS; Toss TOS - Procedure FABS; - -- TOS := ABS TOS - Procedure FNEG; - -- TOS := - TOS - Procedure FRNDINT; - -- TOS := Integer(TOS) [Integer Round] - Procedure FEXP(cnt : Integer); - -- TOS := TOS ** cnt - Procedure Finit; - -- Clear the unit (generally used after an exception) - - Function Float_OK Return Boolean; - -- Returns true if the floating point library can be executed. - -- Mainly intended for use with Hardware libraries - will return - -- False if the Hardware is missing or does not work. - -- [Replaces Have_8087!] - - -- Errors: - -- Stack Overflow. - -- Bad Operand. - -- Overflow. - -- Underflow (result is rounded to zero). - - -- To call these externally, would use something like: - -- SFloatop.FLD_Short_Float(Value'Address); - -End SFloatOp; -rue if the floating point library can be executed. - -- Mainly intended for use with Hardware libraries - will return - -- FalsProcedure FDIV; - -- NOS := TOS / NOS; Toss TOS - Procedure FABS; - -- TOS := ABS TOS - Procedure FNEG; - -- TOS := - TOS \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/SFLOATOP.SYM b/software/CPM/CPM_MC_C3/SFLOATOP.SYM deleted file mode 100644 index 8dd5eea..0000000 Binary files a/software/CPM/CPM_MC_C3/SFLOATOP.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/SMATHLIB.JRL b/software/CPM/CPM_MC_C3/SMATHLIB.JRL deleted file mode 100644 index 5644989..0000000 Binary files a/software/CPM/CPM_MC_C3/SMATHLIB.JRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/SMATHLIB.LIB b/software/CPM/CPM_MC_C3/SMATHLIB.LIB deleted file mode 100644 index 64d7406..0000000 --- a/software/CPM/CPM_MC_C3/SMATHLIB.LIB +++ /dev/null @@ -1,73 +0,0 @@ -Package SMathlib Is - -- Single Precision Mathematic functions library - -- Last modified 2/ 1/84 - - -- Copyright 1983,84 RR Software, Inc., P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. All Other rights reserved. - - - PI : Constant := 3.14159_26535_89793_23846; - E : Constant := 2.71828_18284_59045_23536; - LOG10_E : Constant := 0.43429_44819_03251_82765; -- Log10(e) - - Function Sqrt (Val : In Float) Return Float; - -- Returns the sqrt of val - - Function Round (Val : In Float) Return Float; - -- Rounds val to an integer value, and returns it as a float - - Function Trunc (Val : In Float) Return Float; - -- Truncate val to its integer part, and returns it as a float - - Function Exp (Val : In Float) Return Float; - -- Returns e ** Val - -- To get 10 ** val, divide by LOG10_E. - - Function Log (Val : In Float) Return Float; - -- Returns the natural logarithm of Val. Val must be > 0. - -- To get Log10, multiply by LOG10_E. - - Function Power (Val,Exp : In Float) Return Float; - -- Returns Val ** Exp - - -- All angles are in radians! - Function Sin (Angle : In Float) Return Float; - -- Returns the Sine of the angle - - Function Cos (Angle : In Float) Return Float; - -- Returns the Cosine of the angle - - Function Tan (Angle : In Float) Return Float; - -- Returns the Tangent of the Angle - - Function ArcTan (Val : In Float) Return Float; - -- Returns the ArcTangent of the Value - - Function ArcCos (Val : In Float) Return Float; - -- Returns the ArcCosine of the Value - - Function ArcSin (Val : In Float) Return Float; - -- Returns the ArcSine of the Value - - Function ArcTan2(X,Y : In Float) Return Float; - -- Returns the ArcTangent of X / Y - - Function Deg_to_Rad (Angle : In Float) Return Float; - -- Converts the Angle in Degrees to the same angle in Radians - - Function Rad_to_Deg (Angle : In Float) Return Float; - -- Converts the Angle in Radians to the same angle in Degrees - -End SMathlib; - In Float) Return Float; - -- Returns the ArcSine of the Value - - Function ArcTan2(X,Y : In Float) Return Float; - -- Returns the ArcTangent of X / Y - - Function Deg_to_Rad (Angle : In Float) Return Float; - -- Converts the Angle in Degrees to the same angle in Radians - - Function Rad_to_Deg (Angle : In Float) Return Float; - -- Converts the Angle in Radians to the sam \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/SMATHLIB.SYM b/software/CPM/CPM_MC_C3/SMATHLIB.SYM deleted file mode 100644 index 8a171a1..0000000 Binary files a/software/CPM/CPM_MC_C3/SMATHLIB.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/SRANDOM.JRL b/software/CPM/CPM_MC_C3/SRANDOM.JRL deleted file mode 100644 index e84ac6f..0000000 Binary files a/software/CPM/CPM_MC_C3/SRANDOM.JRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/SRANDOM.LIB b/software/CPM/CPM_MC_C3/SRANDOM.LIB deleted file mode 100644 index 28817d0..0000000 --- a/software/CPM/CPM_MC_C3/SRANDOM.LIB +++ /dev/null @@ -1,18 +0,0 @@ -Package srandom Is - - -- - -- Simple random number generator - -- - - Procedure Set_Seed; - -- Initialize the random number generator to its default seeds - - Procedure Set_Seed(x,y,z : Integer); - -- Sets the seeds to any three arbitrary integers - - Function rand return float; - -- Returns a random number in the range 0..1 - -End srandom; - - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/SRANDOM.SYM b/software/CPM/CPM_MC_C3/SRANDOM.SYM deleted file mode 100644 index 674c3bb..0000000 Binary files a/software/CPM/CPM_MC_C3/SRANDOM.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/STANDARD.SYM b/software/CPM/CPM_MC_C3/STANDARD.SYM deleted file mode 100644 index 694ac55..0000000 Binary files a/software/CPM/CPM_MC_C3/STANDARD.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/STRLIB.JRL b/software/CPM/CPM_MC_C3/STRLIB.JRL deleted file mode 100644 index 5fcb60a..0000000 Binary files a/software/CPM/CPM_MC_C3/STRLIB.JRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/STRLIB.LIB b/software/CPM/CPM_MC_C3/STRLIB.LIB deleted file mode 100644 index 8ff619c..0000000 --- a/software/CPM/CPM_MC_C3/STRLIB.LIB +++ /dev/null @@ -1,37 +0,0 @@ -Package Strlib Is - -- String Handling Package Specification - -- Last Modified 6/ 3/82 - - - -- Copyright 1982 RR Software, P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. - - - Subtype Mstring Is String(255); -- Maximum string length - Subtype StrIndex Is Integer Range 0..255; -- Maximum string indices - -Function Length (str : In Mstring) Return Integer; - -- Return the length of the string -Function Remove (str : In Mstring; pos,size : In StrIndex) Return Mstring; - -- Remove size characters from str at pos -Function Insert (source,dest : In MString; pos : In StrIndex) Return MString; - -- Insert source into dest at pos -Function Extract (str : In Mstring; pos,size : In StrIndex) Return Mstring; - -- Extract size characters from str at pos -Function Position (pattern,str : Mstring) Return Integer; - -- Return the position of the first occurance of pattern in str, - -- or 0 if there is none -Function char_to_str (char : character) Return String; - -- Convert a character into a string of length 1 -Function str_to_int (str : Mstring) Return Integer; - -- Convert a string into an integer -Function int_to_str (int : Integer) Return Mstring; - -- Convert an integer into a string - -End Strlib; - : Mstring) Return Integer; - -- Return the position of the first occurance of pattern in str, - -- or 0 if there is nonemove (str : In Mstring; pos,size : In StrIndex) Return Mstring; - -- Remove size characters from str at pos -Function Insert \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/STRLIB.SYM b/software/CPM/CPM_MC_C3/STRLIB.SYM deleted file mode 100644 index dce4156..0000000 Binary files a/software/CPM/CPM_MC_C3/STRLIB.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/TIMELIB.LIB b/software/CPM/CPM_MC_C3/TIMELIB.LIB deleted file mode 100644 index 42798dc..0000000 --- a/software/CPM/CPM_MC_C3/TIMELIB.LIB +++ /dev/null @@ -1,39 +0,0 @@ -Package Timelib Is - -- Time Library - Contains procedures for getting the time and date - -- from MS-DOS - - - -- Copyright 1982 RR Software, P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. - - -Type time Is Record - hours : Integer; - Minutes: Integer; - seconds: Integer; - fract : Integer; -End Record; - -Type date Is Record - year : Integer; - month : Integer; - day : Integer; -End Record; - -Function get_time Return Time; -- Get and return the current time -Function get_date Return Date; -- Get and return the current date -Procedure put_date(fyle : In file; day : date); - -- Put the date to the file -Procedure put_time(fyle : In file; clk : time); - -- Put the time to the file -Function elapsed_time(start,finish : Time) Return Time; - -- Figure the elapsed time between start and finish - -End Timelib; -Package Timelib Is - -- Time Library - Contains procedures for getting the time and date - -- from MS-DOS - - - -- Copyri \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/TIMELIB.PKG b/software/CPM/CPM_MC_C3/TIMELIB.PKG deleted file mode 100644 index 6278a9a..0000000 --- a/software/CPM/CPM_MC_C3/TIMELIB.PKG +++ /dev/null @@ -1,124 +0,0 @@ -With Util; -- Hi and Lo are used in here -Package Body Timelib Is - --- Time Library - Get the current time and date -- --- Not implemented for CP/M-80 - user may add their own implementation --- Last modified 9/ 7/82 - - - -- Copyright 1982 RR Software, P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. - - -Use Util; - -time1,time2 : Integer; -- Local temporary variables - -Function get_time Return Time Is - -- Get and return the current time - temp : time; -Begin - Put("Get_time not implemented - User must implement"); New_Line; - temp.hours := 12; - temp.minutes := 0; - temp.seconds := 0; - temp.fract := 0; - Return Temp; -End get_time; - -Function get_date Return Date Is - -- Get and return the current date - temp : date; -Begin - Put("Get_date not implemented - User must implement"); New_Line; - temp.year := 1982; - temp.month := 9; - temp.day := 7; - Return Temp; -End get_date; - -Procedure put_date(fyle : In file; day : date) Is - -- Put the date to the file -Begin - Case day.month Is - When 1 => Put(fyle,"January "); - When 2 => Put(fyle,"February "); - When 3 => Put(fyle,"March "); - When 4 => Put(fyle,"April "); - When 5 => Put(fyle,"May "); - When 6 => Put(fyle,"June "); - When 7 => Put(fyle,"July "); - When 8 => Put(fyle,"August "); - When 9 => Put(fyle,"September "); - When 10 => Put(fyle,"October "); - When 11 => Put(fyle,"November "); - When 12 => Put(fyle,"December "); - When Others => Put(fyle,"** Bad Date ** "); - End Case; - Put(fyle,day.day); Put(fyle,", "); - Put(fyle,day.year); -End put_date; - -Procedure put_time(fyle : In file; clk : time) Is - -- Put the time to the file -Begin - Put(fyle,clk.hours); Put(fyle,":"); - If clk.minutes In 0..9 Then Put(fyle,'0'); End If; - Put(fyle,clk.minutes); Put(fyle,":"); - If clk.seconds In 0..9 Then Put(fyle,'0'); End If; - Put(fyle,clk.seconds); Put(fyle,"."); - If clk.fract In 0..9 Then Put(fyle,'0'); End If; - Put(fyle,clk.fract); -End put_time; - -Function elapsed_time(start,finish : Time) Return Time Is - -- Figure the elapsed time between start and finish - temp : time; -Begin - temp.hours := finish.hours - start.hours; - temp.minutes := finish.minutes - start.minutes; - temp.seconds := finish.seconds - start.seconds; - temp.fract := finish.fract - start.fract; - If temp.hours >= 0 Then -- adjust so all fields are positive - If temp.fract < 0 Then - temp.fract := temp.fract + 100; - temp.seconds := temp.seconds - 1; - End If; - If temp.seconds < 0 Then - temp.seconds := temp.seconds + 60; - temp.minutes := temp.minutes - 1; - End If; - If temp.minutes < 0 Then - temp.minutes := temp.minutes + 60; - temp.hours := temp.hours - 1; - End If; - If temp.hours < 0 Then - Put("*Error* Negative time elapsed"); New_Line; - End If; - Else - Put("*Error* Negative time elapsed"); New_Line; - End If; - Return temp; -End elapsed_time; - -End Timelib; - s := temp.seconds + 60; - temp.minutes := temp.minutes - 1; - End If; - If temp.minutes < 0 Then - temp.minutes := temp.minutes + 60; - temp.hours := temp.hours - 1; - End If; - If temp.hours < 0 Then - Put("*Error* Negative time elapsed"); New_Line; - End If; - Else - Put("*Error* Negative time elapsed"); New_Line; - End If; - Return temp; -End elapse temp.fract := temp.fract + 100; - temp.seconds := temp.seconds - 1; - End If; - If temp.seconds < 0 Then - temp.secon \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/TIMELIB.SYM b/software/CPM/CPM_MC_C3/TIMELIB.SYM deleted file mode 100644 index cff7063..0000000 Binary files a/software/CPM/CPM_MC_C3/TIMELIB.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/UTIL.JRL b/software/CPM/CPM_MC_C3/UTIL.JRL deleted file mode 100644 index 5110522..0000000 Binary files a/software/CPM/CPM_MC_C3/UTIL.JRL and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/UTIL.LIB b/software/CPM/CPM_MC_C3/UTIL.LIB deleted file mode 100644 index 3b4108f..0000000 --- a/software/CPM/CPM_MC_C3/UTIL.LIB +++ /dev/null @@ -1,47 +0,0 @@ -With Jlib80; -Package Util Is - -- Spec for the package util - -- Last modifed 9/22/82 - -- Contains the utility routines, and the basic file handling routines - - -- Copyright 1982 RR Software, P.O. Box 1512, Madison WI 53701 - -- Permission is hereby given to distribute Object Code produced from - -- these libraries. - - - Use JLib80; -- So the file definitions are available - - Procedure Err_Exit; - Procedure Halt; - Function Hi (val : Integer) Return Byte; - Function Lo (val : Integer) Return Byte; - Function Memavail Return Integer; - Function Maxavail Return Integer; - Function Command_Line Return String; - -- Returns the command line - - -- Default File Procedures - - Function FConvert(Fyle : In File) Return File_ptr; - Procedure FFConvert(Fyle_ptr : In File_Ptr; Fyle : Out File); - -- Convert to and from the type file to the type file_ptr - -- For system use only, Not to be used in user programs. - - Function Standard_Input Return File; - -- Returns the initial default system input file - Function Standard_Output Return File; - -- Returns the initial default system output file - Function Current_Input Return File; - -- Returns the current default input file - Function Current_Output Return File; - -- Returns the current default output file - Procedure Set_Input(Fyle : In File); - -- Set the current default input file to fyle - Procedure Set_Output(Fyle : In File); - -- Set the current default output file to fyle - -End Util; - (val : Integer) Return Byte; - Function Memavail Return Integer; - Function Maxavail Return Integer; - Function Comman \ No newline at end of file diff --git a/software/CPM/CPM_MC_C3/UTIL.SYM b/software/CPM/CPM_MC_C3/UTIL.SYM deleted file mode 100644 index f527f9f..0000000 Binary files a/software/CPM/CPM_MC_C3/UTIL.SYM and /dev/null differ diff --git a/software/CPM/CPM_MC_C3/XREF.PKG b/software/CPM/CPM_MC_C3/XREF.PKG deleted file mode 100644 index 0969e17..0000000 --- a/software/CPM/CPM_MC_C3/XREF.PKG +++ /dev/null @@ -1,261 +0,0 @@ -With IO,STRLIB,Util; -Package Body Xref Is -Use IO,STRLIB,Util; - -- Cross reference program - -- Last Modified 3/12/83 - -- Provided to demonstrate Access types, and to provide a useful tool - -- Only the first MAXLINES occurances of a name will be recorded to - -- save space. - -- If the memory is nearly full, the crossref will be aborted, and - -- what already has been done will be printed. - - -- The crossref'ed words are stored in a Binary Sorted Tree, and then - -- are printted in order by printtree. The line numbers are stored in - -- a linked list attached to each tree node. This algorithm is from - -- Wirth, Algorithms + Data Structures = Programs - ---SY Wong added function reserved_word to omit same, 1/15/83. - - MAXLINES : Constant := 25; - - Type Ident Is New String(20); - Type LNum; -- These types are used to form a linked list - Type Line Is Access Lnum; -- of line numbers - Type LNum Is Record - lno : Integer; - nxt : Line; - End Record; - - Type word; -- These types are used to form a sorted - Type wptr Is Access word; -- binary tree of words - Type word Is Record - key : Ident; - cnt : Integer; -- Number of uses - lnos: Line; -- Line number chain - left,right : wptr; -- Tree pointers - End Record; - - Root : Wptr := Null; - - cur_line : Integer := 1; - inp : File; - tname : String; - -Function reserved_word(str: in string) return boolean is -L:integer; -begin - L:=length(str); - case L is - when 2 => if STR="AT" OR STR="DO" OR STR="IF" OR STR="IN" - OR STR="IO" - OR STR="IS" OR STR="OF" OR STR="OR" then return true; - else return false; end if; - when 3 => if STR="ALL" OR STR="AND" OR STR="END" - OR STR="FOR" OR STR="MOD" OR STR="NEW" OR STR="NOT" - OR STR="OUT" OR STR="PUT" - OR STR="REM" OR STR="USE" then return true; - else return false; end if; - when 4 => if STR="BODY" OR STR="CASE" OR STR="ELSE" - OR STR="EXIT" OR STR="FILE" OR STR="GOTO" OR STR="LOOP" - OR STR="OPEN" OR STR="NULL" - OR STR="TASK" OR STR="THEN" OR STR="TRUE" - OR STR="TYPE" OR STR="UTIL" OR STR="WHEN" OR STR="WITH" - then return true; else return false; end if; - when 5 => if STR="ABORT" OR STR="ARRAY" OR STR="BEGIN" - OR STR="DELAY" OR STR="DELTA" OR STR="ELSIF" - OR STR="ENTRY" OR STR="FALSE" OR STR="RAISE" OR STR="RANGE" - OR STR="WHILE" then return true; else return false; - end if; - when 6 => if STR="ACCEPT" OR STR="ACCESS" OR STR="DIGITS" - OR STR="OTHERS" OR STR="PRAGMA" OR STR="RECORD" - OR STR="RETURN" OR STR="SELECT" OR STR="STRING" - OR STR="STRLIB" - then return true; - else return false; end if; - when 7 => if STR="BOOLEAN" - OR STR="DECLARE" OR STR="GENERIC" OR STR="INTEGER" - OR STR="LIMITED" - OR STR="PACKAGE" OR STR="PRIVATE" OR STR="RENAMES" - OR STR="REVERSE" OR STR="SUBTYPE" then return true; - else return false; end if; - when 8 => if STR="CONSTANT" OR STR="FUNCTION" OR STR="SEPARATE" - OR STR="NEW_LINE" - then return true; else return false; end if; - when 9 => if STR="CHARACTER" - OR STR="EXCEPTION" OR STR="PROCEDURE" OR STR="READ_ONLY" - OR STR="TERMINATE" then return true; - else return false; end if; - when others => return false; - end case; -end reserved_word; - -Procedure printtree(w:wptr) Is - -- This routine recursively prints the cross reference tree - -- This means that is calls itself to print the left and right - -- subtrees of the node passed in. If the node passed in is Null, - -- nothing is done (this guarentees termination). - t : Line; no : Integer := 0; -Begin - If w /= Null Then - printtree(w.left); - Put(w.key); Put("-"); Put(w.cnt); Put(" Usages"); New_Line; - Put(" Lines - "); - -- Print the line numbers - -- This is done by 'walking' the linked list of line numbers - t := w.lnos; -- Start of line number list - While t /= Null Loop - Put(t.lno,4); - no := no + 1; - If no Mod 15 = 0 Then - New_Line; - End If; - t := t.nxt; -- Walk to next line number - End Loop; - New_Line; - printtree(w.right); - End If; - -- Do nothing for a null pointer -End printtree; - -Procedure insert(newkey : String; w : In Out wptr) Is - -- This routine recursively inserts a new word. The tree is recursively - -- searched for the word. If it is found, the line number is added to - -- the line number list. Otherwise, a new node is created and added - -- to the tree. - t : line; -Begin - If w = Null Then -- Not in tree, insert it - w := New word; - w.key := newkey; w.cnt := 1; - w.left := Null; w.right := Null; - w.lnos := New LNum; - w.lnos.lno := Cur_Line; - w.lnos.nxt := Null; -@ Put("Add Word - Memavail = "); Put(memavail()); -@ Put(" Maxavail() = "); Put(maxavail()); New_line; - Elsif newkey < w.key Then - insert(newkey,w.left); - Elsif newkey > w.key Then - insert(newkey,w.right); - Else -- Found it - w.cnt := w.cnt + 1; - If w.cnt < MAXLINES And Then w.lnos.lno /= Cur_Line Then - t := New LNum; - t.lno := Cur_Line; - t.nxt := w.lnos; - w.lnos := t; -@ Put("Add Line - Memavail = "); Put(memavail()); -@ Put(" Maxavail() = "); Put(maxavail()); New_line; -End If; - End If; - If Memavail() In 0..2000 Then -- Dump the tree before the memory runs out - Printtree(root); - Put("Crossref Program Halted at Line Number "); Put(Cur_Line); - Put(" of the source file for insufficient memory"); New_Line; - Halt; - End If; -End Insert; - -Procedure scan_input Is - -- Break up the input into JANUS tokens, and store them in the tree - str : string; - ch : character; - len : Integer; -bool : Boolean; -- Temporary to force garbage collection - Begin - Get(inp,ch); - While Not End_of_File(inp) Loop - len := 1; - str(0) := Character'Val(20); -- Set the string to the maximum - -- possible length - While Not End_Of_File(inp) Loop - -- Only cross reference ID's - If (ch In 'A'..'Z') or (ch In 'a'..'z') Then - <> -- Jump from character constant, below - While (ch In 'A'..'Z') or else (ch In 'a'..'z') or else - (ch In '0'..'9') or else (ch = '_') Loop - If len < 21 Then -- String not full - If ch In 'a'..'z' Then - str(len) := Character'Val(Character'Pos(ch) + - Character'Pos('A') - Character'Pos('a')); - Else - str(len) := ch; - End If; -- Capitalize characters - len := len + 1; - End If; -- Throw away character if string is full - get(inp,ch); - End Loop; - Exit; -- Leave Scanner - Elsif (ch = '-') Then -- Skip comments - get(inp,ch); - If ch /= '-' Then - GoTo NotComment; -- Not a comment - End If; - Loop - get(inp,ch); - Exit When (ch In character'Val(10)..Character'Val(13)) - Or Else (ch = Character'Val(26)); - End Loop; - Cur_Line := Cur_Line + 1; - get(inp,ch); - -- No exit (we'll get another token) - <> Null; -- Do nothing special - Elsif (ch = '"') Then -- Skip strings - While Not End_Of_File(inp) Loop - get(inp,ch); - Exit When ch = '"'; - End Loop; - get(inp,ch); - -- No exit - get another token - Elsif (ch = ''') Then - -- (Must skip the middle character of a char constant) - get(inp,ch); - str(1) := ch; - len := 2; - get(inp,ch); - If ch = ''' Then - len := 1; -- Char constant, skip all - get(inp,ch); -- Skip the character - Elsif str(1) In 'A'..'Z' Then - Goto Id; -- It's an Id, Not a character const. - Elsif str(1) In 'a'..'z' Then - str(1) := Character'Val(Character'Pos(Str(1)) - 32); - GoTo Id; -- Also an ID - Else -- Not an Id - len := 1; -- Reset character - End If; - Elsif (ch = Character'Val(13)) Then - Cur_Line := Cur_Line + 1; -- Next Line; - get(inp,ch); -- Skip the character - Else - get(inp,ch); -- Skip the character - End If; - End Loop; - str(0) := Character'Val(len - 1); -- Set the string length - if not reserved_word(str) and len /= 1 -- len = 1 for null str. - then - bool := "aa" = str; - -- Force garbage collection to get rid of memory full errors - insert(str,root); -- And put it into the tree - end if; - End Loop; - End scan_input; - -Begin - Put("Cross Reference Generator - Version 1.1"); New_Line; - Put("File to Crossref? "); - tname := Get_Line(Current_Input()); - Open(inp,tname,Read_Only); - Scan_Input; - printtree(root); - New_Line; Put(Memavail()); Put(" Bytes Free Memory"); New_Line; - Put("Cross Reference Program Completed"); New_Line; -End Xref; -rs - insert(str,root); -- And put it into the tree - end if; - End Loop; - End scan_input; - -Begin - Put("Cros \ No newline at end of file diff --git a/software/CPM/CPM_MC_C4/CDADDS.MAC b/software/CPM/CPM_MC_C4/CDADDS.MAC deleted file mode 100644 index 49244e3..0000000 Binary files a/software/CPM/CPM_MC_C4/CDADDS.MAC and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDADDS.REL b/software/CPM/CPM_MC_C4/CDADDS.REL deleted file mode 100644 index 23bad3f..0000000 Binary files a/software/CPM/CPM_MC_C4/CDADDS.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDADM3.MAC b/software/CPM/CPM_MC_C4/CDADM3.MAC deleted file mode 100644 index fcd7f7f..0000000 Binary files a/software/CPM/CPM_MC_C4/CDADM3.MAC and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDADM3.REL b/software/CPM/CPM_MC_C4/CDADM3.REL deleted file mode 100644 index 7be8595..0000000 Binary files a/software/CPM/CPM_MC_C4/CDADM3.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDANSI.MAC b/software/CPM/CPM_MC_C4/CDANSI.MAC deleted file mode 100644 index 68083d7..0000000 Binary files a/software/CPM/CPM_MC_C4/CDANSI.MAC and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDANSI.REL b/software/CPM/CPM_MC_C4/CDANSI.REL deleted file mode 100644 index c3a74e2..0000000 Binary files a/software/CPM/CPM_MC_C4/CDANSI.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDBEE.MAC b/software/CPM/CPM_MC_C4/CDBEE.MAC deleted file mode 100644 index dce4fcf..0000000 Binary files a/software/CPM/CPM_MC_C4/CDBEE.MAC and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDBEE.REL b/software/CPM/CPM_MC_C4/CDBEE.REL deleted file mode 100644 index c5e0463..0000000 Binary files a/software/CPM/CPM_MC_C4/CDBEE.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDHZ15.MAC b/software/CPM/CPM_MC_C4/CDHZ15.MAC deleted file mode 100644 index d280a2c..0000000 Binary files a/software/CPM/CPM_MC_C4/CDHZ15.MAC and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDHZ15.REL b/software/CPM/CPM_MC_C4/CDHZ15.REL deleted file mode 100644 index 93a4b2c..0000000 Binary files a/software/CPM/CPM_MC_C4/CDHZ15.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDISB.MAC b/software/CPM/CPM_MC_C4/CDISB.MAC deleted file mode 100644 index e40144d..0000000 Binary files a/software/CPM/CPM_MC_C4/CDISB.MAC and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDISB.REL b/software/CPM/CPM_MC_C4/CDISB.REL deleted file mode 100644 index 89d2683..0000000 Binary files a/software/CPM/CPM_MC_C4/CDISB.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDPERK.MAC b/software/CPM/CPM_MC_C4/CDPERK.MAC deleted file mode 100644 index 0129475..0000000 Binary files a/software/CPM/CPM_MC_C4/CDPERK.MAC and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDPERK.REL b/software/CPM/CPM_MC_C4/CDPERK.REL deleted file mode 100644 index bb6e13d..0000000 Binary files a/software/CPM/CPM_MC_C4/CDPERK.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDSROC.MAC b/software/CPM/CPM_MC_C4/CDSROC.MAC deleted file mode 100644 index b0fe570..0000000 Binary files a/software/CPM/CPM_MC_C4/CDSROC.MAC and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDSROC.REL b/software/CPM/CPM_MC_C4/CDSROC.REL deleted file mode 100644 index f15b41c..0000000 Binary files a/software/CPM/CPM_MC_C4/CDSROC.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDWH19.MAC b/software/CPM/CPM_MC_C4/CDWH19.MAC deleted file mode 100644 index 3870532..0000000 Binary files a/software/CPM/CPM_MC_C4/CDWH19.MAC and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDWH19.REL b/software/CPM/CPM_MC_C4/CDWH19.REL deleted file mode 100644 index 226c6ae..0000000 Binary files a/software/CPM/CPM_MC_C4/CDWH19.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDZEPH.MAC b/software/CPM/CPM_MC_C4/CDZEPH.MAC deleted file mode 100644 index 17955d0..0000000 Binary files a/software/CPM/CPM_MC_C4/CDZEPH.MAC and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CDZEPH.REL b/software/CPM/CPM_MC_C4/CDZEPH.REL deleted file mode 100644 index e5fa115..0000000 Binary files a/software/CPM/CPM_MC_C4/CDZEPH.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/COBLBX.REL b/software/CPM/CPM_MC_C4/COBLBX.REL deleted file mode 100644 index 6c04cb3..0000000 Binary files a/software/CPM/CPM_MC_C4/COBLBX.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/COBLIB.REL b/software/CPM/CPM_MC_C4/COBLIB.REL deleted file mode 100644 index 729f303..0000000 Binary files a/software/CPM/CPM_MC_C4/COBLIB.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/COBLOC b/software/CPM/CPM_MC_C4/COBLOC deleted file mode 100644 index cbca4cb..0000000 Binary files a/software/CPM/CPM_MC_C4/COBLOC and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/COBOL.COM b/software/CPM/CPM_MC_C4/COBOL.COM deleted file mode 100644 index 6f4552d..0000000 Binary files a/software/CPM/CPM_MC_C4/COBOL.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/COBOL1.OVR b/software/CPM/CPM_MC_C4/COBOL1.OVR deleted file mode 100644 index 45e9dfc..0000000 Binary files a/software/CPM/CPM_MC_C4/COBOL1.OVR and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/COBOL2.OVR b/software/CPM/CPM_MC_C4/COBOL2.OVR deleted file mode 100644 index 59f3b70..0000000 Binary files a/software/CPM/CPM_MC_C4/COBOL2.OVR and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/COBOL3.OVR b/software/CPM/CPM_MC_C4/COBOL3.OVR deleted file mode 100644 index 90fb467..0000000 Binary files a/software/CPM/CPM_MC_C4/COBOL3.OVR and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/COBOL4.OVR b/software/CPM/CPM_MC_C4/COBOL4.OVR deleted file mode 100644 index aae9364..0000000 Binary files a/software/CPM/CPM_MC_C4/COBOL4.OVR and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CREF80.COM b/software/CPM/CPM_MC_C4/CREF80.COM deleted file mode 100644 index 30bedcd..0000000 Binary files a/software/CPM/CPM_MC_C4/CREF80.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CRTDRV.REL b/software/CPM/CPM_MC_C4/CRTDRV.REL deleted file mode 100644 index 90867c2..0000000 Binary files a/software/CPM/CPM_MC_C4/CRTDRV.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CRTEST.COB b/software/CPM/CPM_MC_C4/CRTEST.COB deleted file mode 100644 index bfdee1d..0000000 Binary files a/software/CPM/CPM_MC_C4/CRTEST.COB and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/CVISAM.COM b/software/CPM/CPM_MC_C4/CVISAM.COM deleted file mode 100644 index e0a1702..0000000 Binary files a/software/CPM/CPM_MC_C4/CVISAM.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/DEBUG.REL b/software/CPM/CPM_MC_C4/DEBUG.REL deleted file mode 100644 index e1afdc1..0000000 Binary files a/software/CPM/CPM_MC_C4/DEBUG.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/L80.COM b/software/CPM/CPM_MC_C4/L80.COM deleted file mode 100644 index 264e3b5..0000000 Binary files a/software/CPM/CPM_MC_C4/L80.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/LD80.COM b/software/CPM/CPM_MC_C4/LD80.COM deleted file mode 100644 index e7831d8..0000000 Binary files a/software/CPM/CPM_MC_C4/LD80.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/LIB.COM b/software/CPM/CPM_MC_C4/LIB.COM deleted file mode 100644 index 81b1d22..0000000 Binary files a/software/CPM/CPM_MC_C4/LIB.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/M80.COM b/software/CPM/CPM_MC_C4/M80.COM deleted file mode 100644 index f94dc44..0000000 Binary files a/software/CPM/CPM_MC_C4/M80.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/REBUILD.COM b/software/CPM/CPM_MC_C4/REBUILD.COM deleted file mode 100644 index ecdbffc..0000000 Binary files a/software/CPM/CPM_MC_C4/REBUILD.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/RECOVR.COB b/software/CPM/CPM_MC_C4/RECOVR.COB deleted file mode 100644 index 5f12e07..0000000 Binary files a/software/CPM/CPM_MC_C4/RECOVR.COB and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/RUNCOB.COM b/software/CPM/CPM_MC_C4/RUNCOB.COM deleted file mode 100644 index 4726198..0000000 Binary files a/software/CPM/CPM_MC_C4/RUNCOB.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/SEQCVT.COM b/software/CPM/CPM_MC_C4/SEQCVT.COM deleted file mode 100644 index 4b7c631..0000000 Binary files a/software/CPM/CPM_MC_C4/SEQCVT.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C4/SQUARO.COB b/software/CPM/CPM_MC_C4/SQUARO.COB deleted file mode 100644 index a51d637..0000000 Binary files a/software/CPM/CPM_MC_C4/SQUARO.COB and /dev/null differ diff --git a/software/CPM/CPM_MC_C5/ASL.REL b/software/CPM/CPM_MC_C5/ASL.REL deleted file mode 100644 index 94b3ee6..0000000 Binary files a/software/CPM/CPM_MC_C5/ASL.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C5/BERRIES.PLT b/software/CPM/CPM_MC_C5/BERRIES.PLT deleted file mode 100644 index 18b4843..0000000 --- a/software/CPM/CPM_MC_C5/BERRIES.PLT +++ /dev/null @@ -1,10 +0,0 @@ -R:FILE: BERRIES.PLT - -*START - T: TYPE STRAW BERRIES OR ELSE - A: - M:STRAW BERRIES -JN: *START - T: I SURE LIKE @ans@ AND CREAM - E: - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C5/CATALOG b/software/CPM/CPM_MC_C5/CATALOG deleted file mode 100644 index 93243c2..0000000 --- a/software/CPM/CPM_MC_C5/CATALOG +++ /dev/null @@ -1,42 +0,0 @@ -NUMBER SIZE NAME COMMENTS ------- ---- --------------- ----------------------------------------------- -000.1 9K ASL.REL A Small Library. Contains assembly language - modules used with PILOT/P. -000.2 1K BERRIES.PLT Short prgm demoing matching exactly. -000.3 1K CHAIN.REL Module that is used for linking programs. -000.4 1K CHAIN.SUB Batch processor for linking programs. -000.5 34K CPM.HLP Data file used with TUTORIAL.PLT. -000.6 4K DISK.COM Execllent file transfer prgm. -000.7 3K DO.COM A replacement program for submit.com. -000.8 2K GOLDI.PLT Fantasy about a girl and 3 bears. -000.9 2K HIPILOT.PLT Interactive session program. -000.10 1K LESSON1.PLT This is a chained program under LESSONS. -000.11 1K LESSON2.PLT This is a chained program under LESSONS. -000.12 1K LESSONS.PLT Driver program for chaining sample lessons. -000.13 1K LMENU.PLT Menu prgm for LESSONS; prgms chain back here. -000.14 3K MATCH.PZ Source code for the Match routine. -000.15 1K MATCH.REL Assembly language module. -000.16 5K MATCH.SRC Assembly source code. -000.17 2K PRIMS.PZ Declarations for the routines in ASL.REL. -000.18 14K PILOT/P.COM PILOT/P object program. -000.19 14K PILOT/P.DOC Documentation of PILOT/P. -000.20 3K PILOT/P.HDR An include file for PILOT/P. -000.21 17K PILOT/P.PAS PILOT/P source code (Pascal/Z compiler). -000.22 9K PILOT/P.REF Quick Reference Guide. -000.23 1K PILOT/P.SUB Batch processor file to be used with DO.COM -000.24 4K PILOT/PR.HDR The include file with RANDOM and real #s. -000.25 4K SAGE.PLT Lesson in abstraction. -000.26 1K SAMPLE1.PLT Demo - Type, Accept, Match and X. -000.27 1K SAMPLE2.PLT Demo - subroutine. -000.28 2K SAMPLE3.PLT Demo - Menues, selection, and subroutine. -000.29 1K SAMPLE4.PLT Demo - output text to printer device. -000.30 1K SAMPLE5.PLT Demo - reading a data file. -000.31 1K SAMPLE6.PLT Demo - the WAIT stmt. -000.32 1K SAMPLE7.PLT Demo - RANDOM, RND, and RANDOMIZE. -000.33 2K TUTORIAL.PLT Pascal and PILOT program. Tutorial on CP/M - using the data file CPM/HLP. -000.34 1K WAIT.PZ Source code for the Wait routine. -000.35 1K WAIT.REL Assembly language module. -000.36 2K WAIT.SRC Assembly source code. -000.37 4K XDIR.COM Super extended directory program. - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C5/CHAIN.REL b/software/CPM/CPM_MC_C5/CHAIN.REL deleted file mode 100644 index a97b42a..0000000 Binary files a/software/CPM/CPM_MC_C5/CHAIN.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C5/CHAIN.SUB b/software/CPM/CPM_MC_C5/CHAIN.SUB deleted file mode 100644 index 67f1c29..0000000 --- a/software/CPM/CPM_MC_C5/CHAIN.SUB +++ /dev/null @@ -1,10 +0,0 @@ -:SUBMIT CHAIN Program DriveUnit [Optional libraries] -:SUBMIT CHAIN LESSONS B -PILOT/P $2:$1 -PASCAL $1.$2$2X -ASMBL $1.$2$2/REL -ERA $2:$1.SRC -LINK /N:$2:$1 chain $2:$1 asl/s $3 $4 $5/E -ERA $2:$1.REL -DIR $2:$1.* - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C5/COMPILE.SUB b/software/CPM/CPM_MC_C5/COMPILE.SUB deleted file mode 100644 index eee9cff..0000000 --- a/software/CPM/CPM_MC_C5/COMPILE.SUB +++ /dev/null @@ -1,7 +0,0 @@ -Pascal $1.$2$2X -asmbl $1.$2$2/rel -ERA $2:$1.SRC -LINK /N:$2:$1 $2:$1/V asl/s $3 $4 $5/E -ERA $2:$1.REL -DIR $2:$1.* - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C5/CPM.HLP b/software/CPM/CPM_MC_C5/CPM.HLP deleted file mode 100644 index 464ef32..0000000 --- a/software/CPM/CPM_MC_C5/CPM.HLP +++ /dev/null @@ -1,925 +0,0 @@ -65 :General Information on CP/M -.break - CP/M is a monitor control program for microcomputer software -development which uses IBM-compatible flexible disks (floppy disks) for -mass storage. Using a microcomputer mainframe based on Intel's 8080 or -Zilog's Z80 microprocessor, CP/M provides a general environment for program -construction, storage, and editing, along with assembly and program debug -facilities. An important feature of CP/M is that it can be easily altered -to execute with any computer configuration which uses an Intel 8080 or -Zilog Z80 Microprocessor and has at least 20K bytes of main memory with up -to eight IBM-compatable diskette drives. - The CP/M monitor provides access to programs through a comprehensive -file management system. The file subsystem supports a named file -structure, allowing dynamic allocation of file space as well as sequential -and random file access. Using this file system, up to 128 distinct -programs can be stored in both source and machine-executable form. - Digital Research, the designer of CP/M, has provided a set of nine -manuals which describe the use and operation of CP/M in detail. -.pause -.break - These manuals are: - 1. An Introduction to CP/M Features and Facilities - 2. ED: A Context Editor for the CP/M Disk System - 3. ASM: CP/M Assembler User's Manual - 4. DDT: CP/M Dynamic Debugging Tool User's Manual - 5. CP/M 1.4 Interface Guide - 6. CP/M 1.4 System Alteration Guide - 7. CP/M 2.0 User's Guide - 8. CP/M 2.0 Interface Guide - 9. CP/M 2.0 System Alteration Guide - As the reader can see, CP/M supports a context editor, an assembler -(Intel-compatable), and a debugger system. These are available in the -basic CP/M package. There is a large variety of other software available -which can run under CP/M with little or no modification. Such software -includes several assemblers (both 8080 and Z80), a symbolic debugger, -several high-level languages (including FORTRAN IV {compiler}, BASIC-E -{translator}, CBASIC {translator}, many interpretive BASICs, ALGOL, FOCAL, -and C), and several special-purpose applications programs (such as text -formatting systems and accounting systems). - This HELP File addresses itself specifically to the CP/M 2.x Operating -Systems. -.pause -.end -66 :CP/M File References -.break - A file reference identifies a particular file or group of files on a -particular disk attached to CP/M. These file references can be either -unambiguous (ufn) or ambiguous (afn). An unambiguous file reference -uniquely identifies a single file, while an ambiguous file reference may be -satisfied by a number of different files. - - An unambiguous file reference is an exact name of the specified file. -It consists of up to eight characters in the file name and three characters -in the file type. An unambiguous file reference is of the form -- - - pppppppp.sss - - The characters used in specifying an unambiguous file reference may -not contain any of -- - - < > . , ; : = ? * [ ] - - An ambiguous file reference is used for directory search and pattern -matching. The form of an ambiguous file reference is similar to an -unambiguous reference, except the symbol '?' may be interspersed throughout -the file reference. In various commands throughout CP/M, the '?' symbol -.pause -.break -matches any character of a file name in the '?' position. For example, -X?Y.C?M will match XZY.COM and X3Y.CEM. The '*' symbol is used to match -all characters of a file name or file type. For example, *.COM will match -XZY.COM and HELP.COM, while HELP.* will match HELP.COM and HELP.HLP. -.pause -.end -67 :CP/M Line Editing and Output Control -.break - The following are the line editing functions supported by CP/M -- - - rubout Delete and echo the last character typed at the - console. - Ctrl-H Delete the last character typed; Backspace one - character; CRT-oriented - Ctrl-U Delete the entire line typed at the console. - Ctrl-X Delete the entire line typed at the console; Backspace - to the beginning of the current line; CRT-oriented. - Ctrl-R Retype current command line: types a "clean line" - following character deletion with rubouts. - Ctrl-E Physical end of line: carriage is returned, but line - is not sent until the carriage return key is depressed. - Ctrl-M Terminates input (carriage return). - Ctrl-J Terminates current input (line feed); CRT-oriented - Ctrl-C This is used in CP/M to re-initialize the system. - Anytime you change diskettes in a drive, you should - type control-C so that the operating system will know - that a diskette was changed. - Ctrl-Z End input from the console (used in PIP and ED). -.pause -.break - Other control functions affect console output -- - - Ctrl-P This code is used to tell CP/M that characters sent - to the screen should also be sent to the printer. - This will remain in effect until you press control-P - a second time to turn off the routing to the printer, - or until you reset the system. - - Ctrl-S This is used to pause or "freeze" the characters that - are scrolling by on the screen. Pressing any other - character will resume output (scrolling) to the screen. - - Input lines can generally be up to 255 characters in length. They are -not acted upon until the carriage return key is typed. -.pause -.end -68 :CP/M Built-In Commands -.break - The ERA Command - - This command is used to erase files from a diskette. The format is: - ERA FILENAME -Where FILENAME is any valid CP/M filename. The filename may be -prefixed by a drive designator (i.e. ERA B:FILENAME ). If no -designator is given then the currently logged drive will be used. - -EXAMPLE To erase a file called "LETTER.TXT" from drive B, you -would type: - ERA B:LETTER.TXT -.pause -.break - The DIR Command - - This command displays a list of all files on a diskette. - Its format is: - DIR x: - Where x: is an optional drive designator (A:, B:, etc.). If no disk -drive is specified, then CP/M will give you a listing of the files -on the drive that is currently logged. - -EXAMPLE - To get a listing of all the files on drive B, you would type: - DIR B: -.pause -.break - The REN Command - - You may change the name that you have given to a file with the REN -command. To use the REN command, you would type: - - REN NEWNAME=OLDNAME -EXAMPLE To change the name of the file "LETTER.TXT" on drive B -to the new name "MEMO.TXT," you would type: - - REN B:MEMO.TXT=B:LETTER.TXT - - - - The SAVE Command - - The SAVE command places n pages (256-byte blocks) onto disk from the -TPA and names this file ufn. -The form of the SAVE command is: - SAVE xx FILE.COM -.pause -.break - The TYPE Command - - The TYPE command is used in CP/M to display a file on the screen. -To use the TYPE command, enter the following: - - TYPE FILENAME - - This will cause the file to be sent to the screen of the terminal. -When the file is being displayed, you may press CONTROL-S to stop -the scrolling. To continue scrolling, press any other character. -By preceding the TYPE command with a CONTROL-P, the output will -also be sent to the printer. - -EXAMPLE To view a file called "LETTER.TXT" on drive B, enter: - - TYPE B:LETTER.TXT - This command will only work to display text files. Displaying -non-text files such as files ending in "COM," may cause your -terminal to do strange things. -.pause -.break - The USER Command - - Upon cold boot, the user is automatically logged in to User Area 0, -which is compatible with CP/M 1.4 directories. The USER command allows -the user to move to another logical area within the same directory; areas -are numbered 0-15. The ERA, DIR, REN, SAVE, and TYPE commands apply to -the current User Area. -.pause -.end -69 :CP/M Transient Commands -.break - The CP/M standard transient commands are -- - - STAT List the number of bytes of storage and data on the - currently logged-in disk, provide statistical - information about particular files, and display or - alter device assignment. - PIP Load the Peripheral Interchange Program for later - disk file and peripheral transfer operations. - ED Load and execute the CP/M text editor program. - SUBMIT Submit a file of commands for batch processing. - XSUB Used in conjunction with SUBMIT, transfers all buffered - console input from CON: to the SUBMIT File. - ASM Load the CP/M assembler and assemble the specified - program from disk. - LOAD Load the file in Intel "hex" machine code format and - produce a file in machine executable form which can be - loaded into the TPA (this loaded program becomes a new - command under the CCP). -.pause -.break - DDT Load the CP/M debugger into the TPA and execute it. - DUMP Dump the contents of a file in hex. - SYSGEN Create a new CP/M system diskette. - MOVCPM Regenerate the CP/M system for a particular memory - size. -.pause -.end -70 :Physical Device Assignments for ARIES-1 -.break - Logical Device Physical Device - - CON: TTY: Model 43 Teletype - CRT: Hazeltine 1500 CRT - BAT: CRT and Modem - UC1: In=CRT, Out=CRT and Modem - RDR: TTY: Model 43 Teletype - PTR: Modem - UR1: CRT and Modem w/CRT Output - UR2: CRT and Modem - PUN: TTY: Model 43 Teletype - PTP: Modem - UP1: CRT and Modem - UP2: CRT and Modem - LST: TTY: Model 43 Teletype - CRT: Hazeltine 1500 CRT - LPT: Modem - UL1: CRT and Modem -.pause -.end -71 :CP/M STAT Command -.break - The STAT Command takes any of the following forms -- - -STAT Calculate the storage remaining on all active drives and print a - message like - x: R/W, SPACE: nnnK -- if disk is Read/Write - x: R/O, SPACE: nnnK -- if disk is Read Only -STAT x: Calculate the storage remaining on the specified drive and print - BYTES REMAINING ON x: nnnK -.pause -.break -STAT x:afn [$S] - Scan the specified files on the specified drive (x: is optional), - and list all files which satisfy the unambiguous reference in - alphabetical order with storage requirements. A table like the - following is generated -- - - Size Recs Bytes Ext Acc - sssss rrrr nnnk ee a/b d:pppppppp.sss - - where - sssss -- number of virtual 128-byte records in file - This field is display if the optional $S is given - rrrr -- number of 128-byte records in each extent of the file - nnnK -- number of bytes (in K, K=1024) allocated to the file - ee -- number of 16K extensions - a/b -- access mode of file; R/O or R/W - d:pppppppp.sss -- drive name (d may be A, B, C, D) and file - name -.pause -.break -STAT x:=R/O - Set the specified drive to Read Only. This is cleared by a warm - boot. When a disk is Read Only, the message - BDOS ERR ON x: READ ONLY - will appear if there is an attempt to write to it. -STAT VAL: - Summarize the status commands. STAT VAL: will print the list -- - - Temp R/O Disk: d:=R/O - Set Indicator: d:filename.typ $R/O $R/W $SYS $DIR - Disk Status : DSK: d:DSK: - User Status : USR: - Iobyte Assign: - CON: = TTY: CRT: BAT: UC1: - RDR: = TTY: PTR: UR1: UR2: - PUN: = TTY: PTP: UP1: UP2: - LST: = TTY: CRT: LPT: UL1: -.pause -.break -STAT DEV: - Display the current logical to physical device mapping. For - example, the list may appear as -- - - CON: = CRT: PUN: = PTP: - RDR: = UR1: LST: = TTY: - -STAT d:afn [$R/O or $R/W or $SYS or $DIR] - Set the various permanent file indicators. R/O=Read/Only, - R/W=Read/Write, SYS=System, DIR=Non-System - -STAT ld1=pd1, ld2=pd2, ... - Change the logical to physical device assignments. Logical - device ld1 is assigned to physical device pd1, etc. The valid - logical device names are -- - - CON: The system console device - RDR: The paper tape reader device - PUN: The paper tape punch device - LST: The output list device -.pause -.break - The valid physical device names are -- - - TTY: Slow speed output device (teletype) - CRT: High speed output device (cathode ray tube) - BAT: Batch processing (CON: input is RDR:, CON: output - is LST:) - UC1: User-defined console - PTR: Paper tape reader - PTP: Paper tape punch - UR1: User-defined reader #1 - UR2: User-defined reader #2 - UP1: User-defined punch #1 - UP2: User-defined punch #2 - LPT: Line printer - UL1: User-defined list device #1 -.pause -.break -STAT d:DSK: - List the characteristics of the disk named "d:"; if "d:" is not -specified, list the characteristics of all active disks. A sample listing: - - d: Drive Characteristics - 65536: 128 Byte Record Capacity - 8192: Kilobyte Drive Capacity - 128: 32 Byte Directory Entries - 0: Checked Directory Entries - 1024: Records/ Extent - 128: Records/ Block - 58: Sectors/ Track - 2: Reserved Tracks - -STAT USR: - List the User Number the user is currently in and the User -Numbers which have files on the currently addressed disk. A sample -listing: - Active User : 0 - Active Files: 0 1 3 -.pause -.end -72 :CP/M PIP Command -.break - PIP (Peripheral Interchange Program) is the CP/M transient which -implements the basic media conversion operations necessary to load, print, -punch, copy, and combine disk files. PIP is initiated by one of the -following forms -- - - PIP Engage PIP, prompt the user with '*', and read - command lines directly from the console. PIP used - in this way is exited by either typing an empty - command line (just a carriage return) or a Ctrl-C - as the first character of the line. - PIP cmnd Engage PIP, execute the specified command, and - return to CP/M. - - The form of each command line in PIP is -- - - destination = source#1, source#2, source#3, ..., source#n -.pause -.break - The general forms of PIP command lines are -- - - x:=y:afn Copy all files satisfying afn from drive y to - drive x. 'y' may be omitted, and, if so, the - currently logged-in drive is selected. - x:ufn=y: Copy the file given by ufn from y to x. 'x' may - be omitted, and, if so, the currently logged-in - drive is selected. - x:afn=y:afn Like the above, but x and/or y may be omitted; the - default drive is selected for the omitted - drive(s). - ld=pd Copy from the specified physical device to the - specified logical device. Valid logical devices - are -- - CON:, RDR:, PUN:, LST: - Valid physical devices are -- - TTY:, CRT:, UC1:, PTR:, PTP:, UR1:, UR2:, - UP1:, UP2:, LPT:, UL1: -.pause -.break -There are many different ways to use PIP. The following examples illustrate -the most common forms - - A>PIP B:=A:FILENAME - Makes a duplicate copy on drive B, of - the file "FILENAME" on drive A. - - A>PIP C:NEWNAME=B:FILENAME - Makes a duplicate copy on drive - C, of the file "FILENAME" on - drive B, calling it "NEWNAME" - on drive C. - - A>PIP B:=A:*.* - Copies all files from drive A to drive B. - -.pause -.break - Additional device names which may be used in PIP commands are -- - - NUL: Send 40 Nulls (ASCII 0) to the device. - EOF: Send a CP/M End of File character (ASCII Ctrl-Z). - INP: Special PIP input source to be patched (see manual). - OUT: Special PIP output destination to be patched (see - manual). - PRN: Same as LST:, but tabs are expanded at every eighth - character position, lines are numbered, and page ejects - are inserted every 60 lines with an initial eject. - - - The user can also specify one or more PIP parameters enclosed in -square brackets separated by zero or more blanks. These parameters are -- - - B Block mode transfer. Data is buffered by PIP until an ASCII X- - Off character (Ctrl-S) is received from the source device. - Dn Delete characters which extend past column n in the transfer of - data to the destination from the character source. - E Echo all transfer operations to the console. - F Filter (remove) form feeds from the file. -.pause -.break - Gn Get File from User Number n (n in the range 0 - 15) - H Hex data transfer. All data is checked for proper Intel hex file - format. - I Ignore ':00' records in the transfer of Intel hex format file. - L Translate upper case to lower case alphabetics. - N Add line numbers to each line transferred to the destination. - O Object file (non-ASCII) transfer. Ignore End of File. - - Pn Include page ejects at every n lines. - Qs^Z Quit copying from the source device or file when the string s - (terminated by Ctrl-Z) is encountered. - R Read system files - Ss^Z Start copying from the source file when the string s is seen. - Tn Expand tabs to every nth column. - U Translate lower case to upper case alphabetics. - V Verify that data has been copied correctly. - W Write over R/O files without console interrogation - Z Zero the parity bit on input for each ASCII character. -.pause -.end -73 :CP/M ED Command -.break - The ED Program is the CP/M system context editor, which allows -creation and alteration of ASCII files. Complete details are given in the -user's manual. - - The following are the error indicators given by ED -- - - ? Unrecognized Command - > Memory buffer full - # Cannot apply command the number of times specified - O Cannot open LIB file in R command - - - The following are the control characters recognized by ED -- - - ^C System reboot - ^E Physical (not entered in command) - ^H Character delete (backspace) - ^I Logical tab - ^J New line (line feed) - ^L Logical in search and substitute strings - ^M New line (carriage return) -.pause -.break - ^U Line delete - ^X Line delete and backspace - ^Z String terminator - Rubout Character delete - Break Discontinue command - - - The following are the commands recognized by ED -- - - nA Append lines - +/- B Beginning/Bottom of buffer - +/- nC Move character positions - +/- nD Delete characters - E Exit - nFs^Z Find string - H End edit, close and reopen files - Is^Z Insert characters - nJ Place strings in juxtaposition - +/- nK Kill (delete) lines - +/- nL Move down/up lines -.pause -.break - nM Macro definition - O Return to original file - +/- nP Move and print pages - Q Quit with no file changes - R Read library file - - nSs1^Zs2^Z - Substitute s2 for s1 - +/- nT Type lines - +/- U Translate lower to upper case if U; none if -U - +/- V Engage/disengage line numbers (verify) - 0V Print memory buffer info (free/total usage) - nW Write lines - nX Transfer n lines to X$$$$$$$.LIB - 0X Empty X$$$$$$$.LIB - nZ Sleep - +/- n Move and type (+/- nLT) - n: Move to absolute line (V engaged) - :n Process from current line to specified line (V engaged) -.pause -.end -74 :CP/M ASM Command -.break - The ASM Command loads and executes the CP/M 8080 assembler. It is of -the form -- - - ASM filename.xyz - -where - - filename ... is the name of the file 'filename.ASM' to assemble - x ... designates the disk name which contains the source - y ... designates the disk name to contain the hex file - (y=Z suppresses generation of the hex file) - z ... designates the disk name to contain the print file - (y=X lists on CON:, y=Z suppresses listing) - - Refer to the ASM Manual for further details. -.pause -.end -75 :CP/M LOAD Command -.break - The LOAD Command reads the file specified, which is assumed to contain -Intel hex format machine code and produces a memory image file which can be -subsequently executed (converts .HEX to .COM files). It is of the form -- - - LOAD filename - -where filename is the name of the file 'filename.HEX'. -.pause -.end -76 :The UNLOAD Command -.break - The UNLOAD Command does the reverse of the LOAD Command -- it converts -COM files to HEX files. It is of the form -- - - UNLOAD filename - -where filename is the name of the file 'filename.COM'. -.pause -.end -77 :CP/M DDT Command -.break - The DDT Program allows dynamic interactive testing and debugging of -programs generated in the CP/M environment. It is invoked by -- - - DDT - DDT filename.HEX - DDT filename.COM - -where 'filename' is the name of the program to be loaded or tested. - - DDT responds to the normal CP/M input line editing characters. - - - DDT responds to the following commands -- - - As Perform inline assembly starting at the specified address s. - D Display memory from the current address for 16 display lines. - Ds Display memory from address s for 16 display lines. - Ds,f Display memory from address s to address f. - Fs,f,c - Fill memory from start address s to final address f with byte c. -.pause -.break - G Start execution at the current value of the PC. - Gs Start execution at the specified address s. - Gs,b Start execution at the specified address s and set a breakpoint - at the address b. - Gs,b,c - Same as above with breakpoints at b and c. - G,b Start execution at the current value of the PC with breakpoint b. - G,b,c - Same as above with breakpoints at b and c. - If Insert a file name f into the default FCB. - L List 12 lines of disassembled code from the current address. - Ls List 12 lines from the specified address s. - Ls,f List lines of disassembled code from s to f. - Ms,f,d - Move the block from address s to f to destination at address d. - R Read file in FCB into memory at 100H. - Rb Read file in FCB into memory with offset b from 100H. - Ss Set (examine and alter) memory starting at address s. - T Trace the next instruction. - Tn Trace the next n instructions. -.pause -.break - U Untrace -- like Trace, but intermediate steps are not displayed. - X Examine all registers and flags. - Xr Examine specified registers or flag, where r may be -- - C Carry flag - Z Zero flag - M Minus (sign) flag - I Interdigit Carry flag - A Accumulator - B BC Reg pair - D DE Reg pair - H HL Reg pair - S Stack pointer - P PC -.pause -.end -78 :The ZDT Command -.break - ZDT is a Z80 version of DDT. It is invoked by typing -- - - ZDT - - The commands recognized by ZDT are input in single-character input -mode. No input line editing is done, and each command expects an exact -input. All byte values are exactly two characters, and all addresses are -exactly four characters. - - - The commands recognized by ZDT are -- - - A bbbb - Enter ASCII characters into memory from keyboard starting at - address bbbb. - B - Warm Boot -- Return to CP/M. - C bbbb eeee nnnn - Compare memory from address bbbb to address eeee to block - starting at nnnn. -.pause -.break - D bbbb eeee - Dump memory from bbbb to eeee. - E bbbb eeee - Search for ASCII string from bbbb to eeee. String is at - most 16 characters. String is terminated by . - F bbbb eeee - Search for hex string from bbbb to eeee. String is - terminated by . - G - Go to next breakpoint. - H aaaa nnnn - Hex add and subtract. Computes aaaa+nnnn and aaaa-nnnn. - I nn - Input. Prints value at port nn. - J nnnn - Jump to and execute at location nnnn. - K - Keyboard echo. - L filename.typ nnnn - Loads specified disk file into location nnnn. -.pause -.break - M bbbb eeee nnnn - Move block from bbbb to eeee-1 to nnnn. - N aaaa - Enter offset aaaa for loading. - O nn dd - Output byte dd to port nn. - P bbbb - Input hex into memory from keyboard starting at bbbb. - advances pointer, or backs pointer. - Q bbbb eeee - Dumps from bbbb to eeee in ASCII. - R n ll tt ss bbbb - Read block of data from disk n of length ll (256-byte pages) - starting at track tt and sector ss placing the data at bbbb. - S bbbb eeee - Disassembly (symbolic dump) from bbbb to eeee. - T bbbb eeee - Destructive memory test from bbbb to eeee-1. - U bbbb - Set breakpoint at bbbb. -.pause -.break - V - Display all currently-set breakpoints. - W n ll tt ss bbbb - Write on disk n the data at bbbb for a length of ll starting - at track tt, sector ss. ll is in 256-byte pages. - X - Display registers. - Z bbbb eeee dd - Zero or set memory from bbbb to eeee-1 with byte dd. -.pause -.end -79 :CP/M SYSGEN Command -.break - The SYSGEN Command - - This command is used to place a copy of CP/M in its reserved place on a -diskette. Anytime you want to create a diskette that can be used in drive A -of your computer, you must use SYSGEN to place a copy of CP/M on the diskette -first. This is because the CP/M operating system always expects to find a -copy of itself on the diskette in drive A. It is invoked by typing: - SYSGEN - Once invoked, the user may be expected to see the following prompts: - A>SYSGEN - - CP/M System Generation Program - - Source Drive (or CR to skip): a - Source on A, then type CR - - Destination Drive (or CR to abort): b - Destination on B, then type CR - - Destination Drive (or CR to abort): -.pause -.end -80 :CP/M SUBMIT and XSUB Commands -.break - The SUBMIT command allows CP/M commands to be batched together for -automatic processing. The form of this command is - - SUBMIT ufn parm1 parm2 ... parmn - - The ufn given in the SUBMIT command must be the filename (not type) of -a file which exists on the currently logged-in disk with an assumed file -type of '.SUB'. Refer to the CP/M Manual for further details. - The XSUB command extends the power of the SUBMIT facility. When -specified as the first line of a SUBMIT File, it self-relocates directly -below the CCP. All subsequent SUBMIT command lines are processed by XSUB, -so that programs which read buffered console input (BDOS Function 10) -receive input directly from the SUBMIT File. While XSUB is in memory, it -prints the message "(xsub active)" on each warm boot. An example of the -use of XSUB to display memory from 100H to 1FFH is -- - XSUB - DDT - D100,1FF - G0 -.pause -.end -81 :CP/M BDOS -- Basic I/O Operations -.break - Function and Number Input Parameters Output Parameters - - System Reset 0 None None - Read Console 1 None ASCII Char in A - Write Console 2 ASCII Char in E None - Read Reader 3 None ASCII Char in A - Write Punch 4 ASCII Char in E None - Write List 5 ASCII Char in E None - Direct Con I/O 6 ASCII Char in E I/O Status in A if E=0FFH - Get I/O Status 7 None I/O Status in A - Put I/O Status 8 I/O Status in E None - Print Buffer 9 Address of string None - terminated by $ - in DE - Read Buffer 10 Address of Read Read Buffer is filled - Buffer in DE - Console Ready 11 None LSB of A is 1 if char - ready -*All function numbers are passed in Reg C. -.pause -.break -I/O Status Byte -- - - Value Bits 6&7 Bits 4&5 Bits 2&3 Bits 0&1 - - 00 CON:=TTY: RDR:=TTY: PUN:=TTY: LST:=TTY: - 01 CRT: PTR: PTP: CRT: - 10 BAT: UR1: UP1: LPT: - 11 UC1: UR2: UP2: UL1: - -Read Buffer -- - - Byte Function - - 1 Maximum Buffer Length - 2 Current Buffer Length (returned value) - 3-n Data (returned values) -.pause -.end -82 :CP/M BIOS -- Basic Disk Operations -.break - Function and Number Input Parameters Output Parameters - - Return Version # 12 None Version Info in HL - H=0 CP/M, H=1 MP/M - L=00 CP/M 1.x, 2x 2.x - Init BDOS 13 None None - Log-In Disk 14 Value in Reg E None - A=0, B=1, C=2, - D=3 - Open File 15 Address of FCB Byte address of FCB - in DE if found or 0FFH if not - Close File 16 Address of FCB Byte address of FCB - in DE if found or 0FFH if not - Search for File 17 Address of FCB Byte address of FCB (0-3) - in DE if found or 0FFH if not - Search for Next 18 Address of FCB Byte address of next FCB - in DE if found or 0FFH if not - Delete File 19 Address of FCB Byte address of FCB (0-3) - in DE if found or 0FFH if not -.pause -.break - Function and Number Input Parameters Output Parameters - Read Next Record 20 Address of FCB 0=successful read - in DE 1=read past EOF - 2=reading random data - Write Next Rec 21 Address of FCB 0=successful write - in DE 1=error in extending - 2=end of disk data - 255=no more dir space - Make File 22 Address of FCB Byte address of FCB or - in DE 255 if no more dir space - Rename FCB 23 Address of FCB Byte Address of Dir entry - in DE or 255 if no match - Return Log Code 24 None Login vector in HL - Read Drive No 25 None Number of logged-in drive - (A=0, B=1, C=2, D=3) - Set DMA Address 26 Address of 128 None - byte buffer in DE -.pause -.break - Function and Number Input Parameters Output Parameters - - Get Alloc Vect 27 None Allocation Vect Addr in - HL - Write Prot Disk 28 None None - Get R/O Vect 29 None HL=R/O Vect Val - Set File Attrib 30 Ptr to FCB in DE Dir code in A - Get Disk Parms 31 None HL=DPB Address - Set/Get Usr Code 32 E=0FFH (get)/Code A=Current code (get)/no - (set) value (set) - Read Random 33 DE=FCB addr A=return code - 1=reading unwritten data - 2=(not used) - 3=can't close curr ext - 4=seek to unwritten ext - 5=(not used) - 6=seek past end of disk -.pause -.break - Function and Number Input Parameters Output Parameters - - Write Random 34 DE=FCB addr A=return code - 1=reading unwritten data - 2=(not used) - 3=can't close curr ext - 4=seek to unwritten ext - 5=dir overflow - 6=seek past end of disk - Compute File Siz 35 DE=FCB addr Random Rec Field set - to file size - Set Random Rec 36 DE=FCB addr Random Rec Field set - - -*All function numbers are passed in Reg C -.pause -.end -83 :CP/M File Types -.break - AIN ALGOL 60 Intermediate ALG ALGOL 60 Source File - ASM Assembler Source File BAK Backup File - BAS BASIC Source File C C Source File - COB COBOL Source File COM "Command" File - FOR FORTRAN IV Source File HEX Intel "hex" code file - HLP HELP File INT BASIC Intermediate File - LST Listing File MAC MACRO-80 Source File - PAS PASCAL Source File PRN Assembler Listing File - REL Relocatable Module SRC PASCAL/MT Source File - SUB SUBMIT File SYM Symbol File - TC Tiny-C Source File TFS TFS Source File - TXT Text File $$$ Temporary File -.pause -.end -84 :CP/M BIOS Jump Vector -.break - The following is a table representing the entry points into the CP/M -BIOS of the major routines accessable to the user -- - - - Routine Relative Offset Comment - - BOOT 00H Cold Start - WBOOT 03H Warm Start - CONST 06H Console Status - Reg A = 00 if no char ready - Reg A = FF if char ready - CONIN 09H Console char in (Reg A) - CONOUT 0CH Console char out (Reg C) - LIST 0FH List out (Reg C) - PUNCH 12H Punch out (Reg C) - READER 15H Reader in (Reg A) -.pause -.break - Routine Relative Offset Comment - - HOME 18H Move to track 00 - SELDSK 1BH Select disk given by Reg C (A=0,B=1,...) - SETTRK 1EH Set track address given by Reg C - (0...76) - SETSEC 21H Set sector address given by Reg C - (1...26) - SETDMA 24H Set subsequent DMA address (RP B&C) - READ 27H Read track/sector (block) - WRITE 2AH Write track/sector (block) - LISTST 2DH List Device Status - Reg A = 00 if no char ready - Reg A = FF if char ready - SECTRAN 30H Translate sector number in Reg C using - table pointed to by DE; physical sector - number returned in Reg L -.pause -.end - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C5/DISK.COM b/software/CPM/CPM_MC_C5/DISK.COM deleted file mode 100644 index 6f38ee7..0000000 Binary files a/software/CPM/CPM_MC_C5/DISK.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C5/DO.COM b/software/CPM/CPM_MC_C5/DO.COM deleted file mode 100644 index 8d2b6f0..0000000 Binary files a/software/CPM/CPM_MC_C5/DO.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C5/GOLDI.PLT b/software/CPM/CPM_MC_C5/GOLDI.PLT deleted file mode 100644 index 4977b3e..0000000 --- a/software/CPM/CPM_MC_C5/GOLDI.PLT +++ /dev/null @@ -1,62 +0,0 @@ -R:FILE: GOLDI.PLT -R:A SHORT STORY. - -R: GOLDILOCKS AND YOU KNOW WHO; 2/7/77 - -T: ONCE UPON A TIME THERE WERE THREE BEARS -T: WHO DO YOU THINK THEY WERE? -A: -T: -T: GOLDILOCKS DIDN'T LIKE PORRIDGE, SO SHE -T: FOUND SOME YOGURT IN THE KITCHEN. NEXT SHE -A: $A -T: -T: THEN THE THREE BEARS CAME HOME. THE LITTLE BEAR -T: SNIFFED AROUND AND SAID ; -A: $B -T: -T: THEN THE BIG DADDY BEAR CHASED GOLDILOCKS ALL -T: OVER THE HOUSE BECAUSE SHE @$A@. -T: -T: GOLDILOCKS HID UNDER THE BED. -T: BABY BEAR HID UNDER THE BED. -T: THEY SAT ON BABY BEAR'S ELECTRIC TRAIN, AND -A: -T: -T: PRETTY SOON MAMA BEAR CAME IN YELLING -T: "WHO ATE UP ALL MY YOGURT?" -A: -T: -T: GOLDILOCKS LAUGHED. -T: BABY BEAR LAUGHED EVEN HARDER. -T: HE SAID "@$B@." -T: MAMA BEAR SAID -A: $C -T: -T: THEN THEY WENT ON A PICNIC. -T: THEY PACKED A BASKET OF PEANUTS AND POPCORN AND ; -A: $F -T: AND BUBLE GUM AND FRISBEES AND LEMONADE. -T: -T: THEY DECIDED TO GO TO ; -A: $P -T: -T: WHEN THEY GOT THERE, THE DADDY BEAR OPENED THE DOOR -T: AND ALL OF THE @$F@ ; -T: FELL OUT OF THE CAR. -T: THE BABY BEAR SAID "@$B@" -T: THE MAMA BEAR SAID "@$C@" -T: THE GREAT BIG DADDY BEAR SAID -A: -T: -T: GOLDILOCKS CRIED "LETS'S GET OUT OF @$P@. -T: LET'S GO HOME." -T: BUT THE CAR HAD A FLAT TIRE AND THEY ALL HAD TO SLEEP -T: IN THE BACK SEAT, AND ALL NIGHT LONG THE DADDY BEAR GRUMBLED -T: "@$B@." -T: -T: -T: -T: THE END -E: - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C5/HIPILOT.PLT b/software/CPM/CPM_MC_C5/HIPILOT.PLT deleted file mode 100644 index 905e1fc..0000000 --- a/software/CPM/CPM_MC_C5/HIPILOT.PLT +++ /dev/null @@ -1,44 +0,0 @@ -R: FILE: HIPILOT.PLT -R: A TYPICAL INTERACTIVE SESSION. -R: - T: Hi there, is this your first time on a computer? - A: - C:ucase(ans) - M:YES!SURE!OK!YEAH - TY: I hope you will enjoy your experience with me. - : In the area of education, what are your main interests? -*MORE - A: - C:ucase(ans) - M:TEACH!INSTR!LEARN!MATERIAL - JY:*TEACHING - M:ADMIN!PROGRAM!TEST!GRAD!ANALYS!COURSE!CURR - JY:*OTHER - T:Please tell me more about this. - JN: *MORE -*TEACHING - T: An excellent way of using computers for teaching and learning - : is to give children an opportunity to write their own programs. - : How does this strike you? - A: - C:ucase(ans) - M:GOOD!EXCEL!FINE!YES!IMPORTANT!OK - TN: I see you disagree. Will you explain further? - JY: *YES - A: -*YES - T: Of course the teacher should write programs too, however, - : it isn't always necessary to use "packaged curricula" - : for effective use of the computer in learning situations. - E: -*OTHER - T: Are you interested in the computer's application to teaching? - A: - C:ucase(ans) - M:NO!NEVER - JN: *TEACHING - T: Then perhaps 'PILOT' is not for you. PILOT's intention is - : for it's use by teachers and children for interactive dialogues. - : Thank you for your time and interest. - E: - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C5/ILIB.REL b/software/CPM/CPM_MC_C5/ILIB.REL deleted file mode 100644 index 6e15769..0000000 Binary files a/software/CPM/CPM_MC_C5/ILIB.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C5/LESSON1.PLT b/software/CPM/CPM_MC_C5/LESSON1.PLT deleted file mode 100644 index 3559db9..0000000 --- a/software/CPM/CPM_MC_C5/LESSON1.PLT +++ /dev/null @@ -1,11 +0,0 @@ -R: FILE: LESSON1.PLT - - T:@$c@ - T: LESSON #1 - T: - T: @$n@, AFTER PROGRESSING THRU THESE LESSONS WE - T: AUTOMATICALLY RETURN TO THE MAIN PROGRAM. - W:5 - L: LMENU - E: - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C5/LESSON2.PLT b/software/CPM/CPM_MC_C5/LESSON2.PLT deleted file mode 100644 index dc5a9d7..0000000 --- a/software/CPM/CPM_MC_C5/LESSON2.PLT +++ /dev/null @@ -1,11 +0,0 @@ -R: FILE: LESSON2.PLT - - T:@$c@ - T: LESSON #2 - T: - T: @$n@, AFTER PROGRESSING THRU THESE LESSONS WE - T: AUTOMATICALLY RETURN TO THE MAIN PROGRAM. - W:5 - L: LMENU - E: - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C5/LESSONS.PLT b/software/CPM/CPM_MC_C5/LESSONS.PLT deleted file mode 100644 index 18497fa..0000000 --- a/software/CPM/CPM_MC_C5/LESSONS.PLT +++ /dev/null @@ -1,25 +0,0 @@ -R: FILE: LESSONS.PLT -R: BY COMBINING PILOT AND PASCAL/Z WE CAN CHAIN TO OTHER PROGRAMS. -R: THIS PROGRAM DEMONSTRATES HOW TO CHAIN WITH PASCAL/Z. -R: YOU MUST FOLLOW THE DIRECTIONS GIVEN IN THE PASCAL/Z MANUAL CONCERNING -R: CHAINING AND THE PROGRAM CHAINED TO MUST FOLLOW THE CP/M FILE NAMING -R: CONVENTION. - -T:WELCOME -T: -T:WHAT IS YOUR NAME?; -A:$n -t:THANK YOU @$n@. NOW WE WILL TAKE AN ADVENTURE. - -r: first time flag; = 1 means 1st time here; = 0 means not 1st time. -c: #f := 1 - -r: clear screen string for Zenith terminal. -c:$c[1]:=chr(27); $c[2]:='E'; setlength($c,2) - -r: string to home up the cursor but not clear the screen. -c:$h[1]:=chr(27); $h[2]:='H'; setlength($h,2) - -T: -L:LMENU - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C5/LMENU.PLT b/software/CPM/CPM_MC_C5/LMENU.PLT deleted file mode 100644 index eb8cb01..0000000 --- a/software/CPM/CPM_MC_C5/LMENU.PLT +++ /dev/null @@ -1,45 +0,0 @@ -R: FILE: LMENU.PLT - -%:QUIRY( message: strng; goodchars: charset; var c: char ) -T:@message@; -C:REPEAT keyin(ch) -C: c := toupper(ch) -C: IF c IN goodchars THEN writeln(ch) ELSE write(chr(7)) -C:UNTIL c IN goodchars -E: - -*BEGIN - T:@$c@ - x: #f=1 - TY: WELCOME @$n@ TO USAGE OF A COMPUTER. - TY: - CY: #f:=0 - TN: - TN: -*AGAIN - T:YOU HAVE THESE OPTIONS: - T: 0) END TODAYS SESSION. - T: 1) BEGINNING USE OF THE COMPUTER. - T: 2) MORE ADVANCED USES OF THE COMPUTER. - T: - U:QUIRY(' YOUR CHOICE?',['0','1','2'],ch) - C: ans[1]:=ch; setlength(ans,1) - M:0 - JY:*END - M:1 - JY:*LESSON1 - M:2 - JY:*LESSON2 - J:*AGAIN - -*LESSON1 - L:LESSON1 - -*LESSON2 - L:LESSON2 - -*END - T: THANK YOU FOR COMING @$n@. - T: GOODBYE. - E: - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C5/MATCH.PZ b/software/CPM/CPM_MC_C5/MATCH.PZ deleted file mode 100644 index 7346127..0000000 --- a/software/CPM/CPM_MC_C5/MATCH.PZ +++ /dev/null @@ -1,77 +0,0 @@ -PROCEDURE match( patterns : string255; {these patterns } - delim : char; {separated by this delimiter} - source : string255; {against this source string} - var status : boolean ); {returning this flag } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -LAST EDITED: 03/03/84 rep - -RETURNS: - 'status' true if any of the patterns appear in the source string. - - -DECLARE: - TYPE string0 = string 0; - string255 = string 255; - - CALL AS: - match ( 'YES!yes!NO!no', '!', ans,flag ); - match ( $s, '!', ans,flag ); - - Required: - function vlength(); from ASL.REL - procedure setlength(); Pascal/Z supplied extension. - function index(); Pascal/Z supplied extension. -+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -TYPE - nodeptr = ^node; - node = record - data : STRING 18; { MATCH MAXIMUM OF 18 CHARACTERS PER ARGUMENT } - next : nodeptr - end; -VAR - i : integer; - a, - root: nodeptr; -{$C-,F-,R-,S-,M-} -{ - NAME MATCH - ENTRY MATCH -} -{ setlength - forces the length of string 's' to length 'n' } -PROCEDURE setlength ( VAR s: string0; n: integer ); external; - -{ vlength - returns length of ANY length string. super fast! } -FUNCTION vlength ( VAR s: string0 ): integer; external; - -{ index - returns the position of pattern in source else 0 } -FUNCTION index ( source,pattern: string255 ): integer; external; -{ -MATCH: -} -BEGIN - root := NIL; - append(patterns,delim); - i := 0; - WHILE ivlength(patterns)) OR (patterns[i]=delim)) DO - BEGIN - append(a^.data,patterns[i]); - i := i+1 - END - END; - - a := root; - status := false; - WHILE (a<>NIL) AND (status=false) DO - BEGIN - status := (index(source,a^.data)<>0); - a := a^.next - END -END{match}; - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C5/MATCH.REL b/software/CPM/CPM_MC_C5/MATCH.REL deleted file mode 100644 index 6bee7be..0000000 Binary files a/software/CPM/CPM_MC_C5/MATCH.REL and /dev/null differ diff --git a/software/CPM/CPM_MC_C5/MATCH.SRC b/software/CPM/CPM_MC_C5/MATCH.SRC deleted file mode 100644 index 1ca09f6..0000000 --- a/software/CPM/CPM_MC_C5/MATCH.SRC +++ /dev/null @@ -1,256 +0,0 @@ -;PROCEDURE match( patterns : string255; {these patterns } -; delim : char; {separated by this delimiter} -; source : string255; {against this source string} -; var status : boolean ); {returning this flag } -;{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -;LAST EDITED: 03/03/84 rep -; -;RETURNS: -; 'status' true if any of the patterns appear in the source string. -; -; -;DECLARE: -; TYPE string0 = string 0; -; string255 = string 255; -; -; CALL AS: -; match ( 'YES!yes!NO!no', '!', ans,flag ); -; match ( $s, '!', ans,flag ); -; -; Required: -; function vlength(); from ASL.REL -; procedure setlength(); Pascal/Z supplied extension. -; function index(); Pascal/Z supplied extension. -;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -;TYPE -; nodeptr = ^node; -; node = record -; data : STRING 18; { MATCH MAXIMUM OF 18 CHARACTERS PER ARGUMENT } -; next : nodeptr -; end; -;VAR -; i : integer; -; a, -; root: nodeptr; -;{$C-,F-,R-,S-,M-} -C SET 0 -F SET 0 -R SET 0 -S SET 0 -M SET 0 - - NAME MATCH - ENTRY MATCH - -;{ vlength - returns length of ANY length string. super fast! } -;FUNCTION vlength ( VAR s: string0 ): integer; external; - EXT VLENGTH -; -;{ setlength - forces the length of string 's' to length 'n' } -;PROCEDURE setlength ( VAR s: string0; n: integer ); external; - EXTD L171,SETLENGT -; -;{ index - returns the position of pattern in source else 0 } -;FUNCTION index ( source,pattern: string255 ): integer; external; - EXTD L173,INDEX - -MATCH: - ENTR D,2,6 -; root := NIL; - MOV -4(IX),A - MOV -5(IX),A -; append(patterns,delim); - PUSH IX - POP H - LXI B,522 - DADD B - PUSH H - LXI H,255 - PUSH H - MOV H,A - LXI B,266 - PUSH IX - DADX B - MOV L,0(IX) - POP IX - INR H - PUSH H - LXI H,2 - PUSH H - CALL L137 -; i := 0; - MOV 0(IX),A - MOV -1(IX),A -; WHILE ivlength(patterns)) OR (patterns[i]=delim)) DO -L254 - MOV L,-1(IX) - MOV H,0(IX) - PUSH H - PUSH IX - POP H - LXI B,522 - DADD B - PUSH H - CALL VLENGTH - POP H - GRET D,0 - JC L259 - MOV L,-1(IX) - MOV H,0(IX) - XCHG - LXI H,522 - ADDR IX - MOV D,A - MOV E,M - MOV H,A - LXI B,266 - PUSH IX - DADX B - MOV L,0(IX) - POP IX - DSB1 D,0 -; BEGIN - JZ L253 -; append(a^.data,patterns[i]); - MOV H,-2(IX) - MOV L,-3(IX) - PUSH H - LXI H,18 - PUSH H - MOV L,-1(IX) - MOV H,0(IX) - XCHG - LXI H,522 - ADDR IX - MOV D,A - MOV E,M - INR D - PUSH D - LXI H,2 - PUSH H - CALL L137 -; i := i+1 - MOV L,-1(IX) - MOV H,0(IX) -; END - INX H - MOV 0(IX),H - MOV -1(IX),L -; END; - JMP L254 -L253 -L256 EQU L253 -L257 EQU L256 -L259 EQU L257 - JMP L200 -L199 -; a := root; - MOV L,-5(IX) - MOV H,-4(IX) - MOV -2(IX),H - MOV -3(IX),L -; status := false; - MOV H,9(IX) - MOV L,8(IX) - MOV M,A -; WHILE (a<>NIL) AND (status=false) DO -L329 - MOV L,-3(IX) - MOV H,-2(IX) - MOV D,A - MOV E,A - DSB1 D,0 - JZ L328 - LXI H,9 - ILOD H,1,0 - MOV A,L - CMPI D,0 - MOV A,H -; BEGIN - JNZ L328 -; status := (index(source,a^.data)<>0); - PUSH IX - POP H - LXI B,265 - DADD B - SPSH S,255 - MOV H,-2(IX) - MOV L,-3(IX) - SPSH S,255 - CALL L173 - MOV H,A - MOV L,A - DSB1 D,0 - JRZ L349 - INR A -L349 - MOV L,A - XRA A - MOV H,A - XCHG - MOV H,9(IX) - MOV L,8(IX) - MOV M,E -; a := a^.next -; END - LXI H,-2 - ILOD H,2,-19 - MOV -2(IX),H - MOV -3(IX),L -;END{match}; - JMP L329 -L328 - EXIT D,515,6 - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C5/PILOT#P.COM b/software/CPM/CPM_MC_C5/PILOT#P.COM deleted file mode 100644 index eacceca..0000000 Binary files a/software/CPM/CPM_MC_C5/PILOT#P.COM and /dev/null differ diff --git a/software/CPM/CPM_MC_C5/PILOT#P.DOC b/software/CPM/CPM_MC_C5/PILOT#P.DOC deleted file mode 100644 index 6c912b7..0000000 --- a/software/CPM/CPM_MC_C5/PILOT#P.DOC +++ /dev/null @@ -1,418 +0,0 @@ - - - - - PILOT/P - - Implementing a High-Level Language in a Hurry - by David Mundie - - Documentation by Raymond E. Penley, Feb 26, 1984 - - - - - -With PILOT/P one has the features of the languages Pascal and PILOT. PILOT/P -is a PILOT to Pascal translator. It was originally written for the UCSD Pascal -language but has since been rewritten to use the Pascal/Z compiler by Ithaca -Intersystems. Pascal/Z has all the standard Pascal constructs plus the ability -to chain to another program, thereby increasing the flexibility of the PILOT -langugae. - -The experienced Pascal programmer may add additional variables, functions, -real numbers, and procedures by modifying the file "PILOT.HDR". - -The program has been modified to conform, as much as possible, to standard -PILOT syntax since its original publication in the July 1980 issue of BYTE. - -To compile the PILOT/P program SAMPLE1.PLT residing on the diskette in -drive B, execute the PILOT/P submit program: - - A>DO PILOT/P SAMPLE1 B - -Programs that utilize the program linking statement must be compiled using -the CHAIN submit program instead of the PILOT/P submit program. - -Let us assume that these PILOT/P programs are a complete lesson and that -they are all on the diskette in drive unit B. - - LESSON.PLT, LMENU.PLT, LESSON1.PLT, LESSON2.PLT, and LESSON3.PLT - -Then the following commands will compile and link all the progrms: - - A>DO / - *DO CHAIN LESSON B - *DO CHAIN MENU B - *DO CHAIN LESSON1 B - *DO CHAIN LESSON2 B - *DO CHAIN LESSON3 B - * - -(The order in which they are done is not important.) -When completed all the required programs will be on drive B. - -Recommended placement of programs on a 2 drive system: - -DRIVE A DRIVE B ------------- ----------------- -PILOT/P.COM PILOT/P programs. -PILOT/P.SUB SAMPLE1.PLT -PROGRAMS CAN BE -PILOT/P.HDR ON DRIVE A IF ROOM. -DO.COM -Supersub renamed. -PASCAL.COM -MAIN.SRC -ASMBL.COM -LINK.COM -ASL.REL -A Small Library (Pascal/Z User's Group) -CHAIN.REL -CHAIN.SUB -LIB.REL -EDITOR.COM -YOUR FAVORITE EDITOR -PIP.COM -STAT.COM - - ------------------------------------------------------------------------------- - PILOT/P INSTRUCTIONS ------------------------------------------------------------------------------- - - - TYPE (T:) - -SYNTAX: ------------------------------------------------------------------------------- - T [] : - T [] : ; ------------------------------------------------------------------------------- - -DESCRIPTION: Displays a message to the PILOT user. A message can consist of -a literal character string, string variables and numeric variables. All char- -acter positions to the right of the colon are reproduced in a literal -fashion with the execption that the values of variables are inserted as -replacements for their names. String variable names are identified by -beginning with "$" and numeric variable names by beginning with "#". -Variables may be displayed if their names are enclosed by at-signs "@". -The second form of the TYPE statement will print the message and hold the -cursor immediately following the last character on the same line. - -LIMITATIONS: Never print a string variable that has not been defined by a -previous assignment. The results are unpredictable and usually disasterous. -The length of a TYPE statement is limited to 78 characters, including the 'T' -and ':'. - -EXAMPLE: ------------------------------------------------------------------------------- - T: WELCOME TO PILOT. - T: PLEASE TELL ME YOUR NAME. - A: $N - TN: HI THERE @$N@, I HOPE YOU HAVE A NICE TIME. - C: #X := #X + 1 - T: YOUR NEW SCORE IS @#X@. - T: YOUR NEW SCORE IS @#X:4@. -T: This is a very long type statement. And we are going to reach the limit >>| - T: These two type statements; - T: will print on one line. ------------------------------------------------------------------------------- - - - ACCEPT (A:) - -SYNTAX: ------------------------------------------------------------------------------- - A [] : - A [] : # - A [] : $ ------------------------------------------------------------------------------- - -DESCRIPTION: Opens the console device for the PILOT user to enter a response. -Line editing follows standard CP/M 2.2 line editing. The line terminates -when carriage return is entered. The blank accept statment actually stores -the user input in the system variable "ans". The system variable may be used -at any time in the program. - -LIMITATIONS: Numeric variables and string variables may be any one of the 26 -single letters of the alphabet: a..z. - #a,#b,#c, ...,#z. - $a,$b,$c, ...,$z. - -Upper and lower case letters are considered the same variable. The length of -a response is limited to 80 characters. A numeric variable response may be -+-32767. - -EXAMPLE: ------------------------------------------------------------------------------- - T:WHO ARE YOU? - A: - ..... - T:WHAT IS YOUR NAME? - A:$N - ..... - T:WHAT IS YOUR AGE? - A:#X - ..... ------------------------------------------------------------------------------- - - - MATCH (M:) - -SYNTAX ------------------------------------------------------------------------------- - M [] : [!...!] - M [] : @string variable@ ------------------------------------------------------------------------------- - -DESCRIPTION: Causes a scan of the last user response, the one received by the -last ACCEPT (A:) statement. Patterns in the expression field of the MATCH -statement are compared with the last response. Any item which matches causes -the YN-switch to be set true. Patterns in the list are separated by commas, -with leading or trailing blanks considered part of the pattern. A comma -which terminates the last item is ignored but can serve to indicate the -presence of a trailing blank. A moving window scan of the response with -each pattern occurs until either a match is found or the input is exhausted. - -LIMITATIONS: The match statement does no case translations. The length of -the arguments on the command line is limited to 62 characters max. - M:<------------------- 62 CHARACTERS MAX ----------------------> - M:Washington!Baltimore!California!Tennessee!Mississippi!Maryland - -EXAMPLE: ------------------------------------------------------------------------------- - M:A!B!C - Matches A or B or HAT or ALICE or JOB - M: A! B! C - Matches A or B or ALICE - Does not match JOB or HAT. - M: A ! B ! C ! - Matches only A or B or C - M: A! B! C! a! b! c - Matches upper and lower case. - M:@$a@ - Matches the contents of the string variable $a ------------------------------------------------------------------------------- - - - JUMP (J:) - -SYNTAX: ------------------------------------------------------------------------------- - J [] : ------------------------------------------------------------------------------- - -DESCRIPTION: Jumps to the specified destination in the current program. The -destination must reference an existing label. The label may come before or -after the jump statement. - -LIMITATIONS: A Label statement must be the only statement on a line. The -PILOT/P translator does not check to see that you are jumping to a real -label, also it does not know if you jump to a label that does not exist -anywhere in the program. (A two pass translator would be required to do -that.) - -EXAMPLE: ------------------------------------------------------------------------------- - *START - J:*MORE - ..... - ..... - *MORE - T:ARE YOU READY TO BEGIN? - A: - M:YES - JY:*AGAIN - JN:*START - ..... - *AGAIN - T:I HAVE A QUESTION FOR YOU. - ..... ------------------------------------------------------------------------------- - - - SUBROUTINE (PROCEDURES) (%:) - -SYNTAX: ------------------------------------------------------------------------------- - % : ------------------------------------------------------------------------------- - -DESCRIPTION: Identifies and delimits subroutines. The statement '%:' is -followed by the subroutine name. - -LIMITATIONS: Procedures must be declared before the main program body. - -EXAMPLE: ------------------------------------------------------------------------------- - %: getchoice(var #c:integer) -- procedure starts - R: accepts a number and checks its value - C: REPEAT writeln - T: What is your choice(1 to 10)?; - A: #c - X: #c in [1..10] - TN: @#c:4@,@chr(7)@ is out of range - C: UNTIL flag - E: -- procedure ends ------------------------------------------------------------------------------- - - - USE A SUBROUTINE (U:) - -SYNTAX: ------------------------------------------------------------------------------- - U []: : ------------------------------------------------------------------------------- - -DESCRIPTION: Calls the specified procedure in the current program. - -LIMITATIONS: Only those limitations imposed by your Pascal compiler. Also -see the above instructions on subroutines. - -EXAMPLE: ------------------------------------------------------------------------------- - %:INSTRUCTIONS - T:THE FOLLOWING INSTRUCTIONS APPLY - ..... - E: - *START - T:THIS IS WHERE WE START - T:DO YOU NEED INSTRUCTIONS?; - A: - M:YES - UY:INSTRUCTIONS - ..... ------------------------------------------------------------------------------- - - - END OF SUBROUTINE OR PROGRAM (E:) - - -SYNTAX: ------------------------------------------------------------------------------- - E [] : ------------------------------------------------------------------------------- - -DESCRIPTION: Indicates the end of a subroutine or the end of the current -program. - -EXAMPLE: ------------------------------------------------------------------------------- - %:skip(#x:integer) - C:for #i:=1 to #x do writeln - E: - ..... - T:If you'd like to do more with the abstract and - :concrete, try CLOVE. Bye for now, @$n@. - E: - ..... - *QUIT - T: O.K. @$n@ - T: Try SAGE again if you like. - E: ------------------------------------------------------------------------------- - - - COMPUTE (C:) - -SYNTAX: ------------------------------------------------------------------------------- - C [] : := - C [] : ------------------------------------------------------------------------------- - -DESCRIPTION: Computes a value based on evaluation of the numeric -expression and assigns the result to the numeric variable on the left of -the assignment operator. You may use any legal Pascal expression. All -statements are terminated with a semi-colon and the assignment operator -is the ":=". - -LIMITATIONS: Numeric variable names are the alpha letters A..Z,a..z. -Longer names may not be written unless they are predefined in the file -'PILOT.HDR'. - -EXAMPLE: ------------------------------------------------------------------------------- - C:FOR #i:=1 to 100 DO writeln(#i:5) - C: #X := #X + 5 - C: #X := (#A+5) DIV 15 - C: $s := 'SUNDAY MONDAY TUESDAY WEDENSDAY' ------------------------------------------------------------------------------- - - - REMARK (R:) - -SYNTAX: ------------------------------------------------------------------------------- - R : ------------------------------------------------------------------------------- - -DESCRIPTION: PILOT/P ignores the REMARK statement and blank lines.. It is a -means of storing potentially useful information in the program listing. The -REMARK statement may occur at any point in a PILOT/P program. - -EXAMPLE: ------------------------------------------------------------------------------- - R:-------------------------------- - R:LESSON TWO: DATE WRITTEN: 1/2/84 - R:-------------------------------- ------------------------------------------------------------------------------- - - - PROGRAM LINKING (L:) - -SYNTAX: ------------------------------------------------------------------------------- - L [] : ------------------------------------------------------------------------------- - -DESCRIPTION: Links to another PILOT/P program. - -LIMITATIONS: Must follow the rules in the Pascal/Z manual concerning -chaining programs. Program name must be from 1 to 8 characters only. - -EXAMPLE: ------------------------------------------------------------------------------- - L:LESSON1 ------------------------------------------------------------------------------- - - - WAIT STATEMENT (W:) - -SYNTAX: ------------------------------------------------------------------------------- - W [] : n - W [] : # ------------------------------------------------------------------------------- - -DESCRIPTION: Pauses the specified number of seconds or until any key is -pressed, whichever comes first. The system variable 'ch' contains the key -pressed or if no key was pressed within the specified time period the value -returned is the null (0) character. - -EXAMPLE: ------------------------------------------------------------------------------- - W:5 - X: ch = chr(0) - TY:You must select one of the above, try again. - JY:*AGAIN - M:Q!q ------------------------------------------------------------------------------- - - - BOOLEAN EXPRESSION (X:) - -SYNTAX: ------------------------------------------------------------------------------- - X [] : ------------------------------------------------------------------------------- - -DESCRIPTION: Any Pascal boolean expression may be used, whether arithmetic -or not. - -EXAMPLE: ------------------------------------------------------------------------------- - X: i < length(ans) - X: (ans='HOUSE') or (ans='house') - X: index(ans,'car')<>0 - C: $s := 'SUNDAY MONDAY TUESDAY WEDENSDAY' - X: index($s,'DAY')<>0 ------------------------------------------------------------------------------- - \ No newline at end of file diff --git a/software/CPM/CPM_MC_C5/PILOT#P.HDR b/software/CPM/CPM_MC_C5/PILOT#P.HDR deleted file mode 100644 index fd2de4b..0000000 --- a/software/CPM/CPM_MC_C5/PILOT#P.HDR +++ /dev/null @@ -1,58 +0,0 @@ -{$L-,C-,M-,F-,P+ DO COMPILE PILOT B ASL/S ILIB/S - -Place the program PILOT.PAS ON DRIVE 'B' and these files on drive 'A': -DO.COM, COMPILE.SUB, PRIMS.PZ, ASL.REL, ILIB.REL, LIB.REL, PASCAL.COM, PAS254, -MAIN.SRC, LINK.COM, ASMBL.COM -} -{-------------- Pascal/Z compiler options -----------------} -{$C-}{..........control-c checking OFF } -{$R-}{..........range checking OFF } -{$S-}{..........stack overflow error checking OFF } -{$F-}{..........floating point error checking OFF } -{$M-}{..........integer mult & divd error checking OFF } -{----------------------------------------------------------} - -TYPE - strng = STRING 80; { the length of a "default" string } - byte = 0..255; { single byte integer } - string0 = STRING 0; { special string for Pascal/Z } - string255 = STRING 255; { maximum length for a string } - - lblptr = ^labelrec; - labelrec = RECORD { The data structure of the label list } - name : strng; { THE LABEL'S NAME } - posn : integer; { POSITION OF LABEL IN TREE } - left, { We use a binary tree for faster access } - right : lblptr - end; - - mode =(init, { initial stage of production } - term, { terminator } - prgm, { program mode } - proc, { procedure mode } - unk); { null mode; no activity } - - sym =(progsym, - remsym, {REMARK } - typsym, {TYPE } - mtchsym, {MATCH } - jmpsym, {JUMP } - exitsym, - procsym, {PROCEDURE } - termsym, - computesym, {COMPUTE } - usesym, {USE } - boolsym, - asksym, {ACCEPT } - labelsym, - linksym, {LINK } - waitsym, {WAIT } - null ); - -VAR - badsyntax : boolean; { flag any bad systax in prgm } - buffer : strng; { data line from input file } - - cpos : integer; { current label's position } - tree : lblptr; { the labels tree } - - state : mode; { the current state } - PrevState : mode; { the previous state } - - symbol : sym; { the current symbol } - PrevSym : sym; { the previous symbol } - - temp : strng; { temp usage string } - used_outbuf: boolean; { flag if using outbuf } - - fout, { Output file } - fin : TEXT; { Input file } - -{$iPRIMS.PZ }{Utilities from Pascal/Z Users Group Utility Library disk} - - -PROCEDURE error( message: strng ); -VAR ch: char; -BEGIN - WRITELN( buffer ); - WRITELN( 'ERROR: ',message ); - WRITE( 'Type anything to continue' ); - keyin(ch); - WRITELN; - badsyntax := true; -END{error}; - - -{ strip -- strips blanks and tabs from buffer at position 'i' } - -PROCEDURE strip( i: byte ); -BEGIN - WHILE (buffer[i]=' ') or (buffer[i]=chr(9)) DO delete(buffer,i,1); -END{strip}; - - -PROCEDURE place( VAR tree: lblptr; var key: strng ); -BEGIN - IF tree = NIL THEN BEGIN - NEW(tree); - cpos := cpos+1; - WITH tree^ DO BEGIN - name := key; - posn := cpos; - left := NIL; - right := NIL - END{WITH} - END - ELSE - WITH tree^ DO - IF key < name THEN - place( left,key ) - ELSE IF key > name THEN - place( right,key ) - ELSE - error('DUPLICATE LABEL') -END{place}; - - -FUNCTION FIND( VAR tree: lblptr; VAR key: strng ): lblptr; -BEGIN - if tree=nil then - find := nil - else - WITH tree^ DO - if key < name then - find := find( left,key ) - else if key > name then - find := find( right,key ) - else - find := tree -END{FIND}; - - -FUNCTION lookup( VAR buffer: strng ): INTEGER; -{ tries to find the label contained in buffer in the labels tree. if not - found then the label is inserted into the tree. returns the position of - this label in the tree. } -VAR node: lblptr; -BEGIN - ucase( buffer ); - node := find( tree,buffer ); - if node=nil then begin - place( tree,buffer ); - node := find( tree,buffer ); - end; - lookup := node^.posn; -END{lookup}; - - -PROCEDURE T( VAR buffer: strng ); -{ THIS VERSION WRITTEN BY Raymond E. Penley, Feb 01, 1984 } -{ LAST EDITED: MAR 4, 1984 rep } -{ - THIS INPUT PRODUCES THIS OUTPUT - T:This is a test writeln('This is a test'); - T: writeln; - T:@$a@ writeln($a); - T:@chr(7)@@chr(27)@ writeln(chr(7),chr(27)); - - T:@temp@ is not correct writeln(temp,' is not correct'); - T: your score is @#s@ writeln(' your score is ',#s); - T:Your score is @#s:3@ points writeln('Your score is ',#s:3,' points'); -} -LABEL 9; -CONST delim = '@'; - apos = ''''; -TYPE link = ^object; - object = record { the data structure of the parse list } - TXT : STRNG; - TYP : BOOLEAN; - next: link - end; -VAR empty, { flag for empty queue } - switch : BOOLEAN; { toggle switch for string vs variable } - c : CHAR; - argv : link; { one component of the queue } - front, { front of the queue } - rear : link; { rear component of queue } - I : INTEGER; - width : INTEGER; - - - { getc - returns one character from the input buffer } - PROCEDURE getc( var c: char ); - BEGIN - IF INIL then begin - front := front^.next; - if front=NIL then rear := NIL; - end; - END{retrieve}; - - { enqueue - places a new component at the rear of the queue. 'Arrival' - is a pointer to the new component provided by the caller of the - program. Special action is taken when the queue becomes empty. } - - PROCEDURE enqueue( arrival: link; var front,rear: link ); - BEGIN - if front=NIL - then front := arrival - else rear^.next := arrival; - rear := arrival; - END{enqueue}; - -BEGIN{PROCEDURE T} - WRITE( fout,'WRITE' ); - IF vlength(buffer)=0 THEN BEGIN - WRITELN( fout,'LN;' ); - GOTO 9; - END; - IF buffer[vlength(buffer)]=';' - THEN delete( buffer,vlength(buffer),1 ) - ELSE write ( fout,'LN' ); - IF vlength(buffer)=0 THEN BEGIN - WRITELN( fout,';' ); - GOTO 9; - END; - - front := NIL; { initialize queue pointers } - rear := NIL; - - I := 0; - SWITCH := FALSE; - WHILE Idelim do begin - append(argv^.txt,c); - IF c=apos THEN append(argv^.txt,apos); - argv^.typ := SWITCH; - getc(c); - END; - enqueue( argv,front,rear ); - END; - -{ Rebuild the output string from all the arguments } - setlength( temp,0 ); { temp := ''; } - empty := false; - while not empty do begin - retrieve( argv,front,rear ); - if argv<>nil then begin - CASE argv^.typ OF - TRUE: append(temp,argv^.txt); - FALSE: BEGIN - append(temp,apos); - append(temp,argv^.txt); - append(temp,apos); - END - END{CASE}; - end; - empty := (front=nil) and (rear=nil); - if not empty then append(temp,','); - end; - - if {we} used_outbuf then width := 51 else width := 68; - if vlength(temp) > width - then writeln( fout,'(' ) - else write( fout,'(' ); - writeln( fout,temp,');' ); -9: -END{T}; - - -PROCEDURE Execute( symbol: sym ); -{LAST EDITED: 02/26/84 Ray Penley} -VAR i:INTEGER; -BEGIN - CASE symbol of - labelsym,jmpsym,asksym,linksym,waitsym: - strip{buffer}(1); { purge any blanks/tabs } - end{case}; - CASE symbol of - progsym: { Begin main program symbol. internal program symbol } - WRITELN( fout,'BEGIN initialize;' ); - - remsym: { Remark symbol } - { R: This is a remark } - WRITELN( fout,'{',buffer,'}' ); - - typsym: { Type symbol } - { T: text string } - { TY: text @$a@ text -- type a variable } - T( buffer ); - - mtchsym: { Match symbol } - { M:@$a@ <<< string variable } - { M:a!e!i!o!u <<< text string } - IF buffer[1]='@' THEN BEGIN { match a variable } - copy( temp,buffer,2,2 );{ extract 2 characters from variable } - WRITELN( fout,'match(', temp, ',''!'',ans,flag);' ); - END - ELSE BEGIN{ match a text string } - IF vlength(buffer)>55 - then writeln( fout,'match(' ) - else write ( fout,'match(' ); - WRITELN( fout,'''', buffer, ''',''!'',ans,flag);' ); - END; - - jmpsym,labelsym: { Jump, label symbols } - { *START